Author Topic: Recursive Fills (almost) (Read 6985 times)

bplus · « **on:** November 03, 2021, 01:39:42 am »

I almost have it working, it has a little problem getting around circles, looks kind of interesting though. It's pretty fast! see random tests after first screen.

Code: QB64: [Select]

_Title "Recursive Fill" 'b+ 2021-11-03
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
Randomize Timer
 
Line (110, 200)-Step(580, 200), _RGB32(255, 0, 0), B
Circle (400, 300), 280, _RGB32(255, 0, 0)
'Circle (400, 300), 200.5, _RGB32(255, 0, 0) ' some circle radius leak like radius = 200
'Circle (400, 300), 201, _RGB32(255, 0, 0)
fill 400, 300, _RGB32(255, 0, 0)
Line (300, 10)-Step(200, 580), _RGB32(255, 0, 0), B
fill 400, 150, _RGB32(255, 0, 0)
fill 400, 450, _RGB32(255, 0, 0)
Sleep
While _KeyDown(27) = 0
    Cls
    Line (0, 0)-(_Width - 1, _Height - 1), _RGB32(255, 0, 0), B
    doBoxes = Int(Rnd * 2)
    For i = 1 To 10
        If doBoxes Then Line (Rnd * (_Width - 100) + 50, Rnd * (_Height - 100) + 50)-(Rnd * 100, Rnd * 100), _RGB32(255, 0, 0), B
        x = Rnd * _Width: y = Rnd * _Height: r = Rnd * 50 + 10
        Circle (x, y), r, _RGB32(255, 0, 0)
        Circle (x, y), r + .5, _RGB32(255, 0, 0)
        Circle (x, y), r + 1, _RGB32(255, 0, 0)
    Next
    fill 400, 300, _RGB32(255, 0, 0)
    'Beep
    Sleep
Wend
 
Function plus (x, y, c As _Unsigned Long)
    If Point(x, y) <> c Then
        For i = x - 1 To 0 Step -1
            If Point(i, y) = c Then xl = i + 1: Exit For
        Next
        'if xl = 0 then xl = 0
        For i = x + 1 To _Width - 1
            If Point(i, y) = c Then xr = i - 1: Exit For
        Next
        If xr = 0 Then xr = _Width - 1
        For i = y - 1 To 0 Step -1
            If Point(x, i) = c Then yu = i + 1: Exit For
        Next
        'if yu = 0 then yu = 0
        For i = y + 1 To _Height - 1
            If Point(x, i) = c Then yd = i - 1: Exit For
        Next
        If yd = 0 Then yd = _Height - 1
        Line (xl, y)-(xr, y), c
        Line (x, yu)-(x, yd), c
        plus = -1
    End If
End Function
 
Sub fill (x, y, c As _Unsigned Long)
    If plus(x, y, c) Then
        fill x - 1, y - 1, c
        fill x - 1, y + 1, c
        fill x + 1, y - 1, c
        fill x + 1, y + 1, c
    End If
End Sub
 
 

johnno56 · « **Reply #1 on:** November 03, 2021, 03:40:21 am »

Cool... Very fast... :)

bplus · « **Reply #2 on:** November 03, 2021, 02:39:15 pm »

Thanks @johnno56 got any ideas for use?

I am thinking a mod of this will get us through mazes.

johnno56 · « **Reply #3 on:** November 04, 2021, 06:40:28 am »

Been "out of the loop" today. Figured I would re-install my OS. Nice and fresh; quick and uncluttered... That should be good for another week... My Desktop is a magnet for junk and clutter... Where was I? Ideas you say? As long as the areas that require flood filling aren't too big, I suppose anything really... Mazes? 2D or 3D? Simple 2D mazes probably won't need a fill... After all, the walls, are just filled squares and rectangles... "line()-()" could take care of that... Raycasting could use vertical rectangle segments... Odd 4-sided walls could use a flood fill instead of using textures... Or any of the programs on QB64 that use that fcirc() routine... Board games like checkers or chess. Flood filling "pieces" of those sizes should be quick enough without cause memory issues... perhaps a flight sim (not the MS ones) like Red Baron etc. Might push memory limits... or the old Battle Zone (tank game)... Simple sprite editor... Struggling because of low caffeine levels...

