+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Holiday Code (https://qb64phoenix.com/forum/forumdisplay.php?fid=48)
+---- Thread: Valentine's Beating Heart (/showthread.php?tid=4472)
Valentine's Beating Heart - SMcNeill - 02-15-2026
Inspired by @bplus and his Valentine Heart, I had to make one as well.
My heart beats for you guys!
Code: (Select All)
Screen _NewImage(800, 600, 32)
_Title "Valentine Heart — QB64PE"
Const TWO_PI = 6.283185307
Dim Shared Particles(1 To 300) As Particle
Type Particle
x As Single
y As Single
dx As Single
dy As Single
life As Single
col As _Unsigned Long
End Type
'-----------------------------------------
' Main loop
'-----------------------------------------
Dim t As Single, beat As Integer
Do
Cls , _RGB32(10, 10, 20)
t = t + .05
Dim scale As Single
scale = 8 + Sin(t) * 1.5
' Glow layers
DrawHeart 400, 300, scale * 1.25, _RGBA32(255, 0, 80, 40)
DrawHeart 400, 300, scale * 1.15, _RGBA32(255, 0, 120, 60)
DrawHeart 400, 300, scale, _RGB32(255, 0, 180)
' Beat detection
If Sin(t) > .95 And beat = 0 Then
Burst 400, 300
beat = 1
End If
If Sin(t) < .5 Then beat = 0
UpdateParticles
_Display
_Limit 60
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
'-----------------------------------------
' Spawn particle burst
'-----------------------------------------
Sub Burst (cx As Single, cy As Single)
Dim i As Integer
For i = 1 To 300
Particles(i).x = cx
Particles(i).y = cy
Dim a As Single
a = Rnd * TWO_PI
Particles(i).dx = Cos(a) * (Rnd * 4)
Particles(i).dy = Sin(a) * (Rnd * 4)
Particles(i).life = 1
Particles(i).col = _RGB32(255, 50 + Rnd * 150, 200)
Next
End Sub
'-----------------------------------------
' Update and draw particles
'-----------------------------------------
Sub UpdateParticles
Dim i As Integer
For i = 1 To 300
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
Dim a As Integer
a = 255 * Particles(i).life
Line (Particles(i).x, Particles(i).y)-Step(2, 2), _RGBA32(255, 100, 200, a), BF
End If
Next
End Sub
RE: Valentine's Beating Heart - bplus - 02-15-2026
Cool! Oh man, I forgot we changed Christmas Code to Holiday Code.
But this reminds me of that thing Unseen posted that was written by AI awhile ago with nice added feature that I meant to play with...
RE: Valentine's Beating Heart - bplus - 02-15-2026
bplus mod of Steves Inspired by bplus
Code: (Select All)
Screen _NewImage(800, 600, 32)
_Title "Valentine Heart — QB64PE"
Const TWO_PI = 6.283185307
Dim Shared Particles(1 To 300) As Particle
Type Particle
x As Single
y As Single
dx As Single
dy As Single
life As Single
col As _Unsigned Long
End Type
'-----------------------------------------
' Main loop
'-----------------------------------------
Dim t As Single, beat As Integer
Do
Cls , _RGB32(10, 10, 20)
t = t + .05
Dim scale As Single
scale = 8 + Sin(t) * 1.5
' Glow layers
'DrawHeart 400, 300, scale * 1.25, _RGBA32(255, 0, 80, 40)
'DrawHeart 400, 300, scale * 1.15, _RGBA32(255, 0, 120, 60)
DrawHeartFill 400, 300, scale, _RGB32(255, 0, 0)
' Beat detection
If Sin(t) > .95 And beat = 0 Then
Burst 400, 300
beat = 1
End If
If Sin(t) < .5 Then beat = 0
UpdateParticles
_Display
_Limit 60
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), &HFFFF0000, col
End Sub
'-----------------------------------------
' Spawn particle burst
'-----------------------------------------
Sub Burst (cx As Single, cy As Single)
Dim i As Integer
For i = 1 To 30
Particles(i).x = cx
Particles(i).y = cy
Dim a As Single
a = Rnd * TWO_PI
Particles(i).dx = Rnd * 10 * Cos(a)
Particles(i).dy = Rnd * 10 * Sin(a)
Particles(i).life = 1
Particles(i).col = _RGB32(255, 50 + Rnd * 150, 200)
Next
End Sub
'-----------------------------------------
' Update and draw particles
'-----------------------------------------
Sub UpdateParticles
Dim i As Integer
For i = 1 To 30
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
Dim a As Integer
a = 255 * Particles(i).life
DrawHeart Particles(i).x, Particles(i).y, Rnd * 3, _RGBA32(255, Rnd * 100, Rnd * 200, a)
End If
Next
End SubRE: Valentine's Beating Heart - bplus - 02-15-2026
I don't know if Steve knows this but I did beating heart years ago:
Code: (Select All)
_Title "Beating heart w sound" 'B+ 2019-02-16
'2019-02-16 Beating Cardiod
'2019-02-28 random magnify and beat, redder heart
'2020-11-21 Beating heart w sound
' Thanks to SoundBible for .wav file
' http://soundbible.com/2162-Human-Heartbeat.html
' About: Human heart beating loud and strong. could also be used to show someone is worried, afraid, or injured.
' Title: Human Heartbeat
' Uploaded: 4.24.17
' License: Attribution 3.0
' Recorded by Daniel Simion
' File Size: 2.52 MB
' Downloads: 174359
Const xmax = 800, ymax = 600
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
hb& = _SndOpen("heartbeat.wav") ' doesn't want to work ????
_SndLoop hb&
'center of screen
CX = xmax / 2
CY = ymax / 2 - 50
While _KeyDown(27) = 0
Cls
loopCount = loopCount + 1
Select Case loopCount Mod 8
Case 0: magnify = 10
Case 1: magnify = 12
Case 2: magnify = 10
Case 3: magnify = 14
Case 4: magnify = 10
Case 5: magnify = 10
Case 6: magnify = 10
Case 7: magnify = 10
End Select
For a = -_Pi To _Pi Step _Pi(1 / 360)
x = CX + magnify * xCard(a)
y = CY - magnify * yCard(a)
If a <> -_Pi Then
Line (x, y)-(lastx, lasty), _RGB(140, 0, 0)
End If
lastx = x: lasty = y
Next
Paint (CX, CY), _RGB(180, 0, 0), _RGB(140, 0, 0)
_Display
_Limit 11.1
Wend
'Reference and thanks to:
' http://mathworld.wolfram.com/HeartCurve.html
' find the 6th heart curve equations #7, 8
Function xCard (t)
xCard = 16 * Sin(t) ^ 3
End Function
Function yCard (t)
yCard = 13 * Cos(t) - 5 * Cos(2 * t) - 2 * Cos(3 * t) - Cos(4 * t)
End FunctionLost the sound to it but it had a lub-dub beat to it.
RE: Valentine's Beating Heart - ahenry3068 - 02-15-2026
Had to do my little version
Beating Heart Source and Media
RE: Valentine's Beating Heart - bplus - 02-15-2026
Little? 76 M yikes!
That Black "Eye" at top left makes the heart look like a weird colored frog.
+1 That's pretty realistic for a Myan b+LOL
RE: Valentine's Beating Heart - SMcNeill - 02-15-2026
Since everyone is enjoying this little heartbeat, here's a version 2.0!
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
RE: Valentine's Beating Heart - SMcNeill - 02-15-2026
And here's a rather awesome glitch version, which might be better than the original version...
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, .01
DrawFilledHeart 400, 300, scale, .01
' 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, stepper 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 stepper
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 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
DrawFilledHeart Particles(i).x, Particles(i).y, Rnd * 3 ,1
End If
Next
End Sub
I was going to steal from @bplus and use his idea for hearts as the particles, but....
I gots this instead!!
Now I has to study my own code and math and sort out what the heck I did to do this, cause this is *NEAT*! LOL!!
But it'll have to wait until after I go out and eat supper. I just thought I'd share and maybe someone else can sort out what I did here that makes this type effect. Then when I get back with a full tummy, the solution will be sitting and waiting for me, rather than me having to find it on my own.
What can I say? I'm lazy.
RE: Valentine's Beating Heart - PhilOfPerth - 02-15-2026
Quote: But it'll have to wait until after I go out and eat supper. I just thought I'd share and maybe someone else can sort out what I did here that makes this type effect. Then when I get back with a full tummy, the solution will be sitting and waiting for me, rather than me having to find it on my own.yair, bone lazy! sittin' around eatin' yer Weet-Bix when there's coding waiting to be done!
What can I say? I'm lazy.
RE: Valentine's Beating Heart - SMcNeill - 02-15-2026
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