flood fill ?

[madscijr]

I added the EnableBlend% parameter to disable the blend check and it's twice as fast. 
@Petr's fill (paint2) was fastest after native paint, though I still don't understand what he's doing.
Here's a test of all of them:

Code: (Select All)

' Paint vs Fill speed comparison by Steve, v2 by madscijr
' https://qb64phoenix.com/forum/showthread.php?tid=3631&pid=33725#pid33725

Screen _NewImage(800, 800, 32)
Circle (400, 400), 400, _RGB32(255, 255, 255) 'white circle
TestNum% = 0
TextCols% = (_Width / _FontWidth) - 1

NumTests% = 5

TestNum% = TestNum% + 1
t0# = Timer

For i = 1 To 100
    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
    Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint)                   "
    Locate 2, 1: Print "Fill " + Right$("   " + _ToStr$(i), 3) + " of 100  "
    Paint (400, 400), _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _RGB32(255, 255, 255)
Next i

TestNum% = TestNum% + 1
t1# = Timer

For i = 1 To 100
    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
    Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Fill EnableBlend%=_FALSE)"
    Locate 2, 1: Print "Fill " + Right$("   " + _ToStr$(i), 3) + " of 100  "
    Fill 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _FALSE
Next i

TestNum% = TestNum% + 1
t2# = Timer

For i = 1 To 100
    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
    Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Fill EnableBlend%=_TRUE) "
    Locate 2, 1: Print "Fill " + Right$("   " + _ToStr$(i), 3) + " of 100  "
    Fill 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), _TRUE
Next i

TestNum% = TestNum% + 1
t3# = Timer

For i = 1 To 100
    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
    Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint2)                  "
    Locate 2, 1: Print "Fill " + Right$("   " + _ToStr$(i), 3) + " of 100  "
    Paint2 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256)
Next i

TestNum% = TestNum% + 1
t4# = Timer

' only test 1x, or else we'll be here all day!
For i = 1 To 1
    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
    Locate 1, 1: Print "Test " + _ToStr$(TestNum%) + " of " + _ToStr$(NumTests%) + " (Paint3)                  "
    Locate 2, 1: Print "Fill " + Right$("   " + _ToStr$(i), 3) + " of 1    "
    paint3 400, 400, _RGB32(Rnd * 256, Rnd * 256, Rnd * 256)
Next i

t5# = Timer

Locate 1, 1: Print Left$("Test complete" + String$(TextCols%, " "), TextCols%)
Locate 2, 1: Print Left$("Results for 100 fills:" + String$(TextCols%, " "), TextCols%)
Color _RGB32(255, 255, 255), _RGB32(0, 0, 255)
Locate 3, 2: Print Using "###.### seconds Paint                   "; t1# - t0#
Locate 4, 2: Print Using "###.### seconds Fill EnableBlend%=_FALSE "; t2# - t1#
Locate 5, 2: Print Using "###.### seconds Fill EnableBlend%=_TRUE  "; t3# - t2#
Locate 6, 2: Print Using "###.### seconds Paint2                  "; t4# - t3#
Locate 7, 2: Print Using "###.### seconds Paint3                  "; (t5# - t4#) * 100

' ################################################################################################################################################################
' # BEGIN BPlus's fill code
' ################################################################################################################################################################

' /////////////////////////////////////////////////////////////////////////////
' From: bplus, Mini-Mod
' 4/23/2025 8:53 PM

' I have a different kind of paint, Paint3 that fills the color
' it lands on to do the painting, any other color stops the
' paint like a border

' madscijr added check for Esc key to cancel

Sub paint3 (x0, y0, MyFill As _Unsigned Long) ' needs GetMax, GetMin functions
    Dim fillColor As _Unsigned Long, W, H, parentF, tick, ystart, ystop, xstart, xstop, x, y

    fillColor = Point(x0, y0)
    'PRINT fillColor
    W = _Width - 1: H = _Height - 1

    Dim temp(W, H)
    temp(x0, y0) = 1: parentF = 1
    PSet (x0, y0), MyFill

    Dim k&: k& = 0 ' madscijr

    While parentF = 1
        parentF = 0: tick = tick + 1
        ystart = GetMax(y0 - tick, 0): ystop = GetMin(y0 + tick, H)
        y = ystart
        While y <= ystop
            xstart = GetMax(x0 - tick, 0): xstop = GetMin(x0 + tick, W)
            x = xstart
            While x <= xstop
                If Point(x, y) = fillColor And temp(x, y) = 0 Then
                    If temp(GetMax(0, x - 1), y) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
                    ElseIf temp(GetMin(x + 1, W), y) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
                    ElseIf temp(x, GetMax(y - 1, 0)) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
                    ElseIf temp(x, GetMin(y + 1, H)) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), MyFill
                    End If
                End If
                x = x + 1

                k& = _KeyHit: If k& = 27 Then Exit While ' madscijr
            Wend
            If k& = 27 Then Exit While ' madscijr

            y = y + 1

            k& = _KeyHit: If k& = 27 Then Exit While ' madscijr
        Wend
        If k& = 27 Then Exit While ' madscijr

        k& = _KeyHit: If k& = 27 Then Exit While ' madscijr
    Wend
End Sub ' paint3

' /////////////////////////////////////////////////////////////////////////////

Function GetMin (n1, n2)
    If n1 > n2 Then GetMin = n2 Else GetMin = n1
End Function

' /////////////////////////////////////////////////////////////////////////////

