earliest
State of the Art
Ascii move mousewheel or Dave for Pete
Code: (Select All)
_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
Const xmax = 1000
Const ymax = 720
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 180, 0
Type placeType
x As Single
y As Single
End Type
Type flareType
x As Single
y As Single
dx As Single
dy As Single
c As Long
End Type
Type debrisType
x As Single
y As Single
c As Long
End Type
Common Shared debris() As debrisType
flareMax = 1000: debrisMax = 5000: debrisStack = 0
Dim flare(flareMax) As flareType
Dim debris(debrisMax) As debrisType
Dim burst As placeType
While 1
rndCycle = Rnd * 30
loopCount = 0
burst.x = .75 * xmax * Rnd + .125 * xmax
burst.y = .5 * ymax * Rnd + .125 * ymax
While loopCount < 7
Cls
'color 14 : locate 0,0: ? debris_stack; " Debris" 'debug line
For i = 1 To 200 'new burst using random old flames to sim burnout
nxt = Int(Rnd * flareMax)
angle = Rnd * _Pi(2)
flare(nxt).x = burst.x + Rnd * 5 * Cos(angle)
flare(nxt).y = burst.y + Rnd * 5 * Sin(angle)
angle = Rnd * _Pi(2)
flare(nxt).dx = Rnd * 15 * Cos(angle)
flare(nxt).dy = Rnd * 15 * Sin(angle)
rc = Int(Rnd * 3)
If rc = 0 Then
flare(nxt).c = _RGB32(255, 100, 0)
ElseIf rc = 1 Then
flare(nxt).c = _RGB32(0, 0, 255)
Else
flare(nxt).c = _RGB32(255, 255, 255)
End If
Next
For i = 0 To flareMax
If flare(i).dy <> 0 Then 'while still moving vertically
Line (flare(i).x, flare(i).y)-Step(flare(i).dx, flare(i).dy), _RGB32(98, 98, 98)
flare(i).x = flare(i).x + flare(i).dx
flare(i).y = flare(i).y + flare(i).dy
Color flare(i).c
Circle (flare(i).x, flare(i).y), 1
flare(i).dy = flare(i).dy + .4 'add gravity
flare(i).dx = flare(i).dx * .95 'add some air resistance
If flare(i).x < 0 Or flare(i).x > xmax Then flare(i).dy = 0 'outside of screen
'add some spark bouncing here
If flare(i).y > ymax Then
If Abs(flare(i).dy) > .5 Then
flare(i).y = ymax: flare(i).dy = flare(i).dy * -.25
Else
flare(i).dy = 0
End If
End If
End If
Next
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 > ymax Then NewDebris (i)
Next
_Display
_Limit 20
loopCount = loopCount + 1
Wend
If debrisStack < debrisMax Then
For i = 1 To 20
NewDebris i + debrisStack
Next
debrisStack = debrisStack + 20
End If
Wend
Sub NewDebris (i)
debris(i).x = Rnd * xmax
debris(i).y = Rnd * ymax
c = Rnd * 255
debris(i).c = _RGB32(c, c, c)
End SubState of the Art
Code: (Select All)
_Title "Happy Trails 2020" 'from 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 2020"
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 200 '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 SubAscii move mousewheel or Dave for Pete
Code: (Select All)
DefInt A-Z
_Title "ASCII Fireworks !!! Move Mousewheel !!! to Expand or Contract #2" '2020-01-01
' 2020-01-02 update with graivity effect by tsh73 from JB forum
' 2020-08-11 modified for xpanding and contracting screen size
' 2020-08-11 Steve catches memory leak, fixed!
' 2020-08-12 manstersoft gives me idea for Font 8, added more works and switched color to more! RGB32
Const nR = 9, t = " Happy New Year QB64 Forum, ASCII Fireworks Brought To You By Bplus Inspired by Pete, TempodiBasic and Code Hunter Recent Efforts, Gravity Effect by tsh73 at JB Forum, Thanks Steve for saving memory and manstersoft for Font 8 idea, Go In Peace 2020!....."
Type rocket
x As Single
y As Single
bang As Integer
age As Integer
c As _Unsigned Long
End Type
Dim Shared r(1 To nR) As rocket
For i = 1 To nR
new i
Next
Dim Shared fire&
fire& = _NewImage(640, 400, 32)
Dim tmp&(0 To 10)
lastt = 20
sc& = _NewImage(640, 400, 32)
_Font 8
Do
_Dest fire&
_Font 16
Cls
Color &HFFFF88AA
lc = lc + 1
If lc Mod 3 = 0 Then p = (p + 1) Mod Len(t)
Locate 2, 20: Print Mid$(t, p + 1, 40);
_Font 8
rocs = rocs + 1
If rocs > nR Then rocs = nR
For i = 1 To rocs
drawRocket i
Next
_Dest 0
While _MouseInput
scroll = scroll + _MouseWheel
Wend
If scroll < 800 And scroll > -400 Then
tp = (tp + 1) Mod 10
tmp&(tp) = _NewImage(640 + scroll, 400 + scroll, 32)
Screen tmp&(tp)
_PutImage , fire&, 0
Else
lastt = 20
End If
'debug
'COLOR qb(15)
'LOCATE 1, 1: PRINT lastt, tp, scroll
If lastt <> 20 Then _FreeImage tmp&(lastt)
lastt = tp
_Display
_Limit 20
Loop Until _KeyDown(27)
Sub new (i)
r(i).x = Rnd * 60 + 10
r(i).y = 50
r(i).bang = Rnd * 30
r(i).age = 0
r(i).c = _RGB32(200 * Rnd + 55, 200 * Rnd + 55, 200 * Rnd + 55)
End Sub
Sub drawRocket (i)
If r(i).y > r(i).bang Then
Color r(i).c
Locate r(i).y, r(i).x: Print Chr$(24);
r(i).y = r(i).y - 1
Else
r(i).age = r(i).age + 1
If r(i).age > 50 Then
new i
Else
Color r(i).c
If r(i).age > 4 Then start = r(i).age - 4 Else start = 1
For a = start To r(i).age
For j = 1 To 12
xx = r(i).x + 1 * a * Cos(j * _Pi / 6)
yy = r(i).y + .5 * a * Sin(j * _Pi / 6)
yy = yy + (r(i).y - a) ^ 2 / 15 '<<<< tsh73 gravity
If xx > 0 And xx < 81 And yy > 0 And yy < 51 Then
Locate Int(yy), Int(xx)
Print "*";
End If
Next
Next
End If
End If
End Sub
b = b + ...