Proggies

[bplus]

Kaleidoscope

Code: (Select All)

_Title "Kaleidoscope" 'b+ 2022-05-24
' it so obvious to use maptriangle!
Randomize Timer
Dim Shared sH, sW, sHd2, sWd2
sH = 700: sW = 700: sHd2 = sH / 2: sWd2 = sW / 2
Screen _NewImage(700, 700, 32)
_ScreenMove 290, 0
Do Until _KeyDown(27)
    If Rnd > .05 Then Line (0, 0)-(sW - 1, sH - 1), _RGB32(0, 0, 0, 10), BF Else Cls
    n = (n + 1) Mod 66 + 4
    If n Mod 2 Then n = n + 1
    ReDim px(0 To n - 1), py(0 To n - 1)
    circleDivN = _Pi(2 / n)
    For i = 0 To n - 1
        px(i) = sWd2 + sHd2 * Cos(i * circleDivN)
        py(i) = sHd2 + sHd2 * Sin(i * circleDivN)
    Next
    For i = 1 To 700
        Line (Rnd * sW, Rnd * sH)-Step(Rnd * 5, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
        Circle (Rnd * sW, Rnd * sH), Rnd * 8 + 2, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
    Next
    For i = 1 To 30
        w = Rnd * 700
        Line (sWd2 - w / 2, Rnd * sH)-Step(w, Rnd * 5), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255), BF
    Next
    For s = 0 To n - 1
        For i = 0 To n - 1
            _MapTriangle (sWd2, sHd2)-(px((i + s) Mod n), py((i + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n)), 0 To(sWd2, sHd2)-(px((i + 2 + s) Mod n), py((i + 2 + s) Mod n))-(px((i + 1 + s) Mod n), py((i + 1 + s) Mod n))
        Next
    Next
    _Display
    _Limit 2
Loop

[vince]

2000th post here at Phoenix:

Code: (Select All)

Title "Flower Wheel" ' b+ 2022-04?

Nice fractal, bplus.  This also looks like a JB original

[bplus]

Networking (no not that kind) Color Domination Theory

Code: (Select All)

_Title "Networking 1 translation" 'by B+ started 2018-11-13 mod 2022-05-29
Randomize Timer
Const xmax = 800, ymax = 600, nP = 500, rD = 35
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 200, 60
Dim x(nP), y(nP), dx(nP), dy(nP), c(nP) As _Unsigned Long

'initialize points
For i = 0 To nP
    x(i) = Rnd * xmax: y(i) = Rnd * ymax
    If Rnd < .5 Then dx(i) = -3 * Rnd - .5 Else dx(i) = 3 * Rnd + .5
    If Rnd < .5 Then dy(i) = -3 * Rnd - .5 Else dy(i) = 3 * Rnd + .5
    c(i) = _RGB32(Rnd * 200 + 55, Rnd * 200 + 55, Rnd * 200 + 55)
Next
While _KeyDown(27) = 0
    Cls
    For i = 0 To nP 'big show of points and triangle
        Color c(i)
        Line (x(i), y(i))-Step(1, 1), c(i), BF
        For j = i + 1 To nP 'search for triangle points within 100 pixels
            If distance(x(i), y(i), x(j), y(j)) < rD Then
                For k = j + 1 To nP
                    If distance(x(k), y(k), x(j), y(j)) < rD Then
                        If distance(x(k), y(k), x(i), y(i)) < rD Then
                            'draw 3 lines of triangle
                            Line (x(i), y(i))-(x(j), y(j)), c(i)
                            Line (x(k), y(k))-(x(j), y(j)), c(i)
                            Line (x(i), y(i))-(x(k), y(k)), c(i)
                            c(j) = c(i): c(k) = c(i)
                        End If
                    End If
                Next
            End If
        Next
        'update points
        x(i) = x(i) + dx(i)
        y(i) = y(i) + dy(i)
        If x(i) < 0 Then x(i) = xmax + x(i)
        If x(i) > xmax Then x(i) = x(i) - xmax
        If y(i) < 0 Then y(i) = 0: dy(i) = dy(i) * -1
        If y(i) > ymax Then y(i) = ymax: dy(i) = dy(i) * -1
    Next
    _Display
    _Limit 200
Wend

Function distance (x1, y1, x2, y2)
    distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ .5
End Function

Quiz: Why did I call it Color Domination Theory?


Update: Now see it in action on QBJS!

https://qbjs.org/index.html?code=T3B0aW9...QrkAbLIWwo=


If you wait awhile, sometimes a long while, you will see a color take over.

[bplus]

For Memorial Day

Code: (Select All)

_Title "For Memorial Day mod x3" 'trans 2019-05-29 B+ from wave mod2x
'For Memorial Day.txt for Just Basic v1.01 [B+=MGA] 2016-05-29
' plus ad lib

' notes: American Flag close to proportion standards
'
' verticals:
' Hoist Flag = 1.0 vertical height use 650 pixels because divided by 13 = 50 each stripe
'Hoist Union = 7/13        = 350
'     stripe = 1/13        =  50
' star space = .054        =  350/(10 spaces) = 35 pixels   35/650 ~ .5385
'
' horizontals:
'  Fly Flag length = 1.9   = 650 * 1.9 = 1235
' Fly Union length =  .76  = 650 * .76 = 494
'       star space =  .063  494/(12 spaces) ~  41.167 using 41 * 12 = 492 add 1 pixel before and after stars

'star outer diameter = .0616 * 650 ~ 40 (40.04) so outer radius is 20
' and inner (20 / 2.5) = 8 < does not look right try 7

Const xMaxScreen = 1280
Const yMaxScreen = 780
Const xMaxFlag = 1235 '<=== actual drawing space needed
Const yMaxFlag = 650 '<=== actual drawing space needed
Const PI = _Pi
Const DEG = 180 / PI
Const RAD = PI / 180

Const White = &HFFFFFFFF
'https://www.google.com/search?client=opera&q=US+flag+blue+spec&sourceid=opera&ie=UTF-8&oe=UTF-8
Const OldGloryRed = &HFFBF0A30
Const OldGloryBlue = &HFF002868
Const Sky& = &H2F40A0FF
Dim Shared Flag As Long, p


Screen _NewImage(xMaxScreen, yMaxScreen, 32)
Flag = _NewImage(xMaxFlag, yMaxFlag, 32)

_ScreenMove 70, 0

_Dest Flag
Line (0, 0)-(xMaxFlag, yMaxFlag), OldGloryRed, BF
For row = 1 To 12 Step 2
    Line (0, row * 50)-(xMaxFlag - 1, (row + 1) * 50 - 1), White, BF
Next
'the "Union"
Line (0, 0)-(494, 350), OldGloryBlue, BF
For row = 1 To 9
    ystar = 35 * row
    If row Mod 2 = 1 Then
        For col = 0 To 5
            xstar = 42 + col * 2 * 41
            star xstar, ystar, 7.5, 19.5, 5, 18, White
        Next
    Else
        For col = 0 To 4
            xstar = 83 + col * 2 * 41
            star xstar, ystar, 7.5, 19.5, 5, 18, White
        Next
    End If
Next
_Dest 0
_Source Flag
Color Sky, Sky
_SetAlpha 150, &H00000000 To &HFFFFFFFF, Flag
Do
    Line (0, 0)-(xMaxScreen, yMaxScreen), Sky, BF
    sc = Rnd * yMaxFlag * .5 + 10
    rw = sc * 1.9
    rh = sc
    _PutImage (Rnd * xMaxScreen - .5 * rw, Rnd * (yMaxScreen) - .5 * rh)-Step(rw, rh), Flag, 0
    _Display
    _Limit 2
Loop

Sub star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
    ' x, y are same as for circle,
    ' rInner is center circle radius
    ' rOuter is the outer most point of star
    ' nPoints is the number of points,
    ' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
    ' this is to allow us to spin the polygon of n sides

    pAngle = RAD * (360 / nPoints): radAngleOffset = RAD * angleOffset
    x1 = x + rInner * Cos(radAngleOffset)
    y1 = y + rInner * Sin(radAngleOffset)
    For i = 0 To nPoints - 1
        x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
        y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
        x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
        y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
        ftri x1, y1, x2, y2, x3, y3, K
        'triangles leaked
        Line (x1, y1)-(x2, y2), White
        Line (x2, y2)-(x3, y3), White
        Line (x3, y3)-(x1, y1), White
        x1 = x3: y1 = y3
    Next
    Paint (x, y), White, White
End Sub

Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    a& = _NewImage(1, 1, 32)
    predest = _Dest
    _Dest a&
    PSet (0, 0), K
    _Dest predest
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

   

[bplus]

Goldwave

Here is a Golden Oldie that Aurel dragged out at his forum:

Code: (Select All)

_Title "Gold Wave bplus 2018-03-13"
'translated from SmallBASIC: Goldwave by johnno copied and mod by bplus 2018-01-28

'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
Const xmax = 600
Const ymax = 480
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 60
Dim ccc As _Unsigned Long


'                  compare fill triangle subs:  one uses very simple  _MAPTRIANGLE opt = 1
'                                               2nd uses primative line graphic0s  opt <> 1


opt = 0 ' << opt 1 uses _MAPTRIANGLE to fill triangles, any other uses line filled triangles
While 1
    For t = 1 To 60 Step .1 '< changed
        Cls 'changed
        For y1 = 0 To 24
            For x1 = 0 To 24
                x = (12 * (24 - x1)) + (12 * y1)
                y = (-6 * (24 - x1)) + (6 * y1) + 300
                d = ((10 - x1) ^ 2 + (10 - y1) ^ 2) ^ .5
                h = 60 * Sin(x1 / 4 + t) + 65
                If t > 10 And t < 20 Then h = 60 * Sin(y1 / 4 + t) + 65
                If t > 20 And t < 30 Then h = 60 * Sin((x1 - y1) / 4 + t) + 65
                If t > 30 And t < 40 Then h = 30 * Sin(x1 / 2 + t) + 30 * Sin(y1 / 2 + t) + 65
                If t > 40 And t < 50 Then h = 60 * Sin((x1 + y1) / 4 + t) + 65
                If t > 50 And t < 60 Then h = 60 * Sin(d * .3 + t) + 65
                If opt = 1 Then
                    'TOP
                    ccc = _RGB32(242 + .1 * h, 242 + .1 * h, h)
                    filltri x, y - h, x + 10, y + 5 - h, x + 20, y - h, ccc
                    filltri x, y - h, x + 10, y - 5 - h, x + 20, y - h, ccc
                    'FRONT-LEFT
                    ccc = _RGB(255, 80, 0)
                    filltri x, y - h, x + 10, y + 5 - h, x + 10, y, ccc
                    filltri x, y - h, x, y - 5, x + 10, y, ccc
                    'FRONT-RIGHT
                    ccc = _RGB32(255, 150, 0)
                    filltri x + 10, y + 5 - h, x + 10, y, x + 20, y - 5, ccc
                    filltri x + 10, y + 5 - h, x + 20, y - h, x + 20, y - 5, ccc
                Else
                    Color _RGB32(242 + .1 * h, 242 + .1 * h, h)
                    filltri2 x, y - h, x + 10, y + 5 - h, x + 20, y - h
                    filltri2 x, y - h, x + 10, y - 5 - h, x + 20, y - h
                    'FRONT-LEFT
                    Color _RGB32(255, 80, 0)
                    filltri2 x, y - h, x + 10, y + 5 - h, x + 10, y
                    filltri2 x, y - h, x, y - 5, x + 10, y
                    Color _RGB32(255, 150, 0)
                    filltri2 x + 10, y + 5 - h, x + 10, y, x + 20, y - 5
                    filltri2 x + 10, y + 5 - h, x + 20, y - h, x + 20, y - 5
                End If

                If InKey$ = Chr$(27) Then End
            Next
        Next
        _Display
        _Limit 200
    Next
Wend

'Andy Amaya's modified FillTriangle
Sub filltri2 (xx1, yy1, xx2, yy2, xx3, yy3)
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
    'thanks Andy Amaya!
    'triangle coordinates must be ordered: where x1 < x2 < x3
    If x2 < x1 Then Swap x1, x2: Swap y1, y2
    If x3 < x1 Then Swap x1, x3: Swap y1, y3
    If x3 < x2 Then Swap x2, x3: Swap y2, y3
    If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)

    'draw the first half of the triangle
    length = x2 - x1
    If length <> 0 Then
        slope2 = (y2 - y1) / (x2 - x1)
        For x = 0 To length
            Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1))
            'lastx2% = lastx%
            lastx% = Int(x + x1)
        Next
    End If

    'draw the second half of the triangle
    y = length * slope1 + y1: length = x3 - x2
    If length <> 0 Then
        slope3 = (y3 - y2) / (x3 - x2)
        For x = 0 To length
            'IF INT(x + x2) <> lastx% AND INT(x + x2) <> lastx2% THEN  'works! but need 2nd? check
            If Int(x + x2) <> lastx% Then
                Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2))
            End If
        Next
    End If
