12-30-2024, 06:56 AM
(12-30-2024, 06:48 AM)bplus Wrote: Working with Ken's Fireworks, I came up with some improvements to mine.Hi B+
So for 2025 let's light up the sky!
Code: (Select All)Option _Explicit
_Title "Fireworks for 2025" ' b+ 2024-12-30
Randomize Timer
Const xmax = 1280, ymax = 720
Const nR = 10
Type rocket
x As Single
y As Single
bang As Single
seed As Integer
age As Integer
fini As Integer
r As Integer
c As _Unsigned Long
End Type
Dim Shared r(1 To nR) As rocket, distant As Long, i As Long, lc As Long
distant = _SndOpen("distant.wav", "vol,sync")
For i = 1 To nR
new i
Next
Screen _NewImage(xmax, ymax, 32)
_FullScreen
Dim rocs As Integer, sky As Long
sky = DrawSky&(8)
Color , 0
Do
_PutImage , sky, 0
lc = lc + 1
If lc Mod 30 = 1 And rocs < nR Then rocs = rocs + 1: lc = 1
For i = 1 To rocs
drawRocket i
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
System
Sub new (i)
Dim As Integer b, g
Randomize Timer
r(i).x = Rnd * (xmax - 30) + 10
r(i).y = ymax - 60
r(i).bang = .5 * ymax * Rnd + 30
r(i).seed = Int(32000 * Rnd) + 1
r(i).age = 0
r(i).fini = Rnd * 75 + 25
r(i).r = Int(Rnd * 4) + 1
b = Int(Rnd * 2): g = Int(Rnd * 2)
r(i).c = _RGB32(Rnd * 220 + 35, (g = 1) * -(Rnd * 220 + 35), (b = 1) * -(Rnd * 220 + 35), 50)
End Sub
Sub drawRocket (i)
Dim As Integer k, e, start, tt
Dim ne, a, cx, cy, dx, dy, R
If r(i).y >= r(i).bang Then
Color r(i).c
For k = 1 To 12
Locate r(i).y \ 16, r(i).x \ 8: Print Chr$(24);
Next
r(i).y = r(i).y - 16
Else
If r(i).age = 0 Then ' flash and bang!
Line (0, 0)-(xmax, ymax), &H44FFFFFF, BF: _Display
_SndVol distant, .9
_SndPlay distant
End If
r(i).age = r(i).age + 1
If r(i).age > r(i).fini Then
new i
Else
Randomize Using r(i).seed
ne = Rnd * 500 + 100
Dim embers(ne - 1, 1)
For e = 0 To ne - 1
R = Rnd * 12
a = Rnd * _Pi(2)
embers(e, 0) = R * Cos(a)
embers(e, 1) = R * Sin(a)
Next
If r(i).age > 10 Then start = r(i).age - 10 Else start = 1 ' don't let tails get longer than lTail const
For e = 0 To ne - 1
cx = r(i).x: cy = r(i).y: dx = embers(e, 0): dy = embers(e, 1)
For tt = 1 To r(i).age
cx = cx + dx
cy = cy + dy
If tt > start Then
If tt <> r(i).age Then
FC3 cx, cy, r(i).r, r(i).c
Else
FC3 cx, cy, r(i).r, &H99FFFFFF
End If
End If
dx = dx * .97 'air resitance
dy = .97 * dy + .1 'gravity
Next
Next
End If
End If
End Sub
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&) ' no suffix punctuation use the Global Default Type as Long or Single or Double
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
Function DrawSky& (light As Long) ' light = 0 to 100 as percent
' needs MidInk~&() Function
Dim As _Unsigned Long saveColor, c
Dim As Long i, rtn, saveDest
Dim r, rn, xx, yy, lite
lite = 2 * light
saveDest = _Dest
saveColor = _DefaultColor(saveDest)
rtn = _NewImage(_Width, _Height, 32)
_Dest rtn&
For i = 0 To _Height - 1
c = midInk(.75 * lite + 10, .75 * lite + 5, 35 + .75 * lite, 25 + lite, lite, 55 + lite, i / (_Height - 1))
Line (0, i)-(_Width, i), c
Next
'stars only in low lite
If lite <= 100 Then
For i = 1 To _Width * _Height / 1500
rn = Rnd: xx = Rnd * _Width: yy = Rnd * _Height
If rn < .01 Then
For r = 0 To 2 Step .5
Circle (xx, yy), r, _RGB32(185, 185, 185)
Next
ElseIf rn < .2 Then
Circle (xx, yy), 1, _RGB32(185, 185, 185)
PSet (xx, yy), _RGB32(185, 185, 185)
Else
PSet (xx, yy), _RGB32(185, 185, 185)
End If
Next
End If
_Dest saveDest
Color saveColor
DrawSky& = rtn
End Function
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
This is wery good.