09-01-2024, 08:31 AM (This post was last modified: 09-01-2024, 08:34 AM by bplus.)
+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
09-02-2024, 05:41 PM (This post was last modified: 09-02-2024, 06:02 PM by Dav.)
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
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 Sub
+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
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 Sub
I am adding $Checking: Off | On to these routines.
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
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 Sub
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.
09-03-2024, 01:04 AM (This post was last modified: 09-03-2024, 02:03 AM by Dav.)
(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)
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.
09-03-2024, 03:21 AM (This post was last modified: 09-03-2024, 03:35 AM by NakedApe.)
(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 AsSingle'
y AsSingle
radius AsSingle
frameCol As_UnsignedLong
dotCol As_UnsignedLong End Type DimAsLong scanSnd Dim globe(10) As globe DimAsInteger i, j, k, bright, fCol(11), pSpot(11) DimAsSingle percent, radAdder, iOAspect(4), tempAsp(4), xScroller DimAs_Byte grow, scan, signer, played DimSharedAsLong 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 Data1.15,1.4,1.8,2.7,5.8 For j = 0To4: Read iOAspect(j): Next' store aspect data (inner Oval Aspects) Data60,90,110,130,160,181,190,182,160,137,100,70 For j = 0To11: Read fCol(j): Next' store globe section fill greys Data-122,-102,-82,-57,-35,-10,13,35,60,81,102,123 For j = 0To11: 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 = 0To4: tempAsp(j) = iOAspect(j): Next' initial aspects for inner ovals Do' MAIN Cls _Limit120
xScroller = xScroller - .2' scroll stars to the left _PutImage (0 + xScroller, 0), starScape _PutImage (1281 + xScroller, 0), starScape2 If xScroller < -1280Then 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 > 254Then 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 = 32Then' space bar stops / starts movement If grow <> 0Then
grow = 0 _KeyClear ElseIf grow = 0Then grow = -1 _KeyClear End If End If If grow Then' size control
globe(i).radius = globe(i).radius + radAdder If globe(i).radius > 250Then radAdder = -radAdder If globe(i).radius < 1Then 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 IfNot played And scanSnd > 0Then_SndPlay scanSnd: played = -1 If k = 160Or k = 320Or k = 480Then signer = -signer
globe(i).x = globe(i).x + .25 * signer
tempAsp(j) = tempAsp(j) + .08' was .05
j = j + 1 If tempAsp(j) > 5.5Then tempAsp(j) = 1.15 Loop Until j = UBound(tempAsp) If k > 600Then
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 > 10Then' 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 = 0To4 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 > 8Then' was 10 paint globe sections For j = 0To11 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 = 0To11' draw paint spots during scan If globe(i).radius < 30Then' 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 ElseCircle (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 ' --------------------------------------------- SubsetStars () ' starscape backdrop Dim c AsInteger DimAsLong 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 _Dest0: _FreeImage virtual End Sub