End Sub

' found at QB64.net:    http://www.qb64.net/forum/index.php?topic=14425.0
Sub filltri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest 0
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

           

[triggered]

This reminds me of Mennonite's sinecube

[bplus]

That's a great proggie see Sample Misc Sinecube.bas.

I remember he showed us it at old SmallBASIC forum or BP.org before I knew about QB64!

[bplus]

Celtic Knot Puzzle

Click tiles in top left figure to make a 6 x 6 tile Celtic Knot much like my Avatar ;-))

Press escape and the image will be copied and rotated 45 degrees and be drawn in bottom right corner, to compare to my Avatar. Hint: I needed a solution image to use when building, it's not easy!

Code: (Select All)

_Title "A Celtic Knot Puzzle - click the piece build a knot!" ' b+ 2022-06-06
Screen _NewImage(1200, 700, 32)
_ScreenMove 130, 20
d& = _LoadImage("D tile.png")
d2& = _LoadImage("D2 tile.png")
_PutImage (0, 1), d&, 0
Bg~& = Point(3, 3)

iw = _Width(d&): ih = _Height(d&)
_PrintString (10, 280), Str$(iw) + Str$(ih)
For i = 0 To 6
    Line (0, i * 44)-(iw, i * 44), &HFFFFFF00
Next
For i = 0 To 16
    Line (i * 44, 0)-(i * 44, ih), &HFFFFFF00
