Posts: 3,453
Threads: 376
Joined: Apr 2022
Reputation:
346
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
Posts: 4,713
Threads: 224
Joined: Apr 2022
Reputation:
322
02-15-2026, 06:04 PM
(This post was last modified: 02-15-2026, 06:05 PM by bplus.)
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...
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,713
Threads: 224
Joined: Apr 2022
Reputation:
322
02-15-2026, 06:26 PM
(This post was last modified: 02-15-2026, 07:41 PM by bplus.
Edit Reason: take out glow layers not needed for heart fills
)
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 Sub
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,713
Threads: 224
Joined: Apr 2022
Reputation:
322
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 Function
Lost the sound to it but it had a lub-dub beat to it.
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 243
Threads: 15
Joined: Apr 2024
Reputation:
30
Posts: 4,713
Threads: 224
Joined: Apr 2022
Reputation:
322
02-15-2026, 09:02 PM
(This post was last modified: 02-15-2026, 09:13 PM by bplus.)
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
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 3,453
Threads: 376
Joined: Apr 2022
Reputation:
346
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
Posts: 3,453
Threads: 376
Joined: Apr 2022
Reputation:
346
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.
 
Posts: 799
Threads: 139
Joined: Apr 2022
Reputation:
33
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.
What can I say? I'm lazy.
yair, bone lazy! sittin' around eatin' yer Weet-Bix when there's coding waiting to be done!
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.)
Please visit my Website at: http://oldendayskids.blogspot.com/
Posts: 3,453
Threads: 376
Joined: Apr 2022
Reputation:
346
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
|
