Mod'ing a classic- partial circle fill

[bplus]

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!