Next
iw2 = _Width(d2&): ih2 = _Height(d2&)
iw2 = 16 * 44: ih2 = 8 * 44
_PutImage (1, 300), d2&, 0
For i = 0 To 8
    Line (0, i * 44 + 300)-(iw2, i * 44 + 300), &HFFFFFF00
Next
For i = 0 To 16
    Line (i * 44, 0 + 300)-(i * 44, ih2 + 300), &HFFFFFF00
Next
_PrintString (10, 660), Str$(iw2) + Str$(ih2)

For i = 0 To 8
    Line (0 + 800, i * 44)-(ih2 + 800, i * 44), &HFFFFFF00
Next
For i = 0 To 8
    Line (i * 44 + 800, 0)-(i * 44 + 800, ih2), &HFFFFFF00
Next

Do
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    If mx < 800 Then
        cellx = Int(mx / 44)
        If my >= 300 Then
            celly = Int((my - 300) / 44): fig = 2
        Else
            celly = Int(my / 44): fig = 1
        End If
    Else
        fig = 3
        cellx = Int((mx - 800) / 44)
        celly = Int(my / 44)
    End If
    If mb Then
        _PrintString (800, 400), Space$(50)
        _PrintString (800, 400), "Fig:" + Str$(fig) + " cell:" + Str$(cellx) + Str$(celly)

        If fig = 1 Then
            If cellx >= 0 And cellx <= 15 And celly >= 0 And celly <= 5 Then
                _PutImage (850, 450)-Step(44, 44), 0, 0, (cellx * 44, celly * 44)-Step(44, 44)
            End If
        ElseIf fig = 2 Then
            If cellx >= 0 And cellx <= 15 And celly >= 0 And celly <= 7 Then
                _PutImage (850, 450)-Step(44, 44), 0, 0, (cellx * 44, celly * 44 + 300)-Step(44, 44)
            End If
        ElseIf fig = 3 Then
            If cellx >= 0 And cellx <= 7 And celly >= 0 And celly <= 7 Then
                _PutImage (cellx * 44 + 800, celly * 44)-Step(44, 44), 0, 0, (850, 450)-Step(44, 44)
            End If
        End If
        _Delay .2
    End If
    ' 800, 450 step 44, 44  ' will be transfer spot   from fig 1 or 2 to fig 3
