02-15-2026, 11:10 PM
Last go at heart making. NOW I is going to supper for sure! LOL!
Code: (Select All)
Screen _NewImage(800, 600, 32)
_Title "Rainbow Heart QB64PE"
Const TWO_PI = 6.283185307
Type Particle
As Single x, y, dx, dy, life, size
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
Dim phase As Single
phase = Sin(t)
' Heartbeat scale
Dim scale As Single
scale = 10 + phase * 1.5
' Continuous stereo heartbeat
HeartbeatContinuous phase
' Particle burst only on S1 peak
If phase > .92 And beat = 0 Then
Burst 400, 300
beat = 1
End If
If phase < .5 Then beat = 0
UpdateParticles
' Glow + rainbow fill
DrawFilledHeart 400, 300, scale * 1.20
DrawFilledHeart 400, 300, scale
_Display
_Limit 60
Loop
Sub HeartbeatContinuous (phase As Single)
' phase = Sin(t)
' phase goes from -1 to +1 each heartbeat cycle
Dim L As Single, R As Single
Dim s As Single
' Map phase
Dim p As Single
p = (phase + 1) / 2
' ---------------------------
' Cardiology-style envelope
' ---------------------------
' S1 (lub) happens early in the cycle
Dim s1 As Single
s1 = Exp(-((p - .15) ^ 2) * 90)
' S2 (dub) happens later
Dim s2 As Single
s2 = Exp(-((p - .55) ^ 2) * 120)
' ---------------------------
' Waveform synthesis
' ---------------------------
Dim w1 As Single, w2 As Single
w1 = Sin(p * 200) * .7 + Sin(p * 100) * .3 ' deep thud
w2 = Sin(p * 330) * .5 + Sin(p * 160) * .2 ' higher dub
' Combine with envelopes
s = w1 * s1 + w2 * s2
' ---------------------------
' Stereo imaging
' ---------------------------
L = s * (1 - p * .3) ' S1 stronger on left
R = s * (p * .3 + .7) ' S2 stronger on right
_SndRaw L, R
End Sub
Sub DrawMiniHeart (cx As Single, cy As Single, s As Single, col As _Unsigned Long, a As Integer)
Dim t As Single, x As Single, y As Single
For t = 0 To 6.283 Step .15
x = 16 * Sin(t) ^ 3
y = -(13 * Cos(t) - 5 * Cos(2 * t) - 2 * Cos(3 * t) - Cos(4 * t))
x = cx + x
y = cy + y
Line (x, y)-Step(s, s), _RGBA32(_Red32(col), _Green32(col), _Blue32(col), a), BF
Next
End Sub
'-----------------------------------------
' 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
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
Randomize Timer
For i = 1 To 600
Particles(i).x = cx
Particles(i).y = cy
Dim a As Single
a = Rnd * 6.283
Particles(i).dx = Cos(a) * (Rnd * 8)
Particles(i).dy = Sin(a) * (Rnd * 8)
Particles(i).life = 2
' Random heart size
Particles(i).size = 5 + Rnd * 5
' 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 60
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
DrawMiniHeart Particles(i).x, Particles(i).y, Particles(i).size, Particles(i).col, a
End If
Next
End Sub