+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: SMcNeill (https://staging.qb64phoenix.com/forumdisplay.php?fid=29)
+---- Thread: CircleFiller (/showthread.php?tid=146)
CircleFiller - SMcNeill - 04-23-2022
Not to be confused with CircleFill, this is CircleFiller -- this fills an area with circles!
Code: (Select All)
Screen _NewImage(640, 480, 32)
Const Red = &HFFFF0000
Line (200, 200)-(400, 400), Red, B
CircleFiller 300, 300, 10, Red
Sleep
Cls , 0
Circle (320, 240), 100, Red
CircleFiller 320, 240, 10, Red
Sub CircleFiller (x, y, r, k As _Unsigned Long)
If CircleFillValid(x, y, r, k) Then
CircleFill x, y, r, k
CircleFiller x - r - r - 1, y, r, k
CircleFiller x + r + r + 1, y, r, k
CircleFiller x, y - r - r - 1, r, k
CircleFiller x, y + r + r + 1, r, k
End If
End Sub
Sub CircleFill (cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long)
Dim a As Long, b As Long
Dim x As Long, y As Long
Dim xx As Long, yy As Long
Dim sx As Long, sy As Long
Dim e As Long
Dim rx As Integer, ry As Integer
rx = r: ry = r
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
Do While sx >= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
If y <> 0 Then Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
If (e + e + xx) > 0 Then
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
End If
Loop
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
Do While sx <= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
Do
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
Loop Until (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
Loop
End Sub
Function CircleFillValid (cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long)
Dim a As Long, b As Long
Dim x As Long, y As Long
Dim xx As Long, yy As Long
Dim sx As Long, sy As Long
Dim e As Long
Dim rx As Integer, ry As Integer
rx = r: ry = r
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
Do While sx >= sy
For i = cx - x To cx + x
If Point(i, cy - y) = c Then Exit Function
Next
'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
If y <> 0 Then
'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
For i = cx - x To cx + x
If Point(i, cy + y) = c Then Exit Function
Next
End If
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
If (e + e + xx) > 0 Then
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
End If
Loop
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
Do While sx <= sy
'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
For i = cx - x To cx + x
If Point(i, cy - y) = c Then Exit Function
If Point(i, cy + y) = c Then Exit Function
Next
Do
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
Loop Until (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
Loop
CircleFillValid = -1
End FunctionThis can also be easily modified to become an EllipseFiller (as I'm actually using the EllipseFill routines for this and modified them so rx/ry are both passed by r instead...), if case anyone wants a nice EllipseFiller utility.
And what's the purpose of this, you ask?
I was thinking of plugging it into my little hourglass program so it'd drop balls instead of sand, but then I figured, "Nah... I'm too lazy. This is good enough. Somebody else can go back and insert the routines into the program if they want to now. I'm going to dinner and a movie with the wife..."
