QB64 Phoenix Edition › QB64 Rising › Code and Stuff › Utilities v
Mod'ing a classic- partial circle fill

Threaded Mode
Mod'ing a classic- partial circle fill
OldMoses Offline
Senior Member
****
Posts: 263
Threads: 14
Joined: Apr 2022
Reputation: 23
#1
01-17-2023, 12:25 AM
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%
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Find
Reply
bplus Offline
Mini-Mod
***
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation: 134
#2
Thumbs Up  01-17-2023, 03:19 AM (This post was last modified: 01-17-2023, 03:38 AM by bplus.)
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%

   
b = b + ...
Find
Reply
OldMoses Offline
Senior Member
****
Posts: 263
Threads: 14
Joined: Apr 2022
Reputation: 23
#3
01-17-2023, 06:03 AM
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
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Find
Reply
bplus Offline
Mini-Mod
***
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation: 134
#4
01-17-2023, 03:33 PM
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!
b = b + ...
Find
Reply
bplus Offline
Mini-Mod
***
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation: 134
#5
01-17-2023, 07:00 PM (This post was last modified: 01-17-2023, 07:04 PM by bplus.)
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. ;-))
b = b + ...
Find
Reply
SMcNeill Offline
Super Moderator
******
Posts: 1,507
Threads: 160
Joined: Apr 2022
Reputation: 116
#6
01-17-2023, 07:06 PM
Steve's way of doing this?  Make a newimage the size of your box.  Draw the circle in it.  Putimage that to the screen.  Smile
Website Find
Reply
bplus Offline
Mini-Mod
***
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation: 134
#7
01-17-2023, 07:11 PM (This post was last modified: 01-17-2023, 07:14 PM by bplus.)
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!
b = b + ...
Find
Reply




Users browsing this thread: 3 Guest(s)