Function GetMax (n1, n2)
    If n1 < n2 Then GetMax = n2 Else GetMax = n1
End Function

' ################################################################################################################################################################
' # END BPlus's fill code
' ################################################################################################################################################################

' ################################################################################################################################################################
' # BEGIN Steve's fill code
' ################################################################################################################################################################

' /////////////////////////////////////////////////////////////////////////////
' SMcNeill, Super Moderator
' 4/23/2025 8:55 PM

Sub FillSteve
    $Color:32
    Screen _NewImage(1280, 720, 32)
    _ScreenMove 0, 0

    Circle (640, 360), 350, Red
    Circle (800, 500), 100, Blue
    Paint (800, 500), Blue, Blue

    Locate 1, 1
    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
    Print "Press any key to fill"
    Sleep ' so we can see that the blue circle is inside the red one.

    Fill 640, 360, Red, _FALSE 'fill all transparent pixels red

    Locate 1, 1
    Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
    Print "Press any key to exit"
    Sleep
End Sub ' FillSteve

' /////////////////////////////////////////////////////////////////////////////

Sub Fill (x, y, Kolor As _Unsigned Long, EnableBlend%)
    Dim As _Unsigned Long OC, BC
    OC = Point(x, y) 'original color

    If EnableBlend% = _TRUE Then
        ' blend is enabled
        If _Alpha32(Kolor) <> 255 Or _Alpha32(OC) <> 255 Then ' we're going to blend
            PSet (x, y), Kolor
            BC = Point(x, y) ' blended color
        End If
        BlendFiller x, y, Kolor, OC, BC
    Else
        Filler x, y, Kolor, OC
    End If
End Sub ' Fill

' /////////////////////////////////////////////////////////////////////////////
' Paintbucket fill (opaque)

Sub Filler (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long)
    Dim l, r, i
    If Kolor = OC Then Exit Sub
    l = x: r = x 'find left/right to fill
    Do Until l = 0
        If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
    Loop 'find the left boundry
    Do Until r = _Width - 1
        If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
    Loop 'find the right boundry
    Line (l, y)-(r, y), Kolor, BF
    For i = l To r
        If Point(i, y + 1) = OC Then Filler i, y + 1, Kolor, OC
    Next
    For i = l To r
        If Point(i, y - 1) = OC Then Filler i, y - 1, Kolor, OC
    Next
End Sub ' Filler

' /////////////////////////////////////////////////////////////////////////////
' Paintbucket fill with blending colors w/alpha < 255

Sub BlendFiller (x, y, Kolor As _Unsigned Long, OC As _Unsigned Long, BC As _Unsigned Long)
    Dim l, r, i
    If Kolor = OC Or Kolor = BC Then Exit Sub
    l = x: r = x 'find left/right to fill
    Do Until l = 0
        If Point(l - 1, y) = BC Then Exit Do
        If Point(l - 1, y) = OC Then l = l - 1 Else Exit Do
    Loop 'find the left boundry
    Do Until r = _Width - 1
        If Point(r + 1, y) = BC Then Exit Do
        If Point(r + 1, y) = OC Then r = r + 1 Else Exit Do
    Loop 'find the right boundry
    Line (l, y)-(r, y), Kolor, BF
    For i = l To r
        If Point(i, y + 1) = BC Then _Continue
        If Point(i, y + 1) = OC Then BlendFiller i, y + 1, Kolor, OC, BC
    Next
    For i = l To r
        If Point(i, y - 1) = BC Then _Continue
        If Point(i, y - 1) = OC Or Point(l - 1, y) = BC Then BlendFiller i, y - 1, Kolor, OC, BC
    Next
End Sub ' BlendFiller

' ################################################################################################################################################################
' # END Steve's fill code
' ################################################################################################################################################################

' ################################################################################################################################################################
' # BEGIN Petr's fill code
' ################################################################################################################################################################

' /////////////////////////////////////////////////////////////////////////////
' Petr, Mini-Mod
' 4/24/2025 9:42 AM
' https://qb64phoenix.com/forum/showthread.php?tid=1507

Sub Paint2 (x, y, c~&)
    Dim W
    Dim H
    Dim Virtual As Long
    Dim position&
    Dim Clr2~&
    Dim D&
    Dim CLR~&

    W = _Width: H = _Height
    Virtual = _NewImage(W, H, 32)

    Dim m As _MEM, n As _MEM, Bck As _Unsigned Long

    m = _MemImage(_Source)
    n = _MemImage(Virtual)

    'create mask (2 color image)
    position& = (y * W + x) * 4

    _MemGet m, m.OFFSET + position&, Bck

    Clr2~& = _RGB32(_Red32(Bck) - 1, _Green32(Bck) - 1, _Blue32(Bck) - 1, _Alpha32(Bck) - 1)

    D& = 0

    Do Until D& = n.SIZE
        CLR~& = _MemGet(m, m.OFFSET + D&, _Unsigned Long)
        If CLR~& = Bck~& Then _MemPut n, n.OFFSET + D&, CLR~& Else _MemPut n, n.OFFSET + D&, Clr2~&
        D& = D& + 4
    Loop

    D& = _Dest

    _Dest Virtual
    Paint (x, y), c~&, Clr2~&
    _Dest D&
    _ClearColor Clr2~&, Virtual
    _PutImage , Virtual, D&

    _MemFree m
    _MemFree n
    _FreeImage Virtual
End Sub ' Paint2
' ################################################################################################################################################################
' # END Petr's fill code
' ################################################################################################################################################################