Posts: 513
Threads: 65
Joined: May 2022
Reputation:
83
Program for detecting image edges. Returns an array of edge points.
Code: (Select All)
' ---------------------------
' Border detect 0.1
' ---------------------------
Screen _NewImage(800, 600, 256)
Randomize Timer
Do
Locate 1
'draw random image (1 color, is enought as mask)
For f = 1 To 5000
If Rnd * 4 > 5 Then p = -1 Else p = 1
x = 200 + Rnd * p * 300
y = 200 + Rnd * p * 200
r = (10 + f / 250) * Rnd
CircleFill x, y, r, 40
Next
' prepare output arrays
ReDim Bx(0) As Integer, By(0) As Integer
ReDim count As Long
' use _Dest as source image, because image is draw directly to screen in previous step
DetectBorder _Dest, 40, Bx(), By(), count
_Dest 0
Print "Generate random picture in 1 color and detect the border (white). ESC for end."
Print "Border points (count):"; count
' draw detected border points
If count >= 0 Then
For d = 0 To count
Line (Bx(d), By(d))-(Bx(d) + 1, By(d) + 1), , BF 'draw detected border in white color
Next
End If
_Limit 1
Cls
Print "Generate random picture in 1 color and detect the border (white)."
Loop Until _KeyDown(27)
' ---------------------------------------------
' Boundary test function
' Returns -1 if pixel is boundary, 0 otherwise
' ---------------------------------------------
Function IsBoundary (px As Long, py As Long, targetColor As Integer, src As Long, W As Long, H As Long, dx() As Integer, dy() As Integer)
' outside = boundary
If px < 0 Or px >= W Or py < 0 Or py >= H Then
IsBoundary = -1
Exit Function
End If
_Source src
If Point(px, py) <> targetColor Then
IsBoundary = 0
Exit Function
End If
' at least one neighbor must differ -> boundary
For k = 0 To 7
nx = px + dx(k)
ny = py + dy(k)
If nx < 0 Or nx >= W Or ny < 0 Or ny >= H Then
IsBoundary = -1
Exit Function
Else
_Source src
If Point(nx, ny) <> targetColor Then
IsBoundary = -1
Exit Function
End If
End If
Next
IsBoundary = 0
End Function
' ---------------------------------
' Moore-neighborhood border tracer
' ---------------------------------
Sub DetectBorder (src As Long, targetColor As Integer, bx() As Integer, by() As Integer, bcnt As Long)
Dim dx(7) As Integer, dy(7) As Integer
dx(0) = 1: dy(0) = 0 ' East
dx(1) = 1: dy(1) = 1 ' SE
dx(2) = 0: dy(2) = 1 ' South
dx(3) = -1: dy(3) = 1 ' SW
dx(4) = -1: dy(4) = 0 ' West
dx(5) = -1: dy(5) = -1 ' NW
dx(6) = 0: dy(6) = -1 ' North
dx(7) = 1: dy(7) = -1 ' NE
W = _Width(src)
H = _Height(src)
_Source src
' 1) find first boundary pixel
found = 0
For yy = 0 To H - 1
For xx = 0 To W - 1
If Point(xx, yy) = targetColor Then
If IsBoundary(xx, yy, targetColor, src, W, H, dx(), dy()) Then
sx = xx: sy = yy
found = -1
Exit For
End If
End If
Next
If found Then Exit For
Next
If found = 0 Then
bcnt = -1
Exit Sub
End If
' 2) preallocate storage and prevent overflow
maxPts = W * H
ReDim bx(maxPts - 1) As Integer
ReDim by(maxPts - 1) As Integer
' 3) initialize tracker
x = sx: y = sy
prevX = sx - 1: prevY = sy
startPrevX = prevX: startPrevY = prevY
idx = 0
Do
If idx >= maxPts Then Exit Do
bx(idx) = x
by(idx) = y
idx = idx + 1
' find direction to previous pixel
dirPrev = -1
For d = 0 To 7
If x + dx(d) = prevX And y + dy(d) = prevY Then
dirPrev = d
Exit For
End If
Next
If dirPrev = -1 Then dirPrev = 4
' search next boundary neighbor
foundNext = 0
For k = 1 To 8
i = (dirPrev + k) Mod 8
nx = x + dx(i)
ny = y + dy(i)
If nx >= 0 And nx < W And ny >= 0 And ny < H Then
If IsBoundary(nx, ny, targetColor, src, W, H, dx(), dy()) Then
prevX = x: prevY = y
x = nx: y = ny
foundNext = -1
Exit For
End If
End If
Next
If foundNext = 0 Then Exit Do
Loop Until (x = sx And y = sy And prevX = startPrevX And prevY = startPrevY)
If idx = 0 Then
bcnt = -1
Else
bcnt = idx - 1
End If
End Sub
' ---------------------------------------------
' Fast filled circle - SMcNeill gold standard
' ---------------------------------------------
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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
Posts: 513
Threads: 65
Joined: May 2022
Reputation:
83
Based on the previous program, here is a better version. It selects only non-repeating points from the perimeter and reduces them in the OptimStep step. The lower the OptimStep (min 1), the smoother the boundaries and the more boundary points there are. The higher the OptimStep, the rougher the boundaries and the fewer boundary points there are. Of course, this is a simple algorithm, so it will not limit the square to 4 points. For now...
Code: (Select All)
' ---------------------------
' Border detect 0.1b
' ---------------------------
Screen _NewImage(800, 600, 256)
Randomize Timer
Dim Bcount As Integer
Dim OptimStep As Integer
OptimStep = 10 'step optimalized border is 10 pixels
Do
Locate 1
'draw random image (1 color, is enought as mask)
For f = 1 To 5000
If Rnd * 10 > 4 Then p = -1 Else p = 1
x = 400 + Rnd * p * 300
y = 300 + Rnd * p * 200
r = (10 + f / 500) * Rnd
CircleFill x, y, r, 40
Next
' prepare output arrays
ReDim Bx(0) As Integer, By(0) As Integer
ReDim count As Long
' use _Dest as source image, because image is draw directly to screen in previous step
DetectBorder _Dest, 40, Bx(), By(), count
_Dest 0
Print "Generate random picture in 1 color and detect the border (white). ESC for end."
Print "Border points (count):"; count
' draw detected border points
If count > 0 Then
For d = 0 To count
Line (Bx(d), By(d))-(Bx(d) + 1, By(d) + 1), , BF 'draw detected border in white color
Next
End If
_Limit 1
Cls
OptimizeBorders Bx(), By(), OptimStep, Bcount
Print "Total border points: "; count; "reduced border points: "; Bcount
If Bcount > 0 Then
For d = 1 To Bcount
Line (Bx(d), By(d))-(Bx(d - 1), By(d - 1)), 25 'draw detected border in white color
Next
End If
Line (Bx(Bcount), By(Bcount))-(Bx(0), By(0)), 25
_Limit 1
Cls
Print "Generate random picture in 1 color and detect the border (white)."
Loop Until _KeyDown(27)
Sub OptimizeBorders (Bx() As Integer, By() As Integer, Stp As Integer, Bcount As Integer)
Do Until d > 0 And Bx(d) = Bx(0) And By(d) = By(0)
d = d + 1
Loop
Dim As Integer Bx2(d \ Stp), By2(d \ Stp)
For e = 0 To d Step Stp
Bx2(f) = Bx(e)
By2(f) = By(e)
f = f + 1
Next
ReDim Bx(f) As Integer
ReDim By(f) As Integer
For e = 0 To f - 1
Bx(e) = Bx2(e)
By(e) = By2(e)
Next e
Bcount = f - 1
Erase Bx2
Erase By2
End Sub
' ---------------------------------------------
' Boundary test function
' Returns -1 if pixel is boundary, 0 otherwise
' ---------------------------------------------
Function IsBoundary (px As Long, py As Long, targetColor As Integer, src As Long, W As Long, H As Long, dx() As Integer, dy() As Integer)
' outside = boundary
If px < 0 Or px >= W Or py < 0 Or py >= H Then
IsBoundary = -1
Exit Function
End If
_Source src
If Point(px, py) <> targetColor Then
IsBoundary = 0
Exit Function
End If
' at least one neighbor must differ -> boundary
For k = 0 To 7
nx = px + dx(k)
ny = py + dy(k)
If nx < 0 Or nx >= W Or ny < 0 Or ny >= H Then
IsBoundary = -1
Exit Function
Else
_Source src
If Point(nx, ny) <> targetColor Then
IsBoundary = -1
Exit Function
End If
End If
Next
IsBoundary = 0
End Function
' ---------------------------------
' Moore-neighborhood border tracer
' ---------------------------------
Sub DetectBorder (src As Long, targetColor As Integer, bx() As Integer, by() As Integer, bcnt As Long)
Dim dx(7) As Integer, dy(7) As Integer
dx(0) = 1: dy(0) = 0 ' East
dx(1) = 1: dy(1) = 1 ' SE
dx(2) = 0: dy(2) = 1 ' South
dx(3) = -1: dy(3) = 1 ' SW
dx(4) = -1: dy(4) = 0 ' West
dx(5) = -1: dy(5) = -1 ' NW
dx(6) = 0: dy(6) = -1 ' North
dx(7) = 1: dy(7) = -1 ' NE
W = _Width(src)
H = _Height(src)
_Source src
' 1) find first boundary pixel
found = 0
For yy = 0 To H - 1
For xx = 0 To W - 1
If Point(xx, yy) = targetColor Then
If IsBoundary(xx, yy, targetColor, src, W, H, dx(), dy()) Then
sx = xx: sy = yy
found = -1
Exit For
End If
End If
Next
If found Then Exit For
Next
If found = 0 Then
bcnt = -1
Exit Sub
End If
' 2) preallocate storage and prevent overflow
maxPts = W * H
ReDim bx(maxPts - 1) As Integer
ReDim by(maxPts - 1) As Integer
' 3) initialize tracker
x = sx: y = sy
prevX = sx - 1: prevY = sy
startPrevX = prevX: startPrevY = prevY
idx = 0
Do
If idx >= maxPts Then Exit Do
bx(idx) = x
by(idx) = y
idx = idx + 1
' find direction to previous pixel
dirPrev = -1
For d = 0 To 7
If x + dx(d) = prevX And y + dy(d) = prevY Then
dirPrev = d
Exit For
End If
Next
If dirPrev = -1 Then dirPrev = 4
' search next boundary neighbor
foundNext = 0
For k = 1 To 8
i = (dirPrev + k) Mod 8
nx = x + dx(i)
ny = y + dy(i)
If nx >= 0 And nx < W And ny >= 0 And ny < H Then
If IsBoundary(nx, ny, targetColor, src, W, H, dx(), dy()) Then
prevX = x: prevY = y
x = nx: y = ny
foundNext = -1
Exit For
End If
End If
Next
If foundNext = 0 Then Exit Do
Loop Until (x = sx And y = sy And prevX = startPrevX And prevY = startPrevY)
If idx = 0 Then
bcnt = -1
Else
bcnt = idx - 1
End If
End Sub
' ---------------------------------------------
' Fast filled circle - SMcNeill gold standard
' ---------------------------------------------
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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
Posts: 513
Threads: 65
Joined: May 2022
Reputation:
83
Fast version, use _Mem not Point, optimized directly
Code: (Select All)
' -------------------------------------------
' Border detect 0.2 (MEM version)
' -------------------------------------------
Screen _NewImage(800, 600, 256)
Randomize Timer
Dim Bcount As Integer
Dim OptimStep As Integer
OptimStep = 20 ' step optimized border is 20 pixels
Do
Locate 1
' draw random image (1 color, is enough as mask)
For f = 1 To 5000
If Rnd * 10 > 4 Then p = -1 Else p = 1
x = 400 + Rnd * p * 300
y = 300 + Rnd * p * 200
r = (10 + f / 500) * Rnd
CircleFill x, y, r, 40
Next
' prepare output arrays
ReDim Bx(0) As Integer, By(0) As Integer
ReDim count As Long
' use _Dest as source image, because image is drawn directly to screen in previous step
DetectBorder _Dest, 40, Bx(), By(), count
_Dest 0
Print "Generate random picture in 1 color and detect the border (white). ESC for end."
Print "Border points (count):"; count
' draw detected border points (small squares)
If count > 0 Then
For d = 0 To count
Line (Bx(d), By(d))-(Bx(d) + 1, By(d) + 1), , BF
Next
End If
If Bcount > 0 Then
For d = 1 To Bcount
Line (Bx(d), By(d))-(Bx(d - 1), By(d - 1)), 2
Next
Line (Bx(Bcount), By(Bcount))-(Bx(0), By(0)), 25
End If
_Display
' Sleep
_Limit 2000
Cls
Loop Until _KeyDown(27)
Function GetPix~%% (mem As _MEM, x As Long, y As Long, w As Long)
' vrací 0..255 (unsigned byte)
GetPix = _MemGet(mem, mem.OFFSET + y * w + x, _Unsigned _Byte)
End Function
' ---------------------------------------------
' IsBoundary using _MEM (returns -1 if boundary, 0 otherwise)
' ---------------------------------------------
Function IsBoundary (px As Long, py As Long, targetColor As Integer, mem As _MEM, W As Long, H As Long, dx() As Integer, dy() As Integer)
' outside = boundary
If px < 0 Or px >= W Or py < 0 Or py >= H Then
IsBoundary = -1
Exit Function
End If
If GetPix(mem, px, py, W) <> targetColor Then
IsBoundary = 0
Exit Function
End If
' at least one neighbor must differ -> boundary
For k = 0 To 7
nx = px + dx(k)
ny = py + dy(k)
If nx < 0 Or nx >= W Or ny < 0 Or ny >= H Then
IsBoundary = -1
Exit Function
Else
If GetPix(mem, nx, ny, W) <> targetColor Then
IsBoundary = -1
Exit Function
End If
End If
Next
IsBoundary = 0
End Function
' ---------------------------------
' Moore-neighborhood border tracer (reads from _MEM)
' ---------------------------------
Sub DetectBorder (src As Long, targetColor As Integer, bx() As Integer, by() As Integer, bcnt As Long)
Dim dx(7) As Integer, dy(7) As Integer
dx(0) = 1: dy(0) = 0 ' East
dx(1) = 1: dy(1) = 1 ' SE
dx(2) = 0: dy(2) = 1 ' South
dx(3) = -1: dy(3) = 1 ' SW
dx(4) = -1: dy(4) = 0 ' West
dx(5) = -1: dy(5) = -1 ' NW
dx(6) = 0: dy(6) = -1 ' North
dx(7) = 1: dy(7) = -1 ' NE
W = _Width(src)
H = _Height(src)
' create memory image for fast pixel reads
Dim imgMem As _MEM
imgMem = _MemImage(src)
' 1) find first boundary pixel
found = 0
For yy = 0 To H - 1
For xx = 0 To W - 1
If GetPix(imgMem, xx, yy, W) = targetColor Then
If IsBoundary(xx, yy, targetColor, imgMem, W, H, dx(), dy()) Then
sx = xx: sy = yy
found = -1
Exit For
End If
End If
Next
If found Then Exit For
Next
If found = 0 Then
bcnt = -1
Exit Sub
End If
' 2) preallocate storage and prevent overflow
maxPts = W * H
ReDim bx(maxPts - 1) As Integer
ReDim by(maxPts - 1) As Integer
' 3) initialize tracker
x = sx: y = sy
prevX = sx - 1: prevY = sy
startPrevX = prevX: startPrevY = prevY
idx = 0
Do
If idx >= maxPts Then Exit Do
bx(idx) = x
by(idx) = y
idx = idx + 1
' find direction to previous pixel
dirPrev = -1
For d = 0 To 7
If x + dx(d) = prevX And y + dy(d) = prevY Then
dirPrev = d
Exit For
End If
Next
If dirPrev = -1 Then dirPrev = 4
' search next boundary neighbor (clockwise from dirPrev+1)
foundNext = 0
For k = 1 To 8
i = (dirPrev + k) Mod 8
nx = x + dx(i)
ny = y + dy(i)
If nx >= 0 And nx < W And ny >= 0 And ny < H Then
If IsBoundary(nx, ny, targetColor, imgMem, W, H, dx(), dy()) Then
prevX = x: prevY = y
x = nx: y = ny
foundNext = -1
Exit For
End If
End If
Next
If foundNext = 0 Then Exit Do
Loop Until (x = sx And y = sy)
If idx = 0 Then
bcnt = -1
Else
bcnt = idx - 1
' shrink arrays to actual size
ReDim _Preserve bx(bcnt) As Integer
ReDim _Preserve by(bcnt) As Integer
End If
End Sub
' ---------------------------------------------
' Fast filled circle - SMcNeill gold standard
' (left as-is because it draws into screen)
' ---------------------------------------------
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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
Posts: 811
Threads: 128
Joined: Apr 2022
Reputation:
135
11-13-2025, 10:06 PM
(This post was last modified: 11-13-2025, 10:07 PM by Dav.)
Nice coding, Petr. The MEM version is so much faster - surprised just how much faster it runs.
- Dav
Posts: 513
Threads: 65
Joined: May 2022
Reputation:
83
@Dav
This speed is achieved outside of the _MEM function by modifying the DO loop in the DetectBorder SUB.
Posts: 513
Threads: 65
Joined: May 2022
Reputation:
83
This version detects all shapes on the screen and stores them as multiple separate boundaries.
In your own programs, you may need to filter these boundaries so that related inner and outer contours logically match.
Duplicate boundaries are removed when certain points falsely form a new, invalid contour.
After startup, a random mask shape is generated along with several intentional “holes” (black areas) to test detection of both outer and inner boundaries.
Text is also drawn so the program can detect interior contours as well (for example, the letter Q contains a hole, which represents an additional boundary).
The program then prints the number of detected boundaries and waits for a key press to highlight each boundary in a different color.
Code: (Select All)
' ---------------------------------------------------------
' Border detect 0.3 (QB64PE)
' - Detects all separate borders (outer shapes and holes)
' - Each border is stored separately using one large buffer
' - No duplicates (each border is found exactly once)
' ---------------------------------------------------------
Screen _NewImage(800, 600, 256)
Randomize Timer
Const TARGET_COLOR = 40
Const DRAW_COLOR = 2
Dim BigX As Integer
Dim BigY As Integer
Dim BorderStart As Long
Dim BorderLen As Long
Dim BordersCount As Long
Dim BigCount As Long
BigCount = -1
ReDim As Integer BigX(0), BigY(0)
ReDim As Long BorderStart(0), BorderLen(0)
BordersCount = 0
Dim Fnt As Long
Fnt = _LoadFont("arial.ttf", 110, "nonospace") 'You can replace this with your own font. It is used here only for border-detection testing.
Do
' Clear screen
Line (0, 0)-(799, 599), 15, BF
' Draw random mask areas
For F = 1 To 50
If Rnd * 10 > 4 Then p = -1 Else p = 1
x = 400 + Rnd * p * 300
y = 300 + Rnd * p * 200
r = (3 * F) * Rnd
CircleFill x, y, r, TARGET_COLOR
Line (400 - Rnd * 100, 300 - Rnd * 100)-(400 + Rnd * 100, 300 + Rnd * 100), TARGET_COLOR, BF
Next
For F = 1 To 20
If Rnd * 10 > 4 Then p = -1 Else p = 1
x = 400 + Rnd * p * 100
y = 300 + Rnd * p * 100
r = F * Rnd
CircleFill x, y, r, 0
Line (400 - Rnd * 10, 300 - Rnd * 10)-(400 + Rnd * 10, 300 + Rnd * 10), 0, BF
Next
_Font Fnt
Color TARGET_COLOR, 15
_PrintString (45, 450), "Q B 6 4 P E", 0
Color 0, 15
_Font 16
' Make _MEM snapshot
Dim srcMem As _MEM
srcMem = _MemImage(_Dest)
' Reset border buffers
BigCount = -1
ReDim BigX(0): ReDim BigY(0)
ReDim BorderStart(0): ReDim BorderLen(0)
BordersCount = 0
' Detect all borders
DetectAllBorders _Dest, TARGET_COLOR, BigX(), BigY(), BorderStart(), BorderLen(), BordersCount
' Draw borders
For bi = 0 To BordersCount - 1
Locate 1
Print "Detected borders: "; BordersCount - 1; " Press any key for border "; bi
Sleep
st = BorderStart(bi)
ln = BorderLen(bi)
c = 127 And (32 + bi)
For i = 0 To ln - 1
xi = BigX(st + i)
yi = BigY(st + i)
If xi >= 0 And xi < 800 And yi >= 0 And yi < 600 Then
Line (xi, yi)-(xi + 1, yi + 1), c, BF
End If
Next
Next
_Limit 2000
Loop Until _KeyDown(27)
' ---------------------------------------------------------
' GetPix - returns unsigned 0..255 pixel from _MEM
' ---------------------------------------------------------
Function GetPix~%% (mem As _MEM, x As Long, y As Long, w As Long)
GetPix = _MemGet(mem, mem.OFFSET + y * w + x, _Unsigned _Byte)
End Function
' ---------------------------------------------------------
' IsBoundary - returns -1 if pixel is border pixel
' ---------------------------------------------------------
Function IsBoundary (px As Long, py As Long, targetColor As Integer, mem As _MEM, W As Long, H As Long, dx() As Integer, dy() As Integer)
' Out of bounds = boundary
If px < 0 Or px >= W Or py < 0 Or py >= H Then
IsBoundary = -1
Exit Function
End If
' Pixel not match = not part of object = not boundary
If GetPix(mem, px, py, W) <> targetColor Then
IsBoundary = 0
Exit Function
End If
' 4-neighborhood test
' Boundary pixel if ANY direct neighbor differs
If px > 0 Then
If GetPix(mem, px - 1, py, W) <> targetColor Then
IsBoundary = -1: Exit Function
End If
Else
IsBoundary = -1: Exit Function
End If
If px < W - 1 Then
If GetPix(mem, px + 1, py, W) <> targetColor Then
IsBoundary = -1: Exit Function
End If
Else
IsBoundary = -1: Exit Function
End If
If py > 0 Then
If GetPix(mem, px, py - 1, W) <> targetColor Then
IsBoundary = -1: Exit Function
End If
Else
IsBoundary = -1: Exit Function
End If
If py < H - 1 Then
If GetPix(mem, px, py + 1, W) <> targetColor Then
IsBoundary = -1: Exit Function
End If
Else
IsBoundary = -1: Exit Function
End If
' Otherwise it's interior pixel
IsBoundary = 0
End Function
' ---------------------------------------------------------
' DetectBorderSingle - Moore-Neighbor border tracer
' ---------------------------------------------------------
Sub DetectBorderSingle (sx As Long, sy As Long, targetColor As Integer, imgMem As _MEM, W As Long, H As Long, dx() As Integer, dy() As Integer, bx() As Integer, by() As Integer, bcnt As Long)
maxPts = W * H
ReDim bx(maxPts - 1)
ReDim by(maxPts - 1)
x = sx: y = sy
prevX = sx - 1: prevY = sy
idx = 0
Do
If idx >= maxPts Then Exit Do
bx(idx) = x
by(idx) = y
idx = idx + 1
dirPrev = -1
For d = 0 To 7
If x + dx(d) = prevX And y + dy(d) = prevY Then
dirPrev = d
Exit For
End If
Next
If dirPrev = -1 Then dirPrev = 4
foundNext = 0
For k = 1 To 8
i = (dirPrev + k) Mod 8
nx = x + dx(i)
ny = y + dy(i)
If nx >= 0 And nx < W And ny >= 0 And ny < H Then
If IsBoundary(nx, ny, targetColor, imgMem, W, H, dx(), dy()) Then
prevX = x: prevY = y
x = nx: y = ny
foundNext = -1
Exit For
End If
End If
Next
If foundNext = 0 Then Exit Do
Loop Until (x = sx And y = sy)
If idx = 0 Then
bcnt = -1
Else
bcnt = idx - 1
ReDim _Preserve bx(bcnt)
ReDim _Preserve by(bcnt)
End If
End Sub
' ---------------------------------------------------------
' DetectAllBorders - prevents duplicate detection
' ---------------------------------------------------------
Sub DetectAllBorders (src As Long, targetColor As Integer, BigX() As Integer, BigY() As Integer, BorderStart() As Long, BorderLen() As Long, BordersCount As Long)
W = _Width(src)
H = _Height(src)
Dim imgMem As _MEM
imgMem = _MemImage(src)
ReDim visited(W - 1, H - 1) As _Unsigned _Byte
Dim dx(7) As Integer, dy(7) As Integer
dx(0) = 1: dy(0) = 0
dx(1) = 1: dy(1) = 1
dx(2) = 0: dy(2) = 1
dx(3) = -1: dy(3) = 1
dx(4) = -1: dy(4) = 0
dx(5) = -1: dy(5) = -1
dx(6) = 0: dy(6) = -1
dx(7) = 1: dy(7) = -1
BigCount = -1
ReDim BigX(0): ReDim BigY(0)
ReDim BorderStart(0): ReDim BorderLen(0)
Dim BorderIndex As Long
BorderIndex = -1
Dim bx(0) As Integer, by(0) As Integer
Dim bcnt As Long
For yy = 0 To H - 1
For xx = 0 To W - 1
If visited(xx, yy) = 0 Then
If GetPix(imgMem, xx, yy, W) = targetColor Then
If IsBoundary(xx, yy, targetColor, imgMem, W, H, dx(), dy()) Then
' NEW FIX:
' Start tracing only if at least one neighbor is not visited
okToStart = 0
For k = 0 To 7
nx = xx + dx(k)
ny = yy + dy(k)
If nx >= 0 And nx < W And ny >= 0 And ny < H Then
If visited(nx, ny) = 0 Then okToStart = -1
End If
Next
If okToStart = 0 Then GoTo skipTrace
' Trace this border
DetectBorderSingle xx, yy, targetColor, imgMem, W, H, dx(), dy(), bx(), by(), bcnt
If bcnt >= 0 Then
BorderIndex = BorderIndex + 1
ReDim _Preserve BorderStart(BorderIndex)
ReDim _Preserve BorderLen(BorderIndex)
startPos = BigCount + 1
For i = 0 To bcnt
If bx(i) >= 0 And bx(i) < W And by(i) >= 0 And by(i) < H Then
visited(bx(i), by(i)) = 1
BigCount = BigCount + 1
ReDim _Preserve BigX(BigCount)
ReDim _Preserve BigY(BigCount)
BigX(BigCount) = bx(i)
BigY(BigCount) = by(i)
End If
Next
BorderStart(BorderIndex) = startPos
BorderLen(BorderIndex) = BigCount - startPos + 1
End If
End If
End If
End If
skipTrace:
Next
Next
If BorderIndex >= 0 Then
BordersCount = BorderIndex + 1
Else
BordersCount = 0
End If
End Sub
' ---------------------------------------------------------
' CircleFill - SMcNeill gold routine
' ---------------------------------------------------------
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then
PSet (CX, CY), C
Exit Sub
End If
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
Posts: 4,692
Threads: 222
Joined: Apr 2022
Reputation:
322
This is getting interesting! Cool Petr!
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 360
Threads: 36
Joined: Mar 2023
Reputation:
28
That is some black magic there. Nicely done! +1
|
