Great balls of fire

[B+]

Code: [Select]

'Great balls of fire.bas SmallBASIC 0.12.9 (B+=MGA) 2017-11-23

xxmax = 180 : yymax = 85  'pixels too slow
xstep = xmax / xxmax : ystep = ymax / yymax
dim p(300)  'pallette thanks harixxx
for i = 1 to 100
  fr = 240 * i / 100 + 15
  p(i) = rgb(fr, 0, 0)
  p(i + 100) = rgb(255, fr, 0)
  p(i + 200) = rgb(255, 255, fr)
next
dim f(xxmax, yymax) 'fire array tracks flames
nb = 13             'number of balls
acc = .1            'gravity
br = 4              'ball radius
brs = br * br       'ball radius squared
dim b(1 to nb)      'ball array
for i = 1 to nb     'ball maker
  b(i).x = (xxmax - 2 * br) * rnd + br            'x location
  b(i).y = (yymax - 2 * br) * (i - 1) / nb + br   'y location
  if rnd < .5 then b(i).dx = 1 + rnd * 2 else b(i).dx = -1 - rnd * 2  'dx change of x
  b(i).dy = 1                                                         'dy change of y
next

while 1  'main show
 
  cls 'some flames are sticking
  for i = 0 to xxmax : f(i, yymax) = 0 : f(i, yymax - 1) = 0 : next
  for i = 0 to yymax : f(0, i) = 0 : next
   
  for y = 1 to yymax - 2  'fire based literally on 4 pixels below it like cellular automata
    for x = 1 to xxmax - 1
      f(x, y) = max( (f(x - 1, y + 1) + f(x, y + 1) +f(x + 1, y + 1) + f(x, y + 2) ) / 4 - 5, 0)
      rect x * xstep, y * ystep, step xstep + 1, ystep + 1, p(f(x, y)) filled
    next
  next
 
  for i = 1 to nb  'move ball
    b(i).dy = b(i).dy + acc
   
    'new location unless out of boundsw
    b(i).y = b(i).y + b(i).dy
    b(i).x = b(i).x + b(i).dx
   
    'keep ball in bounds
    if b(i).y > yymax - br then b(i).dy = -.9 * b(i).dy : b(i).y = yymax - br : b(i).dx = b(i).dx *.9
    if b(i).x < br  then b(i).dx = -.9 * b(i).dx : b(i).x = br
    if b(i).x > xxmax - br  then b(i).dx = -.9 * b(i).dx : b(i).x = xxmax - br
   
    'handle new location
    fireBall b(i).x, b(i).y
   
    'handle dead balls
    if abs(b(i).lastbx - b(i).x)< .01 and abs(b(i).lastby-b(i).y) < .01  then
      b(i).x = (xxmax - 2 * br) * rnd + br
      b(i).y =  0
      b(i).dy = 1
      if rnd < .5 then b(i).dx = 1 + rnd * 2 else b(i).dx = -1 - rnd * 2  'edit
    fi
    b(i).lastby = b(i).y : b(i).lastbx = b(i).x
   
  next
  showpage
  delay 10
wend

sub fireBall(x, y)
  local xr, yr, yrMax
  for yr = 0 to br
    if y + yr <= yymax - 2  then f(x, y + yr) = 300
    if y - yr >= 0 then f(x, y - yr) = 300
  next
  for xr = 0 to br
    yrMax = (brs - xr * xr) ^ .5
    for yr = 0 to yrMax
      if x + xr < xxmax - 1 and y + yr <= yymax - 1  then f(x + xr, y + yr) = 300
      if x + xr < xxmax - 1 and y - yr >= 0  then f(x + xr, y - yr) = 300
      if x - xr >= 0 and y + yr <= yymax then f(x - xr, y + yr) = 300
      if x - xr >= 0 and y - yr >= 0  then f(x - xr, y - yr) = 300 
    next
  next
  circle x * xstep, y * ystep - ystep, br * xstep, xstep / ystep, p(300) filled
end


[B+]

A much improved version in QB64:

Code: [Select]

_TITLE "Great balls of fire by bplus, 2017-11-24"
'Great balls of fire.bas SmallBASIC 0.12.9 (B+=MGA) 2017-11-23

CONST xmax = 600
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60 'adjust as needed _MIDDLE needs a delay .5 or more for me

