and here is my update with a few old tricks
Code: (Select All)
Screen _NewImage(800, 600, 32): _ScreenMove 270, 60
_Title "bplus mod of Steves Code Inspired by bplus #2"
Const TWO_PI = 6.283185307
Const max = 100
Dim Shared Particles(1 To 300) As Particle
Dim Shared cN, pR, pG, pB ' color palette
Type Particle
x As Single
y As Single
dx As Single
dy As Single
life As Single
sz As Single
col As _Unsigned Long
End Type
'-----------------------------------------
' Main loop
'-----------------------------------------
Dim t As Single, beat As Integer
Dim scale As Single
Do
Line (0, 0)-(_Width, _Height), &H11000000, BF
t = t + .05
UpdateParticles 1, max / 2
scale = 8 + Sin(t) * 1.5
DrawHeartFill 400, 300, scale, _RGB32(255, 0, 0)
' Beat detection
If Sin(t) > .95 And beat = 0 Then
ResetPal
Burst 400, 300
beat = 1
End If
If Sin(t) < .5 Then beat = 0
UpdateParticles max / 2 + 1, max
_Display
_Limit 30
Loop
'-----------------------------------------
' Draw a parametric heart at scale S
'-----------------------------------------
Sub DrawHeart (cx As Single, cy As Single, s As Single, col As _Unsigned Long)
Dim t As Single, x As Single, y As Single
For t = 0 To TWO_PI Step .01
x = 16 * Sin(t) ^ 3
y = -(13 * Cos(t) - 5 * Cos(2 * t) - 2 * Cos(3 * t) - Cos(4 * t))
PSet (cx + x * s, cy + y * s), col
Next
End Sub
Sub DrawHeartFill (cx As Single, cy As Single, s As Single, col As _Unsigned Long)
Dim t As Single, x As Single, y As Single
For t = 0 To TWO_PI Step .01
x = 16 * Sin(t) ^ 3
y = -(13 * Cos(t) - 5 * Cos(2 * t) - 2 * Cos(3 * t) - Cos(4 * t))
If t <> 0 Then Line (cx + x * s, cy + y * s)-(cx + lx * s, cy + s * ly), col
lx = x: ly = y
Next
Paint (cx, cy), col, col
End Sub
'-----------------------------------------
' Spawn particle burst
'-----------------------------------------
Sub Burst (cx As Single, cy As Single)
Dim i As Integer
For i = 1 To 150
Particles(i).x = cx
Particles(i).y = cy
Dim a As Single
a = Rnd * TWO_PI
r = Rnd * 7 + 2
Particles(i).dx = r * Cos(a)
Particles(i).dy = r * Sin(a)
Particles(i).life = 1
Particles(i).col = Pal~&
Particles(i).sz = Rnd * 3 + .5
Next
End Sub
'-----------------------------------------
' Update and draw particles
'-----------------------------------------
Sub UpdateParticles (istart, iend)
Dim i As Integer
For i = istart To iend
If Particles(i).life > 0 Then
Particles(i).x = Particles(i).x + Particles(i).dx
Particles(i).y = Particles(i).y + Particles(i).dy
Particles(i).life = Particles(i).life - .01
Particles(i).sz = Abs(Particles(i).sz - .02)
Dim a As Integer
a = 255 * Particles(i).life
DrawHeartFill Particles(i).x, Particles(i).y, Rnd * Particles(i).sz, Particles(i).col
End If
Next
End Sub
Function Pal~& ()
cN = cN + .369 ''Dim Shared cN, pR, pG, pB, pA ' no pA
Pal~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
End Function
Sub ResetPal ()
''Dim Shared CN, PR, PG, PB, PA ' no PA
pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2: cN = 0
End Sub
if you dont like the palette just wait for next beat !
EDIT: 2026-02-16 Fixed dx, dy on the particle burst.
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
