Happy Valentine's Day!

[bplus]

Cardiac Conic Shape 1B FatLine

Code: (Select All)

_Title "Cardiac Conic Shape 1B Fat Line" 'b+ 2026-02-15

' inspired by CharlieJV BAM version of Richard Russle

' also inspired by today being Valentine's Day



Const xmax = 800, ymax = 600

Screen _NewImage(xmax, ymax, 32)

_ScreenMove 150, 50

Dim Shared blades: blades = 48

Dim Shared hX(1 To blades), hY(1 To blades)

Dim Shared OCX(1 To blades), OCY(1 To blades)

Dim pal~&(1 To blades)

For i = 1 To blades

    pal~&(i) = _RGB32(255, (blades - i) / blades * 64 + 64, i / blades * 255)

Next

i = 0

' BIG outer circle map points from bottom of screen like heart is mapped

CX = xmax / 2

CY = ymax / 2

BigCircRadius = ymax / 2 - 10

'map the outer circle OCX, OCY points  once and for all time!

For a = _Pi(.5) To _Pi(2.5) - .001 Step _Pi(2 / blades)

    i = i + 1

    OCX(i) = CX + BigCircRadius * Cos(a)

    OCY(i) = CY + BigCircRadius * Sin(a)

Next



' heart

hCircRadius = .15 * BigCircRadius

a = -_Pi

While _KeyDown(27) = 0

    Cls

    ' recalc heart points from new position

    hOrigX = CX + hCircRadius * Cos(a)

    hOrigY = CY + hCircRadius * Sin(a)

    MapHeart hOrigX, hOrigY, 12

    ' draw line from center to heart point

    Color pal~&(1)

    For i = 1 To blades



        FatLine CX, CY, hX(i), hY(i), 5

        ' and line from heart point to outer circle

        FatLine hX(i), hY(i), OCX(i), OCY(i), 5

        If (i Mod 2 = 0) Then

            Color pal~&(i - 1)

            FatLine hX(i), hY(i), hX(i - 1), hY(i - 1), 5

            FatLine OCX(i), OCY(i), OCX(i - 1), OCY(i - 1), 5

        End If

    Next

    _Display

    _Limit 30

    a = a + _Pi(1 / 45)

    If a > _Pi Then a = -_Pi

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



Sub MapHeart (cx, cy, magnify)

    ' dim shared hX, hY 1 to blades

    For a = -_Pi To _Pi - .001 Step _Pi(2 / blades)

        i = i + 1

        hX(i) = cx + magnify * xCard(a)

        hY(i) = cy - magnify * yCard(a)

    Next

End Sub



' 2023-09-27 000Test/Graphics/FatLine test and demo

Sub FatLine (x, y, x2, y2, wide As Integer)

    ' this sub needs fcirc

    Dim dx, dy, distance, r

    dx = x2 - x

    dy = y2 - y

    distance = _Hypot(dx, dy)

    r = Int(wide / 2)

    If distance Then '  bullet proof

        dx = dx / distance

        dy = dy / distance

        If r = 0 Then

            Line (x, y)-(x2, y2), c

        Else

            Dim i As Long

            While i <= distance

                FCirc x + i * dx, y + i * dy, r

                i = i + 1

            Wend

        End If

    Else

        If r = 0 Then ' bullet proof

            PSet (x, y), c

        Else

            FCirc x, y, r

        End If

    End If

End Sub



Sub FCirc (CX As Long, CY As Long, R As Long)

    Dim Radius As Long, RadiusError As Long

    Dim X As Long, Y As Long

    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0

    If Radius = 0 Then PSet (CX, CY): Exit Sub

    Line (CX - X, CY)-(CX + X, CY), , BF

    While X > Y

        RadiusError = RadiusError + Y * 2 + 1

        If RadiusError >= 0 Then

            If X <> Y + 1 Then

                Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF

                Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

        Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF

        Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF

    Wend

End Sub