From a little challenge at the QB64.net forum:
_TITLE "Happy Trails 2018"
' 2017-12-29 another redesign of fireworks
' 2017-12-28 redesign fireworks
' now with lake refelction 2017-12-27 forget the bouncing sparks
' combine Welcome Plasma Font with landscape
'_title "Fireworks 3 translation to QB64 2017-12-26 bplus"
'fireworks 3.bas SmallBASIC 0.12.2 [B+=MGA] 2015-05-09
'fireworks 2.bas 2016-05-05 now with Gravity, Newtonian bounce, smoke debris
'fireworks 3.bas try with map variables make bursts around a central point
RANDOMIZE TIMER
CONST xmax = 1200
CONST ymax = 720
CONST waterline = 600 ' 600 = ratio 5 to 1 sky to water
' raise and lower waterline as desired highest about 400?
CONST lTail = 15
CONST bluey = 5 * 256 ^ 2 + 256 * 5 + 5
CONST debrisMax = 28000
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 120, 20
TYPE fireWorkType
x AS INTEGER
y AS INTEGER
seed AS INTEGER
age AS INTEGER
life AS INTEGER
END TYPE
TYPE debrisType
x AS SINGLE
y AS SINGLE
c AS LONG
END TYPE
COMMON SHARED fw() AS fireWorkType
COMMON SHARED debris() AS debrisType
COMMON SHARED cN, pR!, pG!, pB!
SCREEN _NEWIMAGE(xmax, ymax, 32)
'prepare message font
mess$ = " Happy New Year 2018"
PRINT mess$
w = 8 * LEN(mess$): h = 16
DIM p(w, h)
black&& = POINT(0, 10)
FOR y = 0 TO h
FOR x = 0 TO w
IF POINT(x, y) <> black&& THEN
p(x, y) = 1
END IF
NEXT
NEXT
xo = 0: yo = 15: m = 7.2
resetPlasma
'prepare landscape
CLS
land& = _NEWIMAGE(xmax, ymax, 32)
_DEST land&
drawLandscape
_DEST 0
'prepare fire works
nFW = 3
DIM fw(1 TO 10) AS fireWorkType
FOR i = 1 TO nFW
initFireWork (i)
NEXT
'debris feild
DIM debris(debrisMax) AS debrisType
'OK start the show
WHILE 1
'cls screen with land image
_PUTIMAGE , land&, 0
'draw fireworks
FOR f = 1 TO nFW
IF fw(f).age <= fw(f).life THEN drawfw (f) ELSE initFireWork f
NEXT
'debris
FOR i = 0 TO debrisStack
PSET (debris(i).x, debris(i).y), debris(i).c
debris(i).x = debris(i).x + RND * 3 - 1.5
debris(i).y = debris(i).y + RND * 3.5 - 1.5
IF debris(i).x < 0 OR debris(i).y < 0 OR debris(i).x > xmax OR debris(i).y > waterline + RND * 20 THEN NewDebris (i)
NEXT
'text message in plasma
FOR y = 0 TO h - 1
FOR x = 0 TO w - 1
IF p(x, y) THEN
changePlasma
ELSE
COLOR 0
END IF
LINE (xo + x * m, yo + y * m)-(xo + x * m + m, yo + y * m + m), , BF
NEXT
NEXT
lc = lc + 1
IF lc MOD 200 = 0 THEN resetPlasma
'reflect sky
skyWaterRatio = waterline / (ymax - waterline) - .05
FOR y = waterline TO ymax
FOR x = 0 TO xmax
c&& = POINT(x, waterline - ((y - waterline - 1) * skyWaterRatio) + RND * 5)
PSET (x, y + 1), c&& + bluey
NEXT
NEXT
_DISPLAY
_LIMIT 50 'no limit needed on my system!
'accumulate debris
IF lc MOD 2000 THEN
IF debrisStack < debrisMax THEN
FOR i = 1 TO 2
NewDebris i + debrisStack
NEXT
debrisStack = debrisStack + 2
END IF
END IF
WEND
SUB NewDebris (i)
debris(i).x = RND * xmax
debris(i).y = RND * ymax
c = RND * 155
debris(i).c = _RGB32(c, c, c)
END SUB
SUB changePlasma ()
cN = cN + .01
COLOR _RGB(127 + 127 * SIN(pR! * .3 * cN), 127 + 127 * SIN(pG! * .3 * cN), 127 + 127 * SIN(pB! * .3 * cN))
END SUB
SUB resetPlasma ()
pR! = RND ^ 2: pG! = RND ^ 2: pB! = RND ^ 2
END SUB
SUB drawLandscape
'the sky
FOR i = 0 TO ymax
midInk 0, 0, 0, 78, 28, 68, i / ymax
LINE (0, i)-(xmax, i)
NEXT
'the land
startH = waterline - 80
rr = 10: gg = 20: bb = 15
FOR mountain = 1 TO 6
Xright = 0
y = startH
WHILE Xright < xmax
' upDown = local up / down over range, change along Y
' range = how far up / down, along X
upDown = (RND * .8 - .35) * (1 / (1 * mountain))
range = Xright + rand&&(5, 35) * 2.5 / mountain
lastx = Xright - 1
FOR X = Xright TO range
y = y + upDown
COLOR _RGB32(rr, gg, bb)
LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
lastx = X
NEXT
Xright = range
WEND
rr = rand&&(rr + 5, rr): gg = rand&&(gg + 5, gg): bb = rand&&(bb + 4, bb)
IF rr < 0 THEN rr = 0
IF gg < 0 THEN gg = 0
IF bb < 0 THEN bb = 0
startH = startH + rand&&(1, 10)
NEXT
'LINE (0, waterline)-(xmax, ymax), _RGB32(0, 0, 0), BF
END SUB
SUB midInk (r1, g1, b1, r2, g2, b2, fr)
COLOR _RGB(r1 + (r2 - r1) * fr, g1 + (g2 - g1) * fr, b1 + (b2 - b1) * fr)
END SUB
FUNCTION rand&& (lo&&, hi&&)
rand&& = INT(RND * (hi&& - lo&& + 1)) + lo&&
END FUNCTION
SUB drawfw (i)
'here's how to "save" a bunch of random numbers without data and arrays but tons of redundant calculations
RANDOMIZE USING fw(i).seed 'this repeats all random numbers generated by seed in same sequence
'recreate our firework from scratch!
red = rand&&(200, 255)
green = rand&&(200, 255)
blue = rand&&(200, 255)
x = rand&&(1, 4)
IF x = 1 THEN
red = 0
ELSEIF x = 2 THEN
green = 0
ELSEIF x = 3 THEN
blue = 0
ELSE
x = rand&&(1, 4)
IF x = 1 THEN
red = 0: green = 0
ELSEIF x = 2 THEN
green = 0: blue = 0
ELSEIF x = 3 THEN
blue = 0: red = 0
END IF
END IF
ne = rand&&(80, 300)
DIM embers(ne, 1)
FOR e = 0 TO ne
r = RND * 3
embers(e, 0) = r * COS(e * _PI(2) / 101)
embers(e, 1) = r * SIN(e * _PI(2) / 101)
NEXT
start = fw(i).age - lTail ' don't let tails get longer than lTail const
IF start < 1 THEN start = 1
FOR e = 0 TO ne
cx = fw(i).x: cy = fw(i).y: dx = embers(e, 0): dy = embers(e, 1)
FOR t = 1 TO fw(i).age
cx = cx + dx
cy = cy + dy
IF t >= start THEN
'too much like a flower?
midInk 60, 60, 60, red, green, blue, (t - start) / lTail
'midInk 60, 60, 60, 128, 160, 150, (t - start) / lTail
fcirc cx, cy, (t - start) / lTail
END IF
dx = dx * .99 'air resitance
dy = dy + .01 'gravity
NEXT
COLOR _RGB32(255, 255, 255)
'COLOR _RGB32(red, green, blue)
cx = cx + dx: cy = cy + dy
fcirc cx, cy, (t - start) / lTail
NEXT
fw(i).age = fw(i).age + 1
END SUB
SUB initFireWork (i)
fw(i).x = rand&&(.1 * xmax, .9 * xmax)
fw(i).y = rand&&(.1 * ymax, .5 * ymax)
fw(i).seed = rand&&(0, 32000)
fw(i).age = 0
fw(i).life = rand&&(20, 120)
END SUB
'Steve McNeil's copied from his forum note: Radius is too common a name
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
DIM subRadius AS LONG, RadiusError AS LONG
DIM X AS LONG, Y AS LONG
subRadius = ABS(R)
RadiusError = -subRadius
X = subRadius
Y = 0
IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
LINE (CX - X, CY)-(CX + X, CY), , BF
WHILE X > Y
RadiusError = RadiusError + Y * 2 + 1
IF RadiusError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
END IF
X = X - 1
RadiusError = RadiusError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
WEND
END SUB
Maybe last post from the "dinosaur", got a new laptop where the limit in main loop is actually needed!