Petr · « **Reply #4 on:** November 04, 2021, 09:36:17 am »

Hi, BPlus

I tried your program and unfortunately I was able to replicate a known program crash error using recursion. The added program will crash after a while with the announcement that the program has stopped working and will therefore be terminated. By no means would I want to look for a similar problem in large source code. The same mistake can be made in other ways - by sound, but I'm not talking about it now.

So the question. Is there a way to avoid such a recursion-induced program crash? This silly meaningless message from Windows is as beneficial as coat for the corpse.

Thanks for sharing.

Code: QB64: [Select]

_Title "Recursive Fill" 'b+ 2021-11-03
Screen _NewImage(1920, 1080, 32)
_Delay .25
_ScreenMove _Middle
Randomize Timer
 
Line (110, 200)-Step(580, 200), _RGB32(255, 0, 0), B
Circle (400, 300), 280, _RGB32(255, 0, 0)
'Circle (400, 300), 200.5, _RGB32(255, 0, 0) ' some circle radius leak like radius = 200
'Circle (400, 300), 201, _RGB32(255, 0, 0)
fill 400, 300, _RGB32(255, 0, 0)
Line (300, 10)-Step(200, 580), _RGB32(255, 0, 0), B
fill 400, 150, _RGB32(255, 0, 0)
fill 400, 450, _RGB32(255, 0, 0)
fill 5, 5, &HFFFFFF00
Sleep
While _KeyDown(27) = 0
    Cls
    Line (0, 0)-(_Width - 1, _Height - 1), _RGB32(255, 0, 0), B
    doBoxes = Int(Rnd * 2)
    For i = 1 To 10
        If doBoxes Then Line (Rnd * (_Width - 100) + 50, Rnd * (_Height - 100) + 50)-(Rnd * 100, Rnd * 100), _RGB32(255, 0, 0), B
        x = Rnd * _Width: y = Rnd * _Height: r = Rnd * 50 + 10
        Circle (x, y), r, _RGB32(255, 0, 0)
        Circle (x, y), r + .5, _RGB32(255, 0, 0)
        Circle (x, y), r + 1, _RGB32(255, 0, 0)
    Next
    fill 400, 300, _RGB32(255, 0, 0)
    'Beep
    Sleep
Wend
 
Function plus (x, y, c As _Unsigned Long)
    If Point(x, y) <> c Then
        For i = x - 1 To 0 Step -1
            If Point(i, y) = c Then xl = i + 1: Exit For
        Next
        'if xl = 0 then xl = 0
        For i = x + 1 To _Width - 1
            If Point(i, y) = c Then xr = i - 1: Exit For
        Next
        If xr = 0 Then xr = _Width - 1
        For i = y - 1 To 0 Step -1
            If Point(x, i) = c Then yu = i + 1: Exit For
        Next
        'if yu = 0 then yu = 0
        For i = y + 1 To _Height - 1
            If Point(x, i) = c Then yd = i - 1: Exit For
        Next
        If yd = 0 Then yd = _Height - 1
        Line (xl, y)-(xr, y), c
        Line (x, yu)-(x, yd), c
        plus = -1
    End If
End Function
 
Sub fill (x, y, c As _Unsigned Long)
    If plus(x, y, c) Then
        fill x - 1, y - 1, c
        fill x - 1, y + 1, c
        fill x + 1, y - 1, c
        fill x + 1, y + 1, c
    End If
End Sub
 
 
 
 

Petr · « **Reply #5 on:** November 04, 2021, 09:54:53 am »

@bplus
You don't have to answer, I found a recursion thread where Steve explains it. I'll try to find a way to reliably clean the memory tank (it will be a lot of beers and a lot of headaches) BUT I just have to try. When a reliable method is found, it opens up many possibilities. In this case, for example - how about dividing an image into images with a size of 100x100 pixels, doing coordinate conversions, then filling it in and finally reassembling? Damn, when I read it, I'm not feeling well...