Loop Until _KeyDown(27)
_PrintString (800, 400), Space$(50) ' erase note
Line (850, 450)-Step(45, 45), &HFF000000, BF ' cover last puzzle piece
' grab image and twist 45 degrees!
trans& = _NewImage(264, 264, 32) 'container to hold image
_PutImage , 0, trans&, (800, 0)-Step(264, 264)
RotoZoom _Width - 190, _Height - 190, trans&, 1, 45
Sleep

Sub RotoZoom (X As Long, Y As Long, Image As Long, Scale As Single, degreesRotation As Single)
    Dim px(3) As Single, py(3) As Single, W&, H&, sinr!, cosr!, i&, x2&, y2&
    W& = _Width(Image&): H& = _Height(Image&)
    px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
    px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
    sinr! = Sin(-degreesRotation / 57.2957795131): cosr! = Cos(-degreesRotation / 57.2957795131)
    For i& = 0 To 3
        x2& = (px(i&) * cosr! + sinr! * py(i&)) * Scale + X: y2& = (py(i&) * cosr! - px(i&) * sinr!) * Scale + Y
        px(i&) = x2&: py(i&) = y2&
    Next
    _MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub

Here is the Puzzle with Solution:
   

Here is the zip with source, exe and 3 images 2 images are used for tiles but never used bottom left and you will want to use solution image to help tile solution.

