11-13-2025, 07:46 PM
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