bplus · « **Reply #6 on:** November 04, 2021, 10:15:13 am »

@Petr

The trouble making line in your mod of my code was this one:
fill 5, 5, &HFFFFFF00
There was nothing to stop the color from flooding the whole screen and beyond.
This is fixed by drawing a containment border first around the area to fill with the same color you are about to fill with eg,

Code: QB64: [Select]

_Title "Recursive Fill" 'b+ 2021-11-03
Screen _NewImage(1280, 740, 32)  ' <<<<<<<<<<<<<<<<<< biggest screen I can see on laptop
_Delay .25
_ScreenMove _Middle
Randomize Timer
 
Line (0, 0)-(_Width - 1, _Height - 1), &HFFFFFF00, B ' you must contain the color you are filling with that color border
fill 5, 5, &HFFFFFF00
Beep
 
Function plus (x, y, c As _Unsigned Long)
    If Point(x, y) <> c Then
        For i = x - 1 To 0 Step -1
            If Point(i, y) = c Then xl = i + 1: Exit For
        Next
        'if xl = 0 then xl = 0
        For i = x + 1 To _Width - 1
            If Point(i, y) = c Then xr = i - 1: Exit For
        Next
        If xr = 0 Then xr = _Width - 1
        For i = y - 1 To 0 Step -1
            If Point(x, i) = c Then yu = i + 1: Exit For
        Next
        'if yu = 0 then yu = 0
        For i = y + 1 To _Height - 1
            If Point(x, i) = c Then yd = i - 1: Exit For
        Next
        If yd = 0 Then yd = _Height - 1
        Line (xl, y)-(xr, y), c
        Line (x, yu)-(x, yd), c
        plus = -1
    End If
End Function
 
Sub fill (x, y, c As _Unsigned Long)
    If plus(x, y, c) Then
        fill x - 1, y - 1, c
        fill x - 1, y + 1, c
        fill x + 1, y - 1, c
        fill x + 1, y + 1, c
    End If
End Sub
 

When you hear the beep you will know you didn't crash.
Notice I had to use _Width -1, _Height - 1 to keep the containment box on screen.

BTW The fill routine is not better than Paint to Border color but worse! It's just an experiment with Recursive Sub to attempt a Paint like fill.

If you need a Fill / Paint that changes a color until contained by any other color I have a beauty I call Paint3.

bplus · « **Reply #7 on:** November 04, 2021, 10:29:13 am »

I suppose I could put checks on Fill to make sure x, y aren't off screen. Thus we won't need a containment box, yeah!

Code: QB64: [Select]

_Title "Recursive Fill" 'b+ 2021-11-03
Screen _NewImage(1280, 740, 32) ' <<<<<<<<<<<<<<<<<< biggest screen I can see on laptop
_Delay .25
_ScreenMove _Middle
Randomize Timer
 
fill 5, 5, &HFFFFFF00
Beep
 
Function plus (x, y, c As _Unsigned Long)
    If Point(x, y) <> c Then
        For i = x - 1 To 0 Step -1
            If Point(i, y) = c Then xl = i + 1: Exit For
        Next
        'if xl = 0 then xl = 0
        For i = x + 1 To _Width - 1
            If Point(i, y) = c Then xr = i - 1: Exit For
        Next
        If xr = 0 Then xr = _Width - 1
        For i = y - 1 To 0 Step -1
            If Point(x, i) = c Then yu = i + 1: Exit For
        Next
        'if yu = 0 then yu = 0
        For i = y + 1 To _Height - 1
            If Point(x, i) = c Then yd = i - 1: Exit For
        Next
        If yd = 0 Then yd = _Height - 1
        Line (xl, y)-(xr, y), c
        Line (x, yu)-(x, yd), c
        plus = -1
    End If
End Function
 
Sub fill (x, y, c As _Unsigned Long)
    If x >= 0 And x < _Width And y >= 0 And y < _Height Then
        If plus(x, y, c) Then
            fill x - 1, y - 1, c
            fill x - 1, y + 1, c
            fill x + 1, y - 1, c
            fill x + 1, y + 1, c
        End If
    End If
