Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Another small filled circe sub (not as fast as fcirc)
#81
+1 a740g good to have your skills looking into this. I added the Checking Off | On to FC3 from your examples.

I tested your latest update of Gold against FC3 in the handicapped spot, FC3 does quite well even in less trials, 10000. So in 14 sec races instead of 20 minute ones (on my system) and FC3 in handicapped spot of going first I was surprised it won at all.
Code: (Select All)
_Title "Circle Fill speed tests"

Screen _NewImage(1220, 680, 32)
_ScreenMove 50, 20
_Delay 1
ntests = 1000000 'it takes a really long run to prove Gold Standard Speed 167.9 versus vince 168.1
ntests = 10000 'fast elimination

'It has been noticed that the one going first has a disadvantage

' ==================================================== the contender on left of screen

start## = Timer(.001) ' going first is a disadvantage so if FC3 can close gap from first it's good
For i = 1 To ntests
    FC3 305, 305, 300, _RGBA32(0, 100, 0, 100)
    'arcRing 305, 305, 300, 0, 0, 2 * _Pi, _RGBA32(0, 100, 0, 100)
Next
finish## = Timer(.001) - start##
_PrintString (100, 615), "Time for" + Str$(ntests) + " FC3 Fills:" + Str$(finish##)


start## = Timer(.001) 'this runs the Gold standard to beat  on Right Side of screen
For i = 1 To ntests
    DFC 915, 305, 300, _RGBA32(0, 100, 0, 100)
Next
finish## = Timer(.001) - start##
_PrintString (700, 615), "Time for" + Str$(ntests) + " DFC Circle Fills:" + Str$(finish##)

'from  Gold standard
Sub fcirc0 (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer

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

    If Radius = 0 Then PSet (CX, CY), C: 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), 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


'vince's circle fill   this one does not bother with types good almost identical to Steve's
Sub fcirc1 (x, y, r, c As _Unsigned Long)
    x0 = r
    y0 = 0
    e = -r
    Do While y0 < x0
        If e <= 0 Then
            y0 = y0 + 1
            Line (x - x0, y + y0)-(x + x0, y + y0), c, BF
            Line (x - x0, y - y0)-(x + x0, y - y0), c, BF
            e = e + 2 * y0
        Else
            Line (x - y0, y - x0)-(x + y0, y - x0), c, BF
            Line (x - y0, y + x0)-(x + y0, y + x0), c, BF
            x0 = x0 - 1
            e = e - 2 * x0
        End If
    Loop
    Line (x - r, y)-(x + r, y), c, BF
End Sub

'this does not overlap with circle well 2.13 x's Gold Time
Sub fCirc2 (xx As Long, yy As Long, r As Long, K As _Unsigned Long)
    Dim r2 As Long, x As Long, y As Long, xstop As Long
    r2 = r * r
    x = 1
    xstop = r + 1
    While x < xstop 'remove FOR loop
        y = Sqr(r2 - x * x)
        Line (xx - x, yy + y)-(xx - x, yy - y), K, BF
        Line (xx + x, yy + y)-(xx + x, yy - y), K, BF
        x = x + 1
    Wend
    Line (xx, yy - r)-(xx, yy + r), K, BF
End Sub

'andy amaya's version from SB, way too much overlapping!   Junk as is but 1.1 Gold Standard Time
Sub fCirc3 (CX As Long, CY As Long, R As Long, K As _Unsigned Long) 'thanks Andy Amaya for heads up
    Dim x As Long, y As Long, Xchange As Integer, yChange As Integer, RadiusError As Integer
    x = R
    y = 0
    Xchange = 1 - 2 * R
    yChange = 1
    RadiusError = 0

    While x >= y
        Line (CX - x, CY + y)-(CX + x, CY + y), K, BF ';used calc'd values to draw
        Line (CX - x, CY - y)-(CX + x, CY - y), K, BF ';scan lines from points
        Line (CX - y, CY + x)-(CX + y, CY + x), K, BF ';in opposite octants
        Line (CX - y, CY - x)-(CX + y, CY - x), K, BF
        y = y + 1
        RadiusError = RadiusError + yChange
        yChange = yChange + 2

        If 2 * RadiusError + Xchange > 0 Then
            x = x - 1
            RadiusError = RadiusError + Xchange
            Xchange = Xchange + 2
        End If
    Wend
End Sub

'fCirc but doing octants until get to square, then just do square fill! 1.18 Gold Sdt
'this is closer to matching the Gold Standard
Sub fCirc4 (xx As Long, yy As Long, r As Long, K As _Unsigned Long)
    Dim r2 As Long, t As Long, dist As Long, tstop As Long
    r2 = r * r
    t = r 'r - 1 gets rid of nipples but...
    tstop = r * .707106781
    While t > tstop 'remove FOR loop
        dist = Sqr(r2 - t * t) ' + .5 for rounding down
        Line (xx - t, yy + dist)-(xx - t, yy - dist), K, BF
        Line (xx + t, yy + dist)-(xx + t, yy - dist), K, BF
        Line (xx + dist, yy + t)-(xx - dist, yy + t), K, BF
        Line (xx + dist, yy - t)-(xx - dist, yy - t), K, BF
        t = t - 1
    Wend
    Line (xx - tstop, yy - tstop)-(xx + tstop, yy + tstop), K, BF
End Sub

'add a routine for sqr root   1,16 X's Gold Std
Sub fCirc5 (xx As Long, yy As Long, r As Long, K As _Unsigned Long)
    Dim r2 As Long, t As Long, tstop As Long
    Dim dist1 As Single, dist As Single, dist2 As Long, s As Long
    r2 = r * r
    t = r 'r - 1 gets rid of nipples but...
    tstop = r * .707106781
    While t > tstop 'remove FOR loop

        'VVVVVVVVVVVVVVVVVVV this might now save a shade off SQR
        s = r2 - t * t
        dist = s / 10
        dist2 = dist * dist
        'WHILE ABS(dist ^ 2 - s) >= 1  'no! avoid function calls!
        While dist2 - s > 1 Or dist2 - s < -1
            dist = .5 * (dist + s / dist)
            dist2 = dist * dist
        Wend

        'VVVVVVVVVVVVVVVVV  faster to use this YES
        'dist = SQR(r2 - t * t) ' + .5 for rounding down


        Line (xx - t, yy + dist)-(xx - t, yy - dist), K, BF
        Line (xx + t, yy + dist)-(xx + t, yy - dist), K, BF
        Line (xx + dist, yy + t)-(xx - dist, yy + t), K, BF
        Line (xx + dist, yy - t)-(xx - dist, yy - t), K, BF
        t = t - 1
    Wend
    Line (xx - tstop, yy - tstop)-(xx + tstop, yy + tstop), K, BF
End Sub

'too slow, dest can't just be 0  Junk as is
Sub fcirc6 (xOrigin As Long, yOrigin As Long, radius As Long, K As _Unsigned Long)
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest 0
    Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long, i As Integer
    Dim polyAngle As Single
    polyAngle = _Pi(2) / 60
    x1 = xOrigin + radius * Cos(polyAngle)
    y1 = yOrigin + radius * Sin(polyAngle)
    For i = 2 To 61
        x2 = xOrigin + radius * Cos(i * polyAngle)
        y2 = yOrigin + radius * Sin(i * polyAngle)
        _MapTriangle (0, 0)-(0, 0)-(0, 0), a& To(xOrigin, yOrigin)-(x1, y1)-(x2, y2), 0
        x1 = x2: y1 = y2
    Next
    _FreeImage a& '<<< this is important!
End Sub

'doing a circle fill with this runs 20 x's slower than Gold Std Circle Fill
Sub arcRing (x0, y0, outerR, innerR, raStart, raEnd, colr As _Unsigned Long)
    PI2 = _Pi(2)
    PI32 = _Pi(1.5)
    PIh = _Pi(.5)
    PI = _Pi
    raS = raStart
    While raS >= PI2
        raS = raS - PI2
    Wend
    While raS < 0
        raS = raS + PI2
    Wend
    raE = raEnd
    While raE < 0
        raE = raE + PI2
    Wend
    While raE >= PI2
        raE = raE - PI2
    Wend
    If raE > raS Then ck1 = -1
    For y = y0 - outerR To y0 + outerR
        For x = x0 - outerR To x0 + outerR
            dist = Sqr((x - x0) * (x - x0) + (y - y0) * (y - y0))
            If dist >= innerR And dist <= outerR Then 'within 2 radii
                'angle of x, y to x0, y0
                If x - x0 <> 0 And y - y0 <> 0 Then
                    ra = _Atan2(y - y0, x - x0)
                    If ra < 0 Then ra = ra + PI2
                ElseIf x - x0 = 0 Then
                    If y >= y0 Then ra = _Pi / 2 Else ra = PI32
                ElseIf y - y0 = 0 Then
                    If x >= x0 Then ra = 0 Else ra = PI
                End If
                If ck1 Then 'raEnd > raStart
                    If ra >= raS And ra <= raE Then
                        PSet (x, y), colr
                    End If
                Else 'raEnd < raStart, raEnd is falls before raStart clockwise so fill through 2 * PI
                    If ra >= raS And ra < PI2 Then
                        PSet (x, y), colr
                    Else
                        If ra >= 0 And ra <= raE Then
                            PSet (x, y), colr
                        End If
                    End If
                End If
            End If
        Next
    Next
End Sub

' best 2024-08-31 updated 2024-09-01 with Samuel trick using Checking Off and ON
Sub FC3 (cx, cy, r, clr~&) ' no suffix punctuation use the Global Default Type as Long or Single or Double
    $Checking:Off
    Dim r2, x, y ' for Option _Explicit
    If r < 1 Then Exit Sub
    Line (cx - r, cy)-(cx + r, cy), clr~&, BF
    r2 = r * r
    Do
        y = y + 1
        x = Sqr(r2 - y * y)
        Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
        Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
    Loop Until y = r
    $Checking:On
End Sub

' samuel 2024-09-01 updated Gold Standard ?
Sub DFC (cx As Long, cy As Long, r As Long, c As _Unsigned Long)
    $Checking:Off

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

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

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

    Do While x > y
        y = y + 1
        e = e + y * 2

        If e >= 0 Then
            If x <> y 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
            e = e - x * 2
        End If

        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

@a740g have you run timed tests comparing your updated version against the old Gold Standard?
b = b + ...
Reply


Messages In This Thread
RE: Another small filled circe sub (not as fast as fcirc) - by bplus - 09-01-2024, 08:31 AM



Users browsing this thread: 28 Guest(s)