RetroBASIC
Basicprogramming(.org) => Code and examples => Topic started by: B+ on November 24, 2017, 04:00:46 AM
-
'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
-
A much improved version in QB64:
_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