CircleFiller

[SMcNeill]

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 Function

This 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..."