09-02-2024, 07:40 PM
+1 @Dav it's certainly faster than my DrawBall version
I am adding $Checking: Off | On to these routines.
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 = 1000 'fast elimination
'It has been noticed that the one going first has a disadvantage
' ==================================================== the contender on left of screen
start## = Timer(.001) 'this runs the Gold standard to beat on Right Side of screen
For i = 1 To ntests
fc 915, 305, 300, _RGBA32(0, 100, 0, 100), 1
Next
finish## = Timer(.001) - start##
_PrintString (700, 615), "Time for" + Str$(ntests) + " FC grad = 1 Circle Fills:" + Str$(finish##)
start## = Timer(.001) ' going first is a disadvantage so if FC3 can close gap from first it's good
For i = 1 To ntests
drawBall 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) + " DrawBall 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
Sub PeteFC3 (cx, cy, r, clr~&)
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r ' Dav mod
Do Until y = r ' Since we are working with integers, would this be an alternative?
y = y + 1
x = Sqr(r2 - y * y) ' r2 Dav
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop
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
Sub drawBall (x, y, r, c As _Unsigned Long)
$Checking:Off
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - Sin(rr / r) ' thank OldMoses for Sin ;-))
FC3 x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
$Checking:On
End Sub
Sub fc (cx, cy, radius, clr~&, grad)
$Checking:Off
If grad = 1 Then
red = _Red32(clr~&)
grn = _Green32(clr~&)
blu = _Blue32(clr~&)
alpha = _Alpha32(clr~&)
End If
r2 = radius * radius
For y = -radius To radius
x = Sqr(r2 - y * y)
'if doing gradient
If grad = 1 Then
For i = -x To x
dis = Sqr(i * i + y * y) / radius
red2 = red * (1 - dis) + (red / 2) * dis
grn2 = grn * (1 - dis) + (grn / 2) * dis
blu2 = blu * (1 - dis) + (blu / 2) * dis
clr2~& = _RGBA(red2, grn2, blu2, alpha)
Line (cx + i, cy + y)-(cx + i, cy + y), clr2~&, BF
Next
Else
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
End If
Next
$Checking:On
End SubI am adding $Checking: Off | On to these routines.
b = b + ...