End Sub
 
 

Fixed! Thanks @Petr

Petr · « **Reply #8 on:** November 04, 2021, 12:11:59 pm »

Very good, BPlus :) I don't know why I still need to scratch with my right foot behind my left ear...

bplus · « **Reply #9 on:** November 04, 2021, 01:19:18 pm »

@Petr you seem uncomfortable about something?

Well no worries this will replace Paint or Paint with Border. :) But might be useful pathfinding mod?

johnno56 · « **Reply #10 on:** November 04, 2021, 03:20:46 pm »

This may not make much sense but please read on.

I had a problem with scrolling background images. Set the two images in the right place. Moved both images at the same speed. The first image moves off the screen; the second image is placed next; the second image moves off the screen and the first image... you get the point? What has this got to do with fill? The problem I had with the moving images was a tiny gap between them. I forgot to account for the speed.

My theory, for the fill example is, you are testing the pixel directly beneath where you want to draw - If Point(x,y) <> c - instead of checking the pixel you want to move towards. eg: if you land on a line (or the edge of the screen) it could be too late because the fill routine is already placing pixels beyond the 'landing' point. I'm not sure if I am making sense. Perhaps, checking the pixel you intend to move to first - If Point(x+speed,y) or '1' in this case - will give the fill routine enough warning before going beyond the 'limits'? Just a thought... Similar system in platform games. When moving a character you don't check for collision when you are already in place. You always check 'ahead' to see if the character 'can' move in that direction. Would not the same system apply to the 'collision' of the fill pixels? Apologies for babbling...

Petr · « **Reply #11 on:** November 05, 2021, 07:29:46 am »

@johnno56 You are right!
@bplus Your program works badly:

Code: QB64: [Select]

_Title "Recursive Fill" 'b+ 2021-11-03
Screen _NewImage(1980, 1050, 32) ' <<<<<<<<<<<<<<<<<< biggest screen I can see on laptop
_Delay .25
 
$Color:32
Circle (900, 555), 450, Gold
Sleep
fill 900, 555, Gold
Sleep
fill 5, 5, Red
Beep
 
Function plus (x, y, c As _Unsigned Long)
    plus = 0
    If Point(x, y) <> c Then
        For i = x - 1 To 0 Step -1
            If Point(i, y) = c Then xl = i + 1: Exit For
        Next
        'if xl = 0 then xl = 0
        For i = x + 1 To _Width - 1
            If Point(i, y) = c Then xr = i - 1: Exit For
        Next
        If xr = 0 Then xr = _Width - 1
        For i = y - 1 To 0 Step -1
            If Point(x, i) = c Then yu = i + 1: Exit For
        Next
        'if yu = 0 then yu = 0
        For i = y + 1 To _Height - 1
            If Point(x, i) = c Then yd = i - 1: Exit For
        Next
        If yd = 0 Then yd = _Height - 1
        Line (xl, y)-(xr, y), c
        Line (x, yu)-(x, yd), c
        plus = -1
    End If
End Function
 
Sub fill (x, y, c As _Unsigned Long)
    If x >= 0 And x < _Width And y >= 0 And y < _Height Then
        If plus(x, y, c) Then
            fill x - 1, y - 1, c
            fill x - 1, y + 1, c
            fill x + 1, y - 1, c
            fill x + 1, y + 1, c
        End If
    End If
End Sub
 

I found my old solution for coloring. It's been a long time since I've dealt with this. Acceleration there would mean dropping PAINT and using MEM. But that's an old familiar thing. Here's what I use when I need to color something that doesn't have the same color areas. I see that it still stays with the first version. Well, I'm doing something else again...
My SLOW solution use not recursion, so its out of topic :)

Code: QB64: [Select]

' paint first pre - alternative. Program logic:
'- User set coordinates and output color (border color is NOT NEED)
'- Program find colors borders in easyest way. Create virtual screen and draw borders.
'- Use QB64 statement PAINT in this virtual screen and then copy colored area back to visible screen
'- Kill arrays and virtual screen and return back.
 
