Valentine's Beating Heart

[bplus]

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