QB64 Great balls of fire
#1
Code:
_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


Attached Files Thumbnail(s)

B += x
Reply