[bplus]

The Hypotrochoid Show

Code: (Select All)

_Title "The Hypotrochoid Show" 'for QB64 B+ 2019-07-18
Const xmax = 700, ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
c2~& = &HFFBB0000
xc = xmax / 2: yc = ymax / 2: r = yc * .5: st = 1 / (2 * _Pi * r)
n = 0: m = 3
While _KeyDown(27) = 0
    m = m + 1
    For n = 5 To 30 Step .05
        Cls
        For a = 0 To 2 * _Pi Step st
            xReturn = xc + r * (Cos(a) + Cos(n * a) / 3 + Sin(m * a) / 2)
            yReturn = yc + r * (Sin(a) + Sin(n * a) / 3 + Cos(m * a) / 2)
            fcirc xReturn, yReturn, 10, _RGB32(0, 200, 0, n)
            fcirc xReturn, yReturn, 4, c2~&
        Next
        Print "m = "; m; "  n = "; n
        _Display
    Next
    _Delay 1
Wend

Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned 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), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, 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), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

Update: This runs in QBJS but it is slow compared to QB64pe straight up, also modified to work in QBJS
https://qbjs.org/index.html?code=J09wdGl...+uQAhuQCBQ==

[bplus]

Boing

Code: (Select All)

_Title "Mouse down, drag ball, release...  Boing" 'B+ 2019-01-08 from
'boing.bas for SmallBASIC 2015-07-25 MGA/B+
'coloring mods

Const xmax = 1200
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 80, 20

Dim s(1 To 4, 1 To 2)
s(1, 1) = 0: s(1, 2) = 50
s(2, 1) = 0: s(2, 2) = ymax - 50
s(3, 1) = xmax + 30: s(3, 2) = 50
s(4, 1) = xmax + 30: s(4, 2) = ymax - 50
oldtx = 0: oldtyty = 0: da = .03
boingx = 0: boingy = 0
While 1
    While _MouseInput: Wend
    mb = _MouseButton(1)
    If mb Then
        tx = _MouseX + 20
        ty = _MouseY
    Else
        tx = xmax / 2
        ty = ymax / 2
        If tx <> oldtx Or ty <> oldty Then
            boingx = 3 * (tx - oldtx) / 4
            boingy = 3 * (ty - oldty) / 4
        Else
            boingx = -3 * boingx / 4
            boingy = -3 * boingy / 4
        End If
        tx = tx + boingx
        ty = ty + boingy
    End If
    a = 0
    oldtx = tx
    oldty = ty
    Cls
    For corner = 1 To 4
        s1x = s(corner, 1)
        s1y = s(corner, 2)
        dx = (tx - s1x) / 2000
        dy = (ty - s1y) / 2000
        x = tx - 20
        y = ty
        For i = 1 To 2000
            sx = 20 * Cos(a) + x
            sy = 20 * Sin(a) + y
            Line (sx, sy + 5)-(sx + 4, sy + 5), _RGB32(118, 118, 118), BF
            Line (sx, sy + 4)-(sx + 4, sy + 4), _RGB32(148, 148, 148), BF
            Line (sx, sy + 3)-(sx + 4, sy + 3), _RGB32(238, 238, 238), BF
            Line (sx, sy + 2)-(sx + 4, sy + 3), _RGB32(208, 208, 208), BF
            Line (sx, sy + 1)-(sx + 4, sy + 1), _RGB32(168, 168, 168), BF
            Line (sx, sy)-(sx + 4, sy), _RGB32(108, 108, 108), BF
            Line (sx, sy - 1)-(sx + 4, sy - 1), _RGB32(68, 68, 68), BF
            x = x - dx: y = y - dy
            a = a + da
        Next
    Next
    For r = 50 To 1 Step -1
        g = (50 - r) * 5 + 5
        Color _RGB32(g, g, g)
        fcirc tx - 20, ty, r
    Next
    _Display
    _Limit 15
Wend

'Steve McNeil's  copied from his forum   note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long

    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

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

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    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