'It is first version, extreme slow!
 
'If is something "super", so has not big value. So this is named super.....slow.....wait........Sub :-D
'in true, i thing about - how do it many months. Because i have not enough time, i started this many times in different ways. First -   I wanted to do this by moving the X, Y pointer
'along the Y axis up to the border of the colors, and then copying the border of the color boundaries and reducing its radius at each turn. Unfortunately, when using a circle, the pointer
'has always run away. It was fun, but I did not to laugh ...
 
Screen _NewImage(800, 600, 32)
 
 
Circle (400, 300), 250, _RGB32(100, 20, 33)
Circle (400, 300), 450, _RGB32(10, 200, 133)
Line (100, 100)-(400, 400), _RGB32(10, 200, 133), B
Line (300, 300)-(500, 500), _RGB32(10, 20, 99), B
Sleep
 
SuperPaint 338, 349, _RGB32(255, 0, 0)
Sleep
 
SuperPaint 531, 219, _RGB32(10, 255, 0)
Sleep
 
SuperPaint 436, 451, _RGB32(0, 10, 255)
Sleep
 
SuperPaint 715, 242, _RGB32(255, 255, 0)
Sleep
 
 
 
 
Sub SuperPaint (x As Integer, y As Integer, clr As _Unsigned Long) '32 bit: ok   8 bit: ok
    Background& = Point(x, y)
    W = _Width(0)
    H = _Height(0)
    Dim O(W, H) As Integer, bclr As _Unsigned Long
 
    For Sy = 0 To H - 1
        For sx = 1 To W - 2
            If Point(sx, Sy) <> Point(sx + 1, Sy) Then
                oldsx = sx
                O(sx, Sy) = 1
            End If
    Next sx, Sy
 
    For sx = 0 To W - 1
        For Sy = 0 To H - 1
            If Point(sx, Sy) <> Point(sx, Sy + 1) Then
                oldsy = Sy
                O(sx, Sy) = 1
            End If
    Next Sy, sx
    i = 0
    bclr& = 255
    Select Case _PixelSize(_Dest)
        Case 1: bclr = clr - 1: Depth = 256
        Case 4: bclr = _RGB32(_Red32(clr) - 1, _Green32(clr) - 1, _Blue32(clr) - 1): Depth = 32
    End Select
    my& = _Dest
    virtual& = _NewImage(W, H, Depth)
    _Dest virtual&
    For Sy = 0 To H
        For sx = 0 To W
            If O(sx, Sy) Then
                PSet (sx, Sy), bclr
            End If
    Next sx, Sy
    _Dest virtual&
    Paint (x, y), clr, bclr
    Erase O
    For sx = 0 To W
        For Sy = 0 To H
            _Source virtual&
            _Dest my&
            If Point(sx, Sy) = clr Then PSet (sx, Sy), clr
            If Point(sx - 1, Sy) = clr Then PSet (sx, Sy), clr
            If Point(sx, Sy - 1) = clr Then PSet (sx, Sy), clr
    Next Sy, sx
    _Dest my&
    _FreeImage virtual&
End Sub
 

SMcNeill · « **Reply #12 on:** November 05, 2021, 08:09:56 am »

Here's the Fill I usually use, but it doesn't have any recursion going on with it.

Code: QB64: [Select]

Screen _NewImage(1024, 720, 32)
Do: Loop Until _ScreenExists
_ScreenMove _Middle
 
 
TestLimit = 100
Radius = 350
 
Randomize Timer
t# = Timer
For i = 1 To TestLimit
    k& = &HFF000000 + Int(Rnd * &HFFFFFF)
 
    Circle (512, 360), Radius, k&
    Fill 512, 360, k&
Next
 
t1# = Timer
For i = 1 To TestLimit
    k& = &HFF000000 + Int(Rnd * &HFFFFFF)
 
    Circle (512, 360), Radius, k&
    Paint (512, 360), k&
