+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Utilities (https://staging.qb64phoenix.com/forumdisplay.php?fid=8)
+---- Thread: Mod'ing a classic- partial circle fill (/showthread.php?tid=1403)
Mod'ing a classic- partial circle fill - OldMoses - 01-17-2023
Something that I've needed for one of my projects for a long time. A modification of the circle fill algorithm that restricts the draw to the limits of a bounding box. I'm not sure why it took me so long to get around to this, but here it is, in case someone can make use of it or are inspired to wow us with a better solution.
Left button click to place the center of the box, mousewheel to change the box size.
Code: (Select All)
'OldMoses' mod of Steve's circle fill
'drawing only those portions that fit the bounding box
'e% = 128
sz% = 50
ls% = 300
rs% = 400
t% = 100
b% = 200
SCREEN _NEWIMAGE(1024, 512, 32)
DO
WHILE _MOUSEINPUT
osz% = wsz%
wsz% = SGN(_MOUSEWHEEL) * 3
IF osz% <> sz% THEN
ls% = ls% - wsz%: rs% = rs% + wsz%
t% = t% - wsz%: b% = b% + wsz%
sz% = sz% + wsz%
END IF
WEND
IF _MOUSEBUTTON(1) THEN
ls% = _MOUSEX - sz%: rs% = _MOUSEX + sz%
t% = _MOUSEY - sz%: b% = _MOUSEY + sz%
END IF
CLS
'LINE (512 - e%, 256 - e%)-(512 + e%, 256 + e%)
'LINE (512 + e%, 256 - e%)-(512 - e%, 256 + e%)
LINE (ls%, t%)-(rs%, b%), , B ' Bounding box
'CIRCLE (512, 256), 128, &H7FFF0000
FCirc 512, 256, 128, &H7FFF0000 ' Steve's unmodified circle fill
FCircPart 512, 256, 128, &H7F00FF00, ls%, rs%, t%, b% ' modified partial circle fill
_LIMIT 30
_DISPLAY
LOOP UNTIL _KEYDOWN(27)
END
SUB FCircPart (CX AS LONG, CY AS LONG, RR AS LONG, C AS _UNSIGNED LONG, lt AS LONG, rt AS LONG, t AS LONG, b AS LONG) 'modified circle fill
IF rt < CX - RR OR lt > CX + RR OR t > CY + RR OR b < CY - RR THEN EXIT SUB 'leave if box not intersecting circle
DIM AS LONG R, RError, X, Y
R = ABS(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB ' zero radius is point, not circle
IF CY >= t AND CY <= b THEN LINE (MinOf&(CX - X, lt), CY)-(MaxOf&(CX + X, rt), CY), C, BF 'draw equatorial line if applicable
WHILE X > Y
RError = RError + Y * 2 + 1 '
IF RError >= 0 THEN
IF X <> Y + 1 THEN
IF CY - X >= t AND CY - X <= b AND CX - Y <= rt AND CX + Y >= lt THEN
LINE (MinOf&(CX - Y, lt), CY - X)-(MaxOf&(CX + Y, rt), CY - X), C, BF ' draw lines for south polar latitudes
END IF
IF CY + X <= b AND CY + X >= t AND CX - Y <= rt AND CX + Y >= lt THEN
LINE (MinOf&(CX - Y, lt), CY + X)-(MaxOf&(CX + Y, rt), CY + X), C, BF ' draw lines for north polar latitudes
END IF
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
IF CY - Y >= t AND CY - Y <= b AND CX - X <= rt AND CX + X >= lt THEN
LINE (MinOf&(CX - X, lt), CY - Y)-(MaxOf&(CX + X, rt), CY - Y), C, BF ' draw lines north equatorial latitudes
END IF
IF CY + Y <= b AND CY + Y >= t AND CX - X <= rt AND CX + X >= lt THEN
LINE (MinOf&(CX - X, lt), CY + Y)-(MaxOf&(CX + X, rt), CY + Y), C, BF ' draw lines south equatorial latitudes
END IF
WEND
END SUB 'FCircPart
SUB FCirc (CX AS LONG, CY AS LONG, RR AS LONG, C AS _UNSIGNED LONG) 'Steve's circle fill unmodified
DIM AS LONG R, RError, X, Y
R = ABS(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB ' zero radius is point, not circle
LINE (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
WHILE X > Y
RError = RError + Y * 2 + 1 '
IF RError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw lines for south polar latitudes
LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw lines for north polar latitudes
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw lines north equatorial latitudes
LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw lines south equatorial latitudes
WEND
END SUB 'FCirc
FUNCTION MaxOf& (value AS LONG, max AS LONG)
MaxOf& = -value * (value <= max) - max * (value > max)
END FUNCTION 'MaxOf%
FUNCTION MinOf& (value AS INTEGER, minimum AS INTEGER)
MinOf& = -value * (value >= minimum) - minimum * (value < minimum)
END FUNCTION 'MinOf%RE: Mod'ing a classic- partial circle fill - bplus - 01-17-2023
I liked this routine so much I did 3 more Demos for the Old Moses feature routine.
The first just tests rectangles instead of square:
Code: (Select All)
_Title "Demo 2 Circle Part with rectangle"
'OldMoses' mod of Steve's circle fill
'drawing only those portions that fit the bounding box
'e% = 128
xsz% = 200
ysz% = 50
ls% = 200
rs% = 600
t% = 100
b% = 200
Screen _NewImage(1024, 512, 32)
Do
While _MouseInput
osz% = wsz%
wsz% = Sgn(_MouseWheel) * 3
If (t% - wsz%) < (b% + wsz%) Then
If osz% <> xsz% Then
ls% = ls% - wsz%: rs% = rs% + wsz%
t% = t% - wsz%: b% = b% + wsz%
xsz% = xsz% + wsz%
ysz% = ysz% + wsz%
End If
End If
Wend
If _MouseButton(1) Then
ls% = _MouseX - xsz%: rs% = _MouseX + xsz%
t% = _MouseY - ysz%: b% = _MouseY + ysz%
End If
Cls
'LINE (512 - e%, 256 - e%)-(512 + e%, 256 + e%)
'LINE (512 + e%, 256 - e%)-(512 - e%, 256 + e%)
Line (ls%, t%)-(rs%, b%), , B ' Bounding box
'CIRCLE (512, 256), 128, &H7FFF0000
FCirc 512, 256, 128, &H7FFF0000 ' Steve's unmodified circle fill
FCircPart 512, 256, 128, &H7F00FF00, ls%, rs%, t%, b% ' modified partial circle fill
_Limit 30
_Display
Loop Until _KeyDown(27)
End
Sub FCircPart (CX As Long, CY As Long, RR As Long, C As _Unsigned Long, lt As Long, rt As Long, t As Long, b As Long) 'modified circle fill
If rt < CX - RR Or lt > CX + RR Or t > CY + RR Or b < CY - RR Then Exit Sub 'leave if box not intersecting circle
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
If CY >= t And CY <= b Then Line (MinOf&(CX - X, lt), CY)-(MaxOf&(CX + X, rt), CY), C, BF 'draw equatorial line if applicable
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
If CY - X >= t And CY - X <= b And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY - X)-(MaxOf&(CX + Y, rt), CY - X), C, BF ' draw lines for south polar latitudes
End If
If CY + X <= b And CY + X >= t And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY + X)-(MaxOf&(CX + Y, rt), CY + X), C, BF ' draw lines for north polar latitudes
End If
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
If CY - Y >= t And CY - Y <= b And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY - Y)-(MaxOf&(CX + X, rt), CY - Y), C, BF ' draw lines north equatorial latitudes
End If
If CY + Y <= b And CY + Y >= t And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY + Y)-(MaxOf&(CX + X, rt), CY + Y), C, BF ' draw lines south equatorial latitudes
End If
Wend
End Sub 'FCircPart
Sub FCirc (CX As Long, CY As Long, RR As Long, C As _Unsigned Long) 'Steve's circle fill unmodified
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
Line (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw lines for south polar latitudes
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw lines for north polar latitudes
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw lines north equatorial latitudes
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw lines south equatorial latitudes
Wend
End Sub 'FCirc
Function MaxOf& (value As Long, max As Long)
MaxOf& = -value * (value <= max) - max * (value > max)
End Function 'MaxOf%
Function MinOf& (value As Integer, minimum As Integer)
MinOf& = -value * (value >= minimum) - minimum * (value < minimum)
End Function 'MinOf%2nd Demo the mouse is the center of circle moved around screen, use wheel for expanding it's radius:
Code: (Select All)
_Title "Demo 3 Circle Part with Circle" ' b+ mod Old Moses 2023-01-16
'OldMoses' mod of Steve's circle fill
'drawing only those portions that fit the bounding box
rsz% = 50
ls% = 412
rs% = 512
t% = 100
b% = 300
Screen _NewImage(1024, 512, 32)
Do
While _MouseInput
osz% = wsz%
wsz% = Sgn(_MouseWheel) * 3
If osz% <> rsz% Then
rsz% = rsz% + wsz%
End If
Wend
mx = _MouseX
my = _MouseY
Cls
Line (ls%, t%)-(rs%, b%), &HFFFFFFFF, BF
FCirc mx, my, rsz%, &HFFFF0000 ' Bounding box
'CIRCLE (512, 256), 128, &H7FFF0000
'FCirc 512, 256, 128, &H7FFF0000 ' Steve's unmodified circle fill
FCircPart mx, my, rsz%, &H7F00FF00, ls%, rs%, t%, b% ' modified partial circle fill
_Limit 30
_Display
Loop Until _KeyDown(27)
End
Sub FCircPart (CX As Long, CY As Long, RR As Long, C As _Unsigned Long, lt As Long, rt As Long, t As Long, b As Long) 'modified circle fill
If rt < CX - RR Or lt > CX + RR Or t > CY + RR Or b < CY - RR Then Exit Sub 'leave if box not intersecting circle
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
If CY >= t And CY <= b Then Line (MinOf&(CX - X, lt), CY)-(MaxOf&(CX + X, rt), CY), C, BF 'draw equatorial line if applicable
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
If CY - X >= t And CY - X <= b And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY - X)-(MaxOf&(CX + Y, rt), CY - X), C, BF ' draw lines for south polar latitudes
End If
If CY + X <= b And CY + X >= t And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY + X)-(MaxOf&(CX + Y, rt), CY + X), C, BF ' draw lines for north polar latitudes
End If
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
If CY - Y >= t And CY - Y <= b And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY - Y)-(MaxOf&(CX + X, rt), CY - Y), C, BF ' draw lines north equatorial latitudes
End If
If CY + Y <= b And CY + Y >= t And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY + Y)-(MaxOf&(CX + X, rt), CY + Y), C, BF ' draw lines south equatorial latitudes
End If
Wend
End Sub 'FCircPart
Sub FCirc (CX As Long, CY As Long, RR As Long, C As _Unsigned Long) 'Steve's circle fill unmodified
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
Line (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw lines for south polar latitudes
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw lines for north polar latitudes
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw lines north equatorial latitudes
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw lines south equatorial latitudes
Wend
End Sub 'FCirc
Function MaxOf& (value As Long, max As Long)
MaxOf& = -value * (value <= max) - max * (value > max)
End Function 'MaxOf%
Function MinOf& (value As Integer, minimum As Integer)
MinOf& = -value * (value >= minimum) - minimum * (value < minimum)
End Function 'MinOf%And now for the fun! Demo 4 is Bouncing balls that can only be seen in rectangle glass panes of different color!
Actually they look more like search lights hitting different colored panes.
Code: (Select All)
_Title "Demo 4 Circle Part Random" ' b+ mod Old Moses 2023-01-16
'OldMoses' mod of Steve's circle fill
'drawing only those portions that fit the bounding box
Randomize Timer
Type bx
As Single x, y, w, h
As _Unsigned Long c
End Type
Type circ
As Single x, y, dx, dy, r
As _Unsigned Long c
End Type
Screen _NewImage(1024, 512, 32)
Dim b(1 To 200) As bx
For i = 1 To 200
b(i).w = Rnd * 100 + 10
b(i).x = Rnd * (_Width - b(i).w)
b(i).h = Rnd * 100 + 10
b(i).y = Rnd * (_Height - b(i).h)
b(i).c = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 240 + 15)
Next
Dim c(1 To 50) As circ
For i = 1 To 50
c(i).r = Rnd * 50 + 10
c(i).x = Rnd * (_Width - 2 * c(i).r) + c(i).r
c(i).y = Rnd * (_Height - 2 * c(i).r) + c(i).r
c(i).dx = Rnd * 5
If Rnd < .5 Then c(i).dx = -c(i).dx
c(i).dy = Rnd * 5
If Rnd < .5 Then c(i).dy = -c(i).dy
Next
Do
Cls
For j = 1 To 50
For i = 1 To 200
FCircPart c(j).x, c(j).y, c(j).r, b(i).c, b(i).x, b(i).x + b(i).w, b(i).y, b(i).y + b(i).h ' modified partial circle fill
Next
c(j).x = c(j).x + c(j).dx
If c(j).x - c(j).r < 0 Then c(j).dx = -c(j).dx: c(j).x = c(j).r
If c(j).x + c(j).r > _Width Then c(j).dx = -c(j).dx: c(j).x = _Width - c(j).r
c(j).y = c(j).y + c(j).dy
If c(j).y - c(j).r < 0 Then c(j).dy = -c(j).dy: c(j).y = c(j).r
If c(j).y + c(j).r > _Height Then c(j).dy = -c(j).dy: c(j).y = _Height - c(j).r
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
End
Sub FCircPart (CX As Long, CY As Long, RR As Long, C As _Unsigned Long, lt As Long, rt As Long, t As Long, b As Long) 'modified circle fill
If rt < CX - RR Or lt > CX + RR Or t > CY + RR Or b < CY - RR Then Exit Sub 'leave if box not intersecting circle
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
If CY >= t And CY <= b Then Line (MinOf&(CX - X, lt), CY)-(MaxOf&(CX + X, rt), CY), C, BF 'draw equatorial line if applicable
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
If CY - X >= t And CY - X <= b And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY - X)-(MaxOf&(CX + Y, rt), CY - X), C, BF ' draw lines for south polar latitudes
End If
If CY + X <= b And CY + X >= t And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY + X)-(MaxOf&(CX + Y, rt), CY + X), C, BF ' draw lines for north polar latitudes
End If
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
If CY - Y >= t And CY - Y <= b And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY - Y)-(MaxOf&(CX + X, rt), CY - Y), C, BF ' draw lines north equatorial latitudes
End If
If CY + Y <= b And CY + Y >= t And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY + Y)-(MaxOf&(CX + X, rt), CY + Y), C, BF ' draw lines south equatorial latitudes
End If
Wend
End Sub 'FCircPart
Sub FCirc (CX As Long, CY As Long, RR As Long, C As _Unsigned Long) 'Steve's circle fill unmodified
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
Line (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw lines for south polar latitudes
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw lines for north polar latitudes
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw lines north equatorial latitudes
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw lines south equatorial latitudes
Wend
End Sub 'FCirc
Function MaxOf& (value As Long, max As Long)
MaxOf& = -value * (value <= max) - max * (value > max)
End Function 'MaxOf%
Function MinOf& (value As Integer, minimum As Integer)
MinOf& = -value * (value >= minimum) - minimum * (value < minimum)
End Function 'MinOf%RE: Mod'ing a classic- partial circle fill - OldMoses - 01-17-2023
Demo 4 is one of those examples of code that makes me marvel at how fast QB64 really is. That is a really cool effect. +1
RE: Mod'ing a classic- partial circle fill - bplus - 01-17-2023
Thanks Old Moses
Actually, I am reading over the code of Demo #4 and wondering, I gave both boxes and circles a color in Type, but did not use color for circle which actually makes more sense so here is Demo #5 with that switch:
Code: (Select All)
_Title "Demo 5 Circle Part Random Circle color" ' b+ mod Old Moses 2023-01-17
'OldMoses' mod of Steve's circle fill
'drawing only those portions that fit the bounding box
Randomize Timer
Type bx
As Single x, y, w, h
As _Unsigned Long c
End Type
Type circ
As Single x, y, dx, dy, r
As _Unsigned Long c
End Type
Screen _NewImage(1024, 512, 32)
Dim b(1 To 200) As bx
For i = 1 To 200
b(i).w = Rnd * 100 + 10
b(i).x = Rnd * (_Width - b(i).w)
b(i).h = Rnd * 100 + 10
b(i).y = Rnd * (_Height - b(i).h)
b(i).c = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 240 + 15)
Next
Dim c(1 To 50) As circ
For i = 1 To 50
c(i).r = Rnd * 50 + 10
c(i).x = Rnd * (_Width - 2 * c(i).r) + c(i).r
c(i).y = Rnd * (_Height - 2 * c(i).r) + c(i).r
c(i).dx = Rnd * 5
If Rnd < .5 Then c(i).dx = -c(i).dx
c(i).dy = Rnd * 5
If Rnd < .5 Then c(i).dy = -c(i).dy
c(i).c = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 240 + 15)
Next
Do
Cls
For j = 1 To 50
For i = 1 To 200
FCircPart c(j).x, c(j).y, c(j).r, c(j).c, b(i).x, b(i).x + b(i).w, b(i).y, b(i).y + b(i).h ' modified partial circle fill
Next
c(j).x = c(j).x + c(j).dx
If c(j).x - c(j).r < 0 Then c(j).dx = -c(j).dx: c(j).x = c(j).r
If c(j).x + c(j).r > _Width Then c(j).dx = -c(j).dx: c(j).x = _Width - c(j).r
c(j).y = c(j).y + c(j).dy
If c(j).y - c(j).r < 0 Then c(j).dy = -c(j).dy: c(j).y = c(j).r
If c(j).y + c(j).r > _Height Then c(j).dy = -c(j).dy: c(j).y = _Height - c(j).r
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
End
Sub FCircPart (CX As Long, CY As Long, RR As Long, C As _Unsigned Long, lt As Long, rt As Long, t As Long, b As Long) 'modified circle fill
If rt < CX - RR Or lt > CX + RR Or t > CY + RR Or b < CY - RR Then Exit Sub 'leave if box not intersecting circle
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
If CY >= t And CY <= b Then Line (MinOf&(CX - X, lt), CY)-(MaxOf&(CX + X, rt), CY), C, BF 'draw equatorial line if applicable
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
If CY - X >= t And CY - X <= b And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY - X)-(MaxOf&(CX + Y, rt), CY - X), C, BF ' draw lines for south polar latitudes
End If
If CY + X <= b And CY + X >= t And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY + X)-(MaxOf&(CX + Y, rt), CY + X), C, BF ' draw lines for north polar latitudes
End If
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
If CY - Y >= t And CY - Y <= b And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY - Y)-(MaxOf&(CX + X, rt), CY - Y), C, BF ' draw lines north equatorial latitudes
End If
If CY + Y <= b And CY + Y >= t And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY + Y)-(MaxOf&(CX + X, rt), CY + Y), C, BF ' draw lines south equatorial latitudes
End If
Wend
End Sub 'FCircPart
Sub FCirc (CX As Long, CY As Long, RR As Long, C As _Unsigned Long) 'Steve's circle fill unmodified
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
Line (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw lines for south polar latitudes
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw lines for north polar latitudes
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw lines north equatorial latitudes
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw lines south equatorial latitudes
Wend
End Sub 'FCirc
Function MaxOf& (value As Long, max As Long)
MaxOf& = -value * (value <= max) - max * (value > max)
End Function 'MaxOf%
Function MinOf& (value As Integer, minimum As Integer)
MinOf& = -value * (value >= minimum) - minimum * (value < minimum)
End Function 'MinOf%Just got an idea for something really fresh!
RE: Mod'ing a classic- partial circle fill - bplus - 01-17-2023
BallParts!
Code: (Select All)
_Title "Demo 6 Circle Part Random Circle color" ' b+ mod Old Moses 2023-01-17
'OldMoses' mod of Steve's circle fill
'drawing only those portions that fit the bounding box
Randomize Timer
Type bx
As Single x, y, w, h
As _Unsigned Long c
End Type
Type circ
As Single x, y, dx, dy, r
As _Unsigned Long c
End Type
Dim Shared nBoxes, nCircs
nBoxes = 70
nCircs = 50
Dim Shared b(1 To nBoxes) As bx
Dim Shared c(1 To nCircs) As circ
_Title "Spacebar for different view..."
Screen _NewImage(1024, 512, 32)
newStuff
Do
Cls
If _KeyHit = 32 Then newStuff
For j = 1 To nCircs
For i = 1 To nBoxes
drawBallPart c(j).x, c(j).y, c(j).r, c(j).c, b(i).x, b(i).x + b(i).w, b(i).y, b(i).y + b(i).h ' modified partial circle fill
Next
c(j).x = c(j).x + c(j).dx
If c(j).x - c(j).r < 0 Then c(j).dx = -c(j).dx: c(j).x = c(j).r
If c(j).x + c(j).r > _Width Then c(j).dx = -c(j).dx: c(j).x = _Width - c(j).r
c(j).y = c(j).y + c(j).dy
If c(j).y - c(j).r < 0 Then c(j).dy = -c(j).dy: c(j).y = c(j).r
If c(j).y + c(j).r > _Height Then c(j).dy = -c(j).dy: c(j).y = _Height - c(j).r
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
Sub newStuff
For i = 1 To nBoxes
b(i).w = Rnd * 100 + 10
b(i).x = Rnd * (_Width - b(i).w)
b(i).h = Rnd * 100 + 10
b(i).y = Rnd * (_Height - b(i).h)
b(i).c = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 240 + 15)
Next
For i = 1 To nCircs
c(i).r = Rnd * 50 + 10
c(i).x = Rnd * (_Width - 2 * c(i).r) + c(i).r
c(i).y = Rnd * (_Height - 2 * c(i).r) + c(i).r
c(i).dx = Rnd * 5
If Rnd < .5 Then c(i).dx = -c(i).dx
c(i).dy = Rnd * 5
If Rnd < .5 Then c(i).dy = -c(i).dy
c(i).c = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
Next
End Sub
Sub drawBallPart (x, y, r, c As _Unsigned Long, left, right, top, bottom)
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 ;-))
FCircPart x, y, rr, _RGB32(rred * f, grn * f, blu * f), left, right, top, bottom
Next
End Sub
Sub FCircPart (CX As Long, CY As Long, RR As Long, C As _Unsigned Long, lt As Long, rt As Long, t As Long, b As Long) 'modified circle fill
If rt < CX - RR Or lt > CX + RR Or t > CY + RR Or b < CY - RR Then Exit Sub 'leave if box not intersecting circle
Dim As Long R, RError, X, Y
R = Abs(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
If R = 0 Then PSet (CX, CY), C: Exit Sub ' zero radius is point, not circle
If CY >= t And CY <= b Then Line (MinOf&(CX - X, lt), CY)-(MaxOf&(CX + X, rt), CY), C, BF 'draw equatorial line if applicable
While X > Y
RError = RError + Y * 2 + 1 '
If RError >= 0 Then
If X <> Y + 1 Then
If CY - X >= t And CY - X <= b And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY - X)-(MaxOf&(CX + Y, rt), CY - X), C, BF ' draw lines for south polar latitudes
End If
If CY + X <= b And CY + X >= t And CX - Y <= rt And CX + Y >= lt Then
Line (MinOf&(CX - Y, lt), CY + X)-(MaxOf&(CX + Y, rt), CY + X), C, BF ' draw lines for north polar latitudes
End If
End If
X = X - 1
RError = RError - X * 2
End If
Y = Y + 1
If CY - Y >= t And CY - Y <= b And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY - Y)-(MaxOf&(CX + X, rt), CY - Y), C, BF ' draw lines north equatorial latitudes
End If
If CY + Y <= b And CY + Y >= t And CX - X <= rt And CX + X >= lt Then
Line (MinOf&(CX - X, lt), CY + Y)-(MaxOf&(CX + X, rt), CY + Y), C, BF ' draw lines south equatorial latitudes
End If
Wend
End Sub 'FCircPart
Function MaxOf& (value As Long, max As Long)
MaxOf& = -value * (value <= max) - max * (value > max)
End Function 'MaxOf%
Function MinOf& (value As Integer, minimum As Integer)
MinOf& = -value * (value >= minimum) - minimum * (value < minimum)
End Function 'MinOf%OK I look at this and realize, there is a much easier way to do this. I was wondering way back before doing Demos...
Steve will tell us. ;-))
RE: Mod'ing a classic- partial circle fill - SMcNeill - 01-17-2023
Steve's way of doing this? Make a newimage the size of your box. Draw the circle in it. Putimage that to the screen.
RE: Mod'ing a classic- partial circle fill - bplus - 01-17-2023
Yes a couple of ways for last, bouncing balls
1. Just make a screen with all the rectangle holes cut out and lay over the bouncing balls. Could do this even if you want to move the cut holes around as well!
2. _NewImage the screen draw all the balls and _putImage project all the boxes with ball parts onto the display screen.
BTW I sure like OldMoses Sin improvement for ball drawing!