Happy Valentine's Day!

[bplus]

Inspired by Charlies BAM take on RR of BBC Conic Shape:
https://qb64phoenix.com/forum/showthread...3#pid39873

Code: (Select All)

_Title "Cardiac Conic Shape" 'b+ 2026-02-14

' 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

    For i = 1 To blades

        Line (CX, CY)-(hX(i), hY(i))

        ' and line from heart point to outer circle

        Line (hX(i), hY(i))-(OCX(i), OCY(i))

        If (i Mod 2 = 0) Then

            Color pal~&(i - 1)

            Line (hX(i), hY(i))-(hX(i - 1), hY(i - 1))

            Line (OCX(i), OCY(i))-(OCX(i - 1), OCY(i - 1))

        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

   

[bplus]

Here is my mod that fills colors inside the lines

Code: (Select All)

_Title "Cardiac Conic Shape 2" 'b+ 2026-02-14

' 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)

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

Color &HFFFF0000

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

    For i = 1 To blades

        Line (CX, CY)-(hX(i), hY(i))

        ' and line from heart point to outer circle

        Line (hX(i), hY(i))-(OCX(i), OCY(i))

        If (i Mod 2 = 0) Then

            Line (hX(i), hY(i))-(hX(i - 1), hY(i - 1))

            Line (OCX(i), OCY(i))-(OCX(i - 1), OCY(i - 1))

        End If

    Next

    i = 0

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

        i = i + 1

        If i Mod 2 = 0 Then

            px = CX + (BigCircRadius - 3) * Cos(a1 - _Pi(2 / (2 * blades)))

            py = CY + (BigCircRadius - 3) * Sin(a1 - _Pi(2 / (2 * blades)))

            'Circle (px, py), 2, &HFFFF0000

            Paint (px, py), &HFFFFFFFF, &HFFFF0000

            ftri CX, CY, hX(i), hY(i), hX(i - 1), hY(i - 1), &HFFFF0000

        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



Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)

    Dim D As Long

    Static a&

    D = _Dest

    If a& = 0 Then a& = _NewImage(1, 1, 32)

    _Dest a&

    _DontBlend a& '  '<<<< new 2019-12-16 fix

    PSet (0, 0), K

    _Blend a& '<<<< new 2019-12-16 fix

    _Dest D

    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)

End Sub

   

[PhilOfPerth]

Here is my mod that fills colors inside the lines

Code: (Select All)

_Title "Cardiac Conic Shape 2" 'b+ 2026-02-14

' 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)

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

Color &HFFFF0000

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

    For i = 1 To blades

        Line (CX, CY)-(hX(i), hY(i))

        ' and line from heart point to outer circle

        Line (hX(i), hY(i))-(OCX(i), OCY(i))

        If (i Mod 2 = 0) Then

            Line (hX(i), hY(i))-(hX(i - 1), hY(i - 1))

            Line (OCX(i), OCY(i))-(OCX(i - 1), OCY(i - 1))

        End If

    Next

    i = 0

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

        i = i + 1

        If i Mod 2 = 0 Then

            px = CX + (BigCircRadius - 3) * Cos(a1 - _Pi(2 / (2 * blades)))

            py = CY + (BigCircRadius - 3) * Sin(a1 - _Pi(2 / (2 * blades)))

            'Circle (px, py), 2, &HFFFF0000

            Paint (px, py), &HFFFFFFFF, &HFFFF0000

            ftri CX, CY, hX(i), hY(i), hX(i - 1), hY(i - 1), &HFFFF0000

        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



Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)

    Dim D As Long

    Static a&

    D = _Dest

    If a& = 0 Then a& = _NewImage(1, 1, 32)

    _Dest a&

    _DontBlend a& '  '<<<< new 2019-12-16 fix

    PSet (0, 0), K

    _Blend a& '<<<< new 2019-12-16 fix

    _Dest D

    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)

End Sub

Nice!
I didn't even see the heart in the original. 

[Magdha]

[bplus]

Thankyou Phil and Magdha, I luv the encouragement!

Ha! "didn't see the heart", I been thinking that first one does need Thick Lines to show off better what it is and now that my brain is in mod mode, how about more and more, skinnier and skinnier blades?

Well I wont wait for validation, its the obvious next place to go with this  
Maybe next Valentine's Day b+LOL

[NakedApe]

Nice proggie, @bplus! What's your math background? Teacher? Math major? Calculus crusader? 

[Dimster]

Nice work b .. reminds me of that old riddle, what's black and white and red all over?... a newspaper. I like your answer to that riddle.

[bplus]

Thanks naked, 
I did major in math in college after starting out as biology major, too much memorization there though learning how body functions was interesting. It was Liberal college so it's not like an MIT Math Major. In fact they wouldn't let me take all the math courses I wanted and I started late so... not too much math.

Actually I learned about Computer Sin and Cos doing hexagonal drawing from example program in SmallBASIC way back in 2014-2015 or so. Oh that's why Sin and Cos are so parctical and helpful!!! From hexagonal to any polygonal number of sides. Then there was polar graphing for radianAngle = 0 to _Pi Step some fraction of Pi like with graphing heart shape. RadianAngle, as in what works for Sin and Cos functions. 

I think this is that program from SmallBASIC:

Code: (Select All)

#!/usr/local/bin/sbasic -g
' hexagon.bas
' 28/05/2000

sf=.95
x=(ymax/2)-10:y=0:cx=xmax/2:cy=ymax/2
c=cos(pi/3):s=sin(pi/3)
c1=cos(pi/36):s1=sin(pi/36)

cls
view xmax/20,xmax/20,xmax/1.2,ymax/1.2,15,2

for j=1 to 30
    sx=x+cx:sy=cy-y
    pset sx,sy
    for i=0 to 6
        sx=x+cx:sy=cy-y
        line sx,sy color i*6
        xn=x*c-y*s
        y=x*s+y*c
        x=xn
    next
    xn=sf*(x*c1-y*s1)
    y=sf*(x*s1+y*c1)
    x=xn
next

You never know when a snippet like this becomes a great teacher!

Now I want to post that code to PE... because I swear this looks so different now???

Oops! No that wasn't the code I learned from, here is SB output:
   

I will try again the old library is still there, I contributed allot! to it. I was the librarian there for awhile
https://smallbasic.github.io/pages/samples.html

Update #2 dang could not find that old code but had fun checking out all this old stuff!

[bplus]

Thanks @Dimster I thought the answer to that old joke was a sun burned zebra!

[SMcNeill]

Thanks @Dimster I thought the answer to that old joke was a sun burned zebra!

A skunk in a blender?