Valentine's Beating Heart

[bplus]

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.