Next
t2# = Timer
 
 
For i = 1 To TestLimit
    k& = &HFF000000 + Int(Rnd * &HFFFFFF)
 
    CircleFill 512, 360, Radius, k&
 
Next
t3# = Timer
 
 
Print Using "###.#### seconds for Fill."; t1# - t#
Print Using "###.#### seconds for Paint."; t2# - t1#
Print Using "###.#### seconds for CircleFill."; t3# - t2#
 
 
 
 
 
 
 
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    ' CX = center x coordinate
    ' CY = center y coordinate
    '  R = radius
    '  C = fill color
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R)
    RadiusError = -Radius
    X = Radius
    Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub
 
 
 
 
 
 
 
 
Sub Fill (Passx, Passy, kolor As Long)
    $Checking:Off
    B = _Blend
    _DontBlend
 
    Dim TempGrid(_Width - 1, _Height - 1) As Long
    Dim As _MEM m, m1: m = _Mem(TempGrid()): m1 = _MemImage(0)
    Dim o As _Offset
    _MemCopy m1, m1.OFFSET, m1.SIZE To m, m.OFFSET
    o = 0
    Do Until o >= m.SIZE
        If _MemGet(m1, m1.OFFSET + o, _Unsigned Long) = kolor Then
            _MemPut m, m.OFFSET + o, -1 As LONG
            'Else
            '_MemPut m, m.OFFSET + o, 0 As LONG
        End If
        o = o + 4
    Loop
 
    TempGrid(Passx, Passy) = 1
    startx = Passx - pass: finishx = Passx + pass
    starty = Passy - pass: finishy = Passy + pass
 
    Do Until finished
        pass = pass + 1
        finished = -1
        For x = startx To finishx
            For y = starty To finishy
                If TempGrid(x, y) = pass Then
                    tempx = x
                    Do Until tempx = 0
                        If TempGrid(tempx - 1, y) = 0 Then
                            TempGrid(tempx - 1, y) = pass + 1
                            tempx = tempx - 1
                            If tempx < startx Then startx = tempx
                            finished = 0
                        Else
                            tempx = 0
                        End If
                    Loop
 
                    tempx = x
                    Do Until tempx = _Width - 1
                        If TempGrid(tempx + 1, y) = 0 Then
                            TempGrid(tempx + 1, y) = pass + 1
                            tempx = tempx + 1
                            If tempx > finishx Then finishx = tempx
                            finished = 0
                        Else
                            tempx = _Width - 1
                        End If
                    Loop
 
                    tempy = y
                    Do Until tempy = 0
                        If TempGrid(x, tempy - 1) = 0 Then
                            TempGrid(x, tempy - 1) = pass + 1
                            tempy = tempy - 1
                            If tempy < starty Then startx = tempy
                            finished = 0
                        Else
                            tempy = 0
                        End If
                    Loop
 
                    tempy = y
                    Do Until tempy = _Height - 1
                        If TempGrid(x, tempy + 1) = 0 Then
                            TempGrid(x, tempy + 1) = pass + 1
                            tempy = tempy + 1
                            If tempy > finishy Then finishy = tempy
                            finished = 0
                        Else
                            tempy = _Height - 1
                        End If
                    Loop
                End If
        Next y, x
    Loop
 
    o = 0
    Do Until o >= m.SIZE
        If _MemGet(m, m.OFFSET + o, _Unsigned Long) <> 0 Then _MemPut m1, m1.OFFSET + o, kolor As _UNSIGNED LONG
        o = o + 4
    Loop
    _MemFree m: _MemFree m1
    $Checking:On
    If B Then _Blend
End Sub

It's faster than PAINT, but still no where near the speeds of a decent CircleFIll routine.

NOTE: This is also the same thing which I do for my 2D games which require pathfinding, though it's just usually on a much smaller scale.

Petr · « **Reply #13 on:** November 05, 2021, 08:49:50 am »

I sat down and now (since the last post here) I wrote something, that seems to work faster (as fast as paint). The solution is to create a two-color mask and then use the paint statement and finally insert the image over the original. It's not as fast as Steve's version, but it's definitely faster than what I created in 2018.

