+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Another small filled circe sub (not as fast as fcirc) (/showthread.php?tid=2989)
RE: Another small filled circe sub (not as fast as fcirc) - bplus - 09-01-2024
+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?
RE: Another small filled circe sub (not as fast as fcirc) - Dav - 09-02-2024
I updated my original FC version to draw gradient balls too. If you want a gradient ball give the grad parameter a 1, otherwise it draws a solid color circle. Here is a demo using it, a moving starfield but with balls, so it's called the ballfield. I'll post just the update SUB at the bottom.
(btw, Happy labor day to all!)
- Dav
Ballfield Demo:
Code: (Select All)
'=============
'BALLFIELD.BAS
'=============
'Shows balls in space coming towards you.
'Dav, SEP/2024
'Uses updated version of FC SUB discussed here:
'https://qb64phoenix.com/forum/showthread.php?tid=2989
Randomize Timer
Screen _NewImage(1000, 700, 32)
balls = 600
Dim ballx(balls), bally(balls), ballz(balls), ballSize(balls)
Dim ballc~&(balls), sort(balls) 'array for bubble sort
' Init balls
For i = 0 To balls - 1
ballx(i) = Rnd * _Width 'x pos
bally(i) = Rnd * _Height 'y pos
ballz(i) = Rnd * 100 + 25 'z depth
ballc~&(i) = _RGBA(55 + (Rnd * 200), 55 + (Rnd * 200), 55 + (Rnd * 200), 255)
Next
Do
Cls
For i = 0 To balls - 1
'move faster towards front based on z
ballz(i) = ballz(i) - (.75 * (_Width - ballz(i)) / _Width)
'if done, reset ball x/y/z
If ballz(i) < 1 Then
ballz(i) = Rnd * 100 + 25
ballx(i) = Rnd * _Width
bally(i) = Rnd * _Height
End If
'get size from depth (decreases with depth)
ballSize(i) = (4 / ballz(i)) * 100
'drift off from center (veer away)
veerx = (ballx(i) - (_Width / 2)) * (ballSize(i) / _Width)
veery = (bally(i) - (_Height / 2)) * (ballSize(i) / _Height)
ballx(i) = ballx(i) + veerx
bally(i) = bally(i) + veery
sort(i) = i 'store this ball into array for sorting
Next
'bubble sort based on size (smallest first)
'so small ones are drawn first, big ones last
For i = 0 To balls - 2
For j = 0 To balls - 2 - i
If ballSize(sort(j)) > ballSize(sort(j + 1)) Then
Swap sort(j), sort(j + 1)
End If
Next
Next
'draw balls in the sort() array order
For i = 0 To balls - 1
'only call a draw if the ball is in screen bounds
If ballx(sort(i)) > 0 And ballx(sort(i)) < _Width Then
If bally(sort(i)) > 0 And bally(sort(i)) < _Height Then
fc ballx(sort(i)), bally(sort(i)), ballSize(sort(i)), ballc~&(sort(i)), 1
End If
End If
Next
_Limit 30
_Display
Loop Until InKey$ <> ""
Sub fc (cx, cy, radius, clr~&, grad)
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
End Sub
Updated FC SUB that draws gradient circles.
Code: (Select All)
Sub fc (cx, cy, radius, clr~&, grad)
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
End SubRE: Another small filled circe sub (not as fast as fcirc) - bplus - 09-02-2024
+1 @Dav it's certainly faster than my DrawBall version
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.
RE: Another small filled circe sub (not as fast as fcirc) - Dav - 09-02-2024
Nice collection of routines there. I didn't know there were so many of them. I've given up trying to be fastest, and will just enjoy the FC party now.
Hmm, but I do a see a couple ways to make the gradient part of mine go faster, make the sub require separate r,g,b,a parameters instead of clr~&, so _red32, _Blue32, _Green32 won't have to be called to break it up. Also, I could remove some division out of the For i = -x To x NEXT loop, and make variables for them at the top. The (red / 2), (blu /2), (grn /2) ones.
Added a twist on the ballfield thing. Spins balls around also now, follows mouse as the center point.
- Dav
Code: (Select All)
'=============
'BALLFIELD.BAS v2.0
'=============
'Shows balls spinning towards you.
'Move mouse to move swirling ball tunnel.
'Dav, SEP/2024
'Uses updated version of FC SUB discussed here:
'https://qb64phoenix.com/forum/showthread.php?tid=2989
Randomize Timer
Screen _NewImage(1000, 700, 32)
balls = 600
Dim ballx(balls), bally(balls), ballz(balls), ballSize(balls)
Dim ballc~&(balls), sort(balls) 'array for bubble sort
Dim balla(balls) 'ball angle for spin
' Init balls
For i = 0 To balls - 1
ballx(i) = Rnd * _Width 'x pos
bally(i) = Rnd * _Height 'y pos
ballz(i) = Rnd * 100 + 25 'z depth
ballc~&(i) = _RGBA(55 + (Rnd * 200), 55 + (Rnd * 200), 55 + (Rnd * 200), 255)
balla(i) = Rnd * 360
Next
Do
Cls
While _MouseInput: Wend
mx = _MouseX: my = _MouseY
For i = 0 To balls - 1
balla(i) = balla(i) + 1 * (1 / ballz(i))
'move faster towards front based on z
ballz(i) = ballz(i) - (.75 * (_Width - ballz(i)) / _Width)
'if done, reset ball data
If ballz(i) < 1 Then
ballz(i) = Rnd * 100 + 25
ballx(i) = Rnd * _Width
bally(i) = Rnd * _Height
balla(i) = Rnd * 360 ' Reset balla
End If
'get size from depth (decreases with depth)
ballSize(i) = (4 / ballz(i)) * 100
'calc spin effect
ballx(i) = mx + ((ballSize(i) / 2) * 25) * Cos(balla(i))
bally(i) = my + ((ballSize(i) / 2) * 25) * Sin(balla(i))
'drift off from center (veer away)
veerx = (ballx(i) - mx) * (ballSize(i) / _Width)
veery = (bally(i) - my) * (ballSize(i) / _Height)
ballx(i) = ballx(i) + veerx
bally(i) = bally(i) + veery
sort(i) = i 'store this ball into array for sorting
Next
'bubble sort based on size (smallest first)
'so small ones are drawn first, big ones last
For i = 0 To balls - 2
For j = 0 To balls - 2 - i
If ballSize(sort(j)) > ballSize(sort(j + 1)) Then
Swap sort(j), sort(j + 1)
End If
Next
Next
'draw balls in the sort() array order
For i = 0 To balls - 1
'only call a draw if the ball is in screen bounds
If ballx(sort(i)) > 0 And ballx(sort(i)) < _Width Then
If bally(sort(i)) > 0 And bally(sort(i)) < _Height Then
fc ballx(sort(i)), bally(sort(i)), ballSize(sort(i)), ballc~&(sort(i)), 1
End If
End If
Next
_Limit 30
_Display
Loop Until InKey$ <> ""
Sub fc (cx, cy, radius, clr~&, grad)
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
End SubRE: Another small filled circe sub (not as fast as fcirc) - bplus - 09-02-2024
Thankyou I no longer have the urge to duck.
RE: Another small filled circe sub (not as fast as fcirc) - NakedApe - 09-03-2024
Hey @Dav, I tried running your BALLFIELD above, but get Illegal Function line 96, which reads: x = SQR(r2 - y * y)
I'm on a Mac. Any idea why I can run it? Seems like the SQR function oughta work for me too, darn it... Thnx.
RE: Another small filled circe sub (not as fast as fcirc) - bplus - 09-03-2024
Any chance r2 = 0? SQR does not do negative numbers.
Try adding an exit sub if radius = 0 ?
Works fine for me in Windows. QB64pe v13.1
RE: Another small filled circe sub (not as fast as fcirc) - Dav - 09-03-2024
(09-03-2024, 12:16 AM)NakedApe Wrote: Hey @Dav, I tried running your BALLFIELD above, but get Illegal Function line 96, which reads: x = SQR(r2 - y * y)
I'm on a Mac. Any idea why I can run it? Seems like the SQR function oughta work for me too, darn it... Thnx.
Hmm, I dunno. Works for me, but I'm in Linux. Probably bplus is right about the SQR is getting a bad number some reason. Maybe you could alter the SUB to make sure SQR gets a positive, like this, just for trying sake, try this in the FC sub instead and see what happens.
- Dav
Not saying this is a solution or fix, let’s just see if it gets you past that error and see what happens next or if it will run at all…
Code: (Select All)
precalc = r2 - y * y: If precalc <= 0 Then precalc = 1
x = Sqr(precalc)RE: Another small filled circe sub (not as fast as fcirc) - NakedApe - 09-03-2024
Thanks, Dav and bplus! I subbed in the two lines above and ka-pow a colorful world sprang to life. Very cool stuff! I need to give the program a once over for sure. I'd love to understand 3D more, been trying to find a good resource to learn from.
RE: Another small filled circe sub (not as fast as fcirc) - NakedApe - 09-03-2024
(09-03-2024, 02:51 AM)NakedApe Wrote: I had fun noodling around with this over the weekend. Some lightweight 3D stuff. I threw in the wav file.
Edit: Oops, didn't close the sound file - bad form. This goes before the SYSTEM: _SndClose scanSnd
Code: (Select All)
Option _Explicit ' side scrolling starScapes
Screen _NewImage(1280, 720, 32) '
_MouseHide '
Type globe
x As Single '
y As Single
radius As Single
frameCol As _Unsigned Long
dotCol As _Unsigned Long
End Type
Dim As Long scanSnd
Dim globe(10) As globe
Dim As Integer i, j, k, bright, fCol(11), pSpot(11)
Dim As Single percent, radAdder, iOAspect(4), tempAsp(4), xScroller
Dim As _Byte grow, scan, signer, played
Dim Shared As Long starScape, starScape2
scanSnd = _SndOpen("fuzzyNoise.wav"): _SndVol scanSnd, .5
i = 1 ' it's all about the 1st globe right now
globe(i).radius = 5 ' start values
globe(i).x = _Width / 2
globe(i).y = _Height / 2
Data 1.15,1.4,1.8,2.7,5.8
For j = 0 To 4: Read iOAspect(j): Next ' store aspect data (inner Oval Aspects)
Data 60,90,110,130,160,181,190,182,160,137,100,70
For j = 0 To 11: Read fCol(j): Next ' store globe section fill greys
Data -122,-102,-82,-57,-35,-10,13,35,60,81,102,123
For j = 0 To 11: Read pSpot(j): Next ' store paint locations
grow = -1: scan = 0 ' flags
radAdder = .75: signer = 1 ' radius adder value & sign for scan
setStars ' create backdrop, software image
restart:
For j = 0 To 4: tempAsp(j) = iOAspect(j): Next ' initial aspects for inner ovals
Do ' MAIN
Cls
_Limit 120
xScroller = xScroller - .2 ' scroll stars to the left
_PutImage (0 + xScroller, 0), starScape
_PutImage (1281 + xScroller, 0), starScape2
If xScroller < -1280 Then xScroller = 0
radAdder = globe(i).radius * .0075 * Sgn(radAdder) ' rate of change is a factor of size
percent = globe(i).radius / 130 ' adjust paint points by radius / orig size
bright = globe(i).radius * 1.7 + 150 ' brightness = function of size
If bright > 254 Then bright = 255 ' mind the max
globe(i).frameCol = _RGB32(150) ' grey frame
globe(i).dotCol = _RGB32(255, 255, 0, bright) ' variable brightness for paint dot locs
Print "arrows to steer"
Print "spacebar to stop/start"
Print "<s> to scan"
Print "<esc> to exit" ' user inputs & controls
If _KeyDown(19200) Then globe(i).x = globe(i).x - 2.5 + globe(i).radius / 200 ' steers more when it's small, less when big
If _KeyDown(19712) Then globe(i).x = globe(i).x + 2.5 - globe(i).radius / 200
If _KeyDown(18432) Then globe(i).y = globe(i).y - 2 + globe(i).radius / 200
If _KeyDown(20480) Then globe(i).y = globe(i).y + 2 - globe(i).radius / 200
If _KeyHit = 32 Then ' space bar stops / starts movement
If grow <> 0 Then
grow = 0
_KeyClear
ElseIf grow = 0 Then grow = -1
_KeyClear
End If
End If
If grow Then ' size control
globe(i).radius = globe(i).radius + radAdder
If globe(i).radius > 250 Then radAdder = -radAdder
If globe(i).radius < 1 Then radAdder = -radAdder
End If
If _KeyDown(115) Or _KeyDown(83) Then scan = -1: _KeyClear ' scan = quick wiggle, show paint spots, move/color globe sections
If scan Then
j = 0
Do ' scan control
k = k + 1
If Not played And scanSnd > 0 Then _SndPlay scanSnd: played = -1
If k = 160 Or k = 320 Or k = 480 Then signer = -signer
globe(i).x = globe(i).x + .25 * signer
tempAsp(j) = tempAsp(j) + .08 ' was .05
j = j + 1
If tempAsp(j) > 5.5 Then tempAsp(j) = 1.15
Loop Until j = UBound(tempAsp)
If k > 600 Then
scan = 0: k = 0 ' scan resets itself
If _SndPlaying(scanSnd) Then _SndStop scanSnd: played = 0
GoTo restart
End If
End If ' -----------------------------------------------------------------------------
' draw globe
If scan And globe(i).radius > 10 Then ' if scan, paint inside of globe 1st
Circle (globe(i).x, globe(i).y), globe(i).radius - 3, _RGB32(255, 10, 0), , , 1
Paint (globe(i).x, globe(i).y), _RGB32(200, 100, 200, bright), _RGB32(255, 10, 0)
End If
Circle (globe(i).x, globe(i).y), globe(i).radius, globe(i).frameCol, , , 1 ' draw main circle
For j = 0 To 4
Circle (globe(i).x, globe(i).y), globe(i).radius, globe(i).frameCol, , , tempAsp(j) ' draw inside ovals
Next
Line (globe(i).x, globe(i).y - globe(i).radius)-(globe(i).x, globe(i).y + globe(i).radius), globe(i).frameCol ' middle line
If globe(i).radius > 8 Then ' was 10 paint globe sections
For j = 0 To 11
Paint (globe(i).x + (percent * pSpot(j)), globe(i).y), _RGB32(fCol(j), fCol(j), fCol(j), bright), globe(i).frameCol '
Next
If scan Then
For j = 0 To 11 ' draw paint spots during scan
If globe(i).radius < 30 Then ' was 80
PSet (globe(i).x + (percent * pSpot(j)), globe(i).y), globe(i).dotCol ' paint locs based on % of orig 130 radius @ x = 200
Else Circle (globe(i).x + (percent * pSpot(j)), globe(i).y), globe(i).radius / 102, globe(i).dotCol ' draw dots more to scale, sorta
End If
Next
End If
End If
_Display
Loop Until _KeyDown(27)
System
' ---------------------------------------------
Sub setStars () ' starscape backdrop
Dim c As Integer
Dim As Long virtual
virtual = _NewImage(1280, 720, 32) '
_Dest virtual
c = 0
Do: c = c + 1
PSet ((Int(Rnd * _Width)), Int(Rnd * _Height)), _RGB32(190 + Rnd * 20) ' whites
Loop Until c = 2000
c = 0
Do: c = c + 1
PSet ((Int(Rnd * _Width)), Int(Rnd * _Height)), _RGB32(100 + Rnd * 22) ' grays
Loop Until c = 6000 '
starScape = _CopyImage(virtual, 32) ' software image
starScape2 = _CopyImage(virtual, 32) ' another copy to allow sideways scrolling
_Dest 0: _FreeImage virtual
End Sub