11-13-2025, 09:17 PM
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