Code: QB64: [Select]

 
Screen _NewImage(1024, 768, 32)
$Color:32
Do
    Cls , Red
    For c = 1 To 40
        Circle (Rnd * 980, Rnd * 740), Rnd * 100 + 10, _RGB32(255 * Rnd)
        X = Rnd * 1024
        Y = Rnd * 768
        Lwidth = Rnd * 100
        Lheight = Rnd * 100
        Line (X, Y)-(X + Lwidth, Y + Lheight), _RGB32(255 * Rnd, 255 * Rnd, 255 * Rnd), BF
    Next
    _Delay .3
    _MouseMove 512, 384
 
 
    sp 512, 384, White
    _Delay .3
Loop
 
Sub sp (x, y, c~&)
    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)
    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
 
 
_MouseMove in program is used for us to show where is fill point.
 

bplus · « **Reply #14 on:** November 05, 2021, 09:21:33 am »

Quote

@bplus Your program works badly:

And thus the title of the thread: Recursive Fills (almost)

Steve's "simple" little recursive fill that doesn't work got me on the hunt for a

Recursive Fill Routine

I already offered a non recursive Paint Routine that covers (no pun intended) what Paint doesn't. It looks allot like Steve's without the Mem stuff because we had worked it out here this forum probably at least a year ago. Oh I can check the date a quick search for where it is in my new list of bas files...

Code: QB64: [Select]

Option _Explicit
_Title "PAINT3 test" 'b+ 2020-06-26
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
Dim i, mb, mx, my
For i = 1 To 50
    Line (Rnd * 800, Rnd * 600)-(Rnd * 800, Rnd * 600), _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, 128 + Rnd * 128)
    Circle (Rnd * 800, Rnd * 600), Rnd * 50 + 10, _RGB32(Rnd * 255, Rnd * 255, Rnd * 255, 128 + Rnd * 128)
Next
Do
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    If mb Then paint3 mx, my, &HFFFFFFFF
    _Limit 200
Loop Until _KeyDown(27)
 
Sub paint3 (x0, y0, fill As _Unsigned Long) ' needs max, min 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), fill
    While parentF = 1
        parentF = 0: tick = tick + 1
        ystart = max(y0 - tick, 0): ystop = min(y0 + tick, H)
        y = ystart
        While y <= ystop
            xstart = max(x0 - tick, 0): xstop = min(x0 + tick, W)
            x = xstart
            While x <= xstop
                If Point(x, y) = fillColor And temp(x, y) = 0 Then
                    If temp(max(0, x - 1), y) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), fill
                    ElseIf temp(min(x + 1, W), y) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), fill
                    ElseIf temp(x, max(y - 1, 0)) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), fill
                    ElseIf temp(x, min(y + 1, H)) Then
                        temp(x, y) = 1: parentF = 1: PSet (x, y), fill
                    End If
                End If
                x = x + 1
            Wend
            y = y + 1
        Wend
    Wend
End Sub
 
Function min (n1, n2)
    If n1 > n2 Then min = n2 Else min = n1
End Function
 
Function max (n1, n2)
    If n1 < n2 Then max = n2 Else max = n1
End Function
 
 

But that's not recursive

News:

Author Topic: Recursive Fills (almost) (Read 6985 times)

bplus

Recursive Fills (almost)

johnno56

Re: Recursive Fills (almost)

bplus

Re: Recursive Fills (almost)

johnno56

Re: Recursive Fills (almost)

Petr

Re: Recursive Fills (almost)

Petr

Re: Recursive Fills (almost)

bplus

Re: Recursive Fills (almost)

bplus

Re: Recursive Fills (almost)

Petr

Re: Recursive Fills (almost)

bplus

Re: Recursive Fills (almost)

johnno56

Re: Recursive Fills (almost)

Petr

Re: Recursive Fills (almost)

SMcNeill

Re: Recursive Fills (almost)

Petr

Re: Recursive Fills (almost)

bplus

Re: Recursive Fills (almost)