Another small filled circe sub (not as fast as fcirc)

[bplus]

here's where it gets "fun"

I changed the order of tests and did them on fullscreen because no way I have a screen as wide as you used!
Gold run first, Dav 2nd and finish with Vince = completely different race

Code: (Select All)

_Define A-Z As LONG
Option _Explicit

Const CCOLOR~& = _RGBA32(0, 100, 0, 100)

_Title "Sam Circle Fill speed tests"

Screen _NewImage(1830, 680, 32)
_FullScreen
' Dry run
Sleep 1
_PrintString (0, 0), "Dry run..."
Run_Test 10000

' Showdown
Sleep 5
Cls
_PrintString (0, 0), "Showdown..."
Run_Test 200000

End

Sub Run_Test (iterations As Long)
    Static As Double start, finish
    Static i As Long

    _Display
    start = Timer
    For i = 1 To iterations
        FC_Gold 1525, 305, 300, CCOLOR
    Next
    finish = Timer(0.001!) - start
    _AutoDisplay
    _PrintString (1300, 615), "Time for" + Str$(iterations) + " Gold Standard Circle Fills:" + Str$(finish)

    _Display

    start = Timer(0.001!)
    For i = 1 To iterations
        FC_Dav 305, 305, 300, CCOLOR
    Next
    finish = Timer(0.001!) - start
    _AutoDisplay
    _PrintString (100, 615), "Time for" + Str$(iterations) + " Contender Fills (Dav):" + Str$(finish)

    _Display
    start = Timer
    For i = 1 To iterations
        FC_Vince 915, 305, 300, CCOLOR
    Next
    finish = Timer(0.001!) - start
    _AutoDisplay
    _PrintString (700, 615), "Time for" + Str$(iterations) + " Contender Fills (Vince):" + Str$(finish)

    '_DISPLAY
    'start = TIMER
    'FOR i = 1 TO iterations
    '    FC_Gold 1525, 305, 300, CCOLOR
    'NEXT
    'finish = TIMER(0.001!) - start
    '_AUTODISPLAY
    '_PRINTSTRING (1300, 615), "Time for" + STR$(iterations) + " Gold Standard Circle Fills:" + STR$(finish)
End Sub

Sub FC_Gold (cx As Long, cy As Long, r As Long, c As _Unsigned Long)
    $Checking:Off

    Dim radius As Long: radius = Abs(r)
    Dim radiusError As Long: radiusError = -radius
    Dim x As Long: x = radius
    Dim y As Long

    If radius = 0 Then
        PSet (cx, cy), c
        Exit Sub
    End If

    Line (cx - x, cy)-(cx + x, cy), c, BF

    Do While x > y
        radiusError = radiusError + _ShL(y, 1) + 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 - _ShL(x, 1)
        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
    Loop

    $Checking:On
End Sub

Sub FC_Dav (cx As Long, cy As Long, r As Long, c As _Unsigned Long)
    $Checking:Off

    Dim r2 As Long: r2 = r * r
    Dim As Long x, y

    Line (cx - r, cy)-(cx + r, cy), c, BF

    Do While y < r
        y = y + 1

        x = Sqr(r2 - y * y)

        Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
        Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
    Loop

    $Checking:On
End Sub

Sub FC_Vince (cx As Long, cy As Long, r As Long, c As _Unsigned Long)
    $Checking:Off

    Dim e As Long: e = -r
    Dim x As Long: x = r
    Dim y As Long

    Do While y < x
        If e <= 0 Then
            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

            e = e + _ShL(y, 1)
        Else
            Line (cx - y, cy - x)-(cx + y, cy - x), c, BF
            Line (cx - y, cy + x)-(cx + y, cy + x), c, BF

            x = x - 1

            e = e - _ShL(x, 1)
        End If
    Loop

    Line (cx - r, cy)-(cx + r, cy), c, BF

    $Checking:On
End Sub

Here are results:
   

A 2nd run and Gold Standard proves itself