02-15-2026, 10:12 PM
Since everyone is enjoying this little heartbeat, here's a version 2.0!
VERSION 2.0 HEART THROB!!
VERSION 2.0 HEART THROB!!
Code: (Select All)
Screen _NewImage(800, 600, 32)
_Title "Rainbow Heart — QB64PE"
Const TWO_PI = 6.283185307
Type Particle
x As Single
y As Single
dx As Single
dy As Single
life As Single
col As _Unsigned Long
End Type
Dim Shared Particles(1 To 600) As Particle
'-----------------------------------------
' Main loop
'-----------------------------------------
Dim t As Single, beat As Integer
Do
Cls , _RGB32(10, 10, 20)
t = t + .05
' Heartbeat scale
Dim scale As Single
scale = 10 + Sin(t) * 1.5
' Glow
DrawFilledHeart 400, 300, scale * 1.20
DrawFilledHeart 400, 300, scale
' Beat detection
If Sin(t) > .92 And beat = 0 Then
Burst 400, 300
For i = 0 To 200
s = Sin(i * .25) * Exp(-i / 80) * .8
_SndRaw s
Next
trigger = 0
'HeartbeatSound
beat = 1
End If
If Sin(t) < .5 Then
beat = 0
If Sin(t) < .08 And trigger = 0 Then
trigger = 1
For i = 0 To 200
s = Sin(i * .35) * Exp(-i / 80) * .5
_SndRaw s
Next
End If
End If
UpdateParticles
_Display
_Limit 600
Loop
'-----------------------------------------
' Parametric heart point
'-----------------------------------------
Sub HeartPoint (t As Single, s As Single, cx As Single, cy As Single, x As Single, y As Single)
x = 16 * Sin(t) ^ 3
y = -(13 * Cos(t) - 5 * Cos(2 * t) - 2 * Cos(3 * t) - Cos(4 * t))
x = cx + x * s
y = cy + y * s
End Sub
'-----------------------------------------
' Draw a filled rainbow heart
'-----------------------------------------
Sub DrawFilledHeart (cx As Single, cy As Single, baseScale As Single)
Dim i As Integer, layers As Integer
layers = 80
For i = layers To 1 Step -1
Dim s As Single
s = baseScale * (i / layers)
' Rainbow color
Dim hue As Single
hue = i / layers
Dim r As Integer, g As Integer, b As Integer
r = 255 * Sin(hue * 3.14)
g = 255 * Sin(hue * 3.14 + 2.09)
b = 255 * Sin(hue * 3.14 + 4.18)
Dim col As _Unsigned Long
col = _RGB32(Abs(r), Abs(g), Abs(b))
Dim t As Single, x As Single, y As Single
For t = 0 To TWO_PI Step .01
HeartPoint t, s, cx, cy, x, y
HeartPoint t, s, cx, cy, x, y
Line (x, y)-Step(2, 2), col, BF
Next
Next
End Sub
'-----------------------------------------
' Spawn rainbow particle burst
'-----------------------------------------
Sub Burst (cx As Single, cy As Single)
Dim i As Integer
For i = 1 To 600
Particles(i).x = cx
Particles(i).y = cy
Dim a As Single
a = Rnd * TWO_PI
Particles(i).dx = Cos(a) * (Rnd * 5)
Particles(i).dy = Sin(a) * (Rnd * 5)
Particles(i).life = 1
' Rainbow color
Dim hue As Single
hue = Rnd
Dim r As Integer, g As Integer, b As Integer
r = 255 * Sin(hue * 3.14)
g = 255 * Sin(hue * 3.14 + 2.09)
b = 255 * Sin(hue * 3.14 + 4.18)
Particles(i).col = _RGB32(Abs(r), Abs(g), Abs(b))
Next
End Sub
'-----------------------------------------
' Update and draw particles
'-----------------------------------------
Sub UpdateParticles
Dim i As Integer
For i = 1 To 600
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 - .015
Dim a As Integer
a = 255 * Particles(i).life
PSet (Particles(i).x, Particles(i).y), _RGBA32(_Red32(Particles(i).col), _Green32(Particles(i).col), _Blue32(Particles(i).col), a)
End If
Next
End Sub