TYPE ball
    x AS SINGLE
    y AS SINGLE
    dx AS SINGLE
    dy AS SINGLE
    lastx AS SINGLE
    lasty AS SINGLE
END TYPE
DEFSNG A-Z
DIM SHARED xxmax, yymax, xstep, ystep, acc, br, brs
xxmax = 300: yymax = 300 'pixels too slow
xstep = xmax / xxmax: ystep = ymax / yymax

DIM SHARED p&(300) 'pallette thanks harixxx
FOR i = 1 TO 100
    fr = 240 * i / 100 + 15
    p&(i) = _RGB(fr, 0, 0)
    p&(i + 100) = _RGB(255, fr, 0)
    p&(i + 200) = _RGB(255, 255, fr)
NEXT

DIM SHARED f(xxmax, yymax) 'fire array tracks flames

nb = 7 '              number of balls
acc = .55 '           gravity
br = 15 '             ball radius
brs = br * br '       ball radius squared
DIM SHARED b(1 TO nb) AS ball
FOR i = 1 TO nb 'ball maker
    b(i).x = (xxmax - 2 * br) * RND + br '                               x location
    b(i).y = (yymax - 2 * br) * (i - 1) / nb + br '                      y location
    IF RND < .5 THEN b(i).dx = 1 + RND * 2 ELSE b(i).dx = -1 - RND * 2 ' dx change of x
    b(i).dy = 3 '                                                        dy change of y
NEXT

WHILE 1 'main show

    CLS 'some flames are sticking
    FOR i = 0 TO xxmax: f(i, yymax) = 0: f(i, yymax - 1) = 0: NEXT
    FOR i = 0 TO yymax: f(0, i) = 0: NEXT

    FOR y = 1 TO yymax - 2 'fire based literally on 4 pixels below it like cellular automata
        FOR x = 1 TO xxmax - 1
            v = (f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x, y + 2)) / 4 - 5
            IF v > 0 AND RND < .9 THEN f(x, y) = v ELSE f(x, y) = 0
            IF v > 294 THEN f(x, y) = 300
            'glow worms effect
            'f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x, y + 2)) / 4 - 15, 0)
            LINE (x * xstep, y * ystep)-STEP(xstep, ystep), p&(f(x, y)), BF
        NEXT
    NEXT

    FOR i = 1 TO nb 'move ball
        b(i).dy = b(i).dy + acc

        'new location unless out of bounds
        b(i).y = b(i).y + b(i).dy
        b(i).x = b(i).x + b(i).dx

        'keep ball in bounds
        IF b(i).y > yymax - br THEN b(i).dy = -.9 * b(i).dy: b(i).y = yymax - br: b(i).dx = b(i).dx * .9
        IF b(i).y < br THEN b(i).dy = -1 * b(i).dy: b(i).y = br + 1
        IF b(i).x < br THEN b(i).dx = -.9 * b(i).dx: b(i).x = br
        IF b(i).x > xxmax - br THEN b(i).dx = -.9 * b(i).dx: b(i).x = xxmax - br

        'handle new location
        fireBall b(i).x, b(i).y

        'handle dead balls
        IF ABS(b(i).lastx - b(i).x) < .01 AND ABS(b(i).lasty - b(i).y) < .01 THEN
            b(i).x = (xxmax - 2 * br) * RND + br
            b(i).y = 0
            IF RND < .5 THEN b(i).dx = 1 + RND * 2 ELSE b(i).dx = -1 - RND * 2
            b(i).dy = 3
        END IF
        b(i).lasty = b(i).y: b(i).lastx = b(i).x

    NEXT
    _DISPLAY

WEND

SUB fireBall (x, y)
    FOR xr = 0 TO br
        yrMax = (brs - xr * xr) ^ .5
        FOR yr = 0 TO yrMax
            IF x + xr < xxmax - 1 AND y + yr <= yymax - 1 THEN f(x + xr, y + yr) = 300
            IF x + xr < xxmax - 1 AND y - yr >= 0 THEN f(x + xr, y - yr) = 300
            IF x - xr >= 0 AND y + yr <= yymax THEN f(x - xr, y + yr) = 300
            IF x - xr >= 0 AND y - yr >= 0 THEN f(x - xr, y - yr) = 300
        NEXT
    NEXT
END SUB