I needed a fast way to trace the edge of a colored shape and return an array of points compatible with the XOJO DrawPolygon
and for those of you that also need something… here it is
SUB find_edge(pt as point_record)
Dim px As Integer
Dim py As Integer
Dim stepX As Integer
Dim stepY As Integer
Dim prevX As Integer
Dim prevY As Integer
Dim closedLoop As Boolean
Dim squarevalue As Integer
Dim startpoint As point_record
// getting the starting pixel
startPoint=pt
// move up until we have LEFT the area
//
pX=startPoint.x
pY=startPoint.y
do
pY=py-1
if py<0 then exit do
if not Color_Compare1(px,py) then exit do
loop
py=py+1
startpoint=Point_of(px,py)
// if we found a starting pixel we can begin
// closedLoop will be true once we traced the full contour
closedLoop=False
While Not closedLoop
// the core of the script is getting the 2x2 square value of each pixel
squareValue=getSquareValue(pX,pY)
Select Case squareValue
// going UP with these cases:
//+---+---+ +---+---+ +---+---+
//| 1 | | | 1 | | | 1 | |
//+---+---+ +---+---+ +---+---+
//| | | | 4 | | | 4 | 8 |
//+---+---+ +---+---+ +---+---+
Case 1,5,13
stepX=0
stepY=-1
//going DOWN with these cases:
//+---+---+ +---+---+ +---+---+
//| | | | | 2 | | 1 | 2 |
//+---+---+ +---+---+ +---+---+
//| | 8 | | | 8 | | | 8 |
//+---+---+ +---+---+ +---+---+
Case 8,10,11
stepX=0
stepY=1
//going LEFT with these cases:
//+---+---+ +---+---+ +---+---+
//| | | | | | | | 2 |
//+---+---+ +---+---+ +---+---+
//| 4 | | | 4 | 8 | | 4 | 8 |
//+---+---+ +---+---+ +---+---+
Case 4,12,14
stepX=-1
stepY=0
//going RIGHT with these cases:
//+---+---+ +---+---+ +---+---+
//| | 2 | | 1 | 2 | | 1 | 2 |
//+---+---+ +---+---+ +---+---+
//| | | | | | | 4 | |
//+---+---+ +---+---+ +---+---+
Case 2,3,7
stepX=1
stepY=0
Case 6
//special saddle point case 1:
//+---+---+
//| | 2 |
//+---+---+
//| 4 | |
//+---+---+
//going LEFT if coming from UP
///else going RIGHT
If (prevX=0 And prevY=-1) Then
stepX=-1
stepY=0
Else
stepX=1
stepY=0
End If
Case 9
// special saddle point case 2:
//+---+---+
//| 1 | |
//+---+---+
//| | 8 |
//+---+---+
//going UP if coming from RIGHT
//else going DOWN
If (prevX=1 And prevY=0) Then
stepX=0
stepY=-1
Else
stepX=0
stepY=1
End If
End Select
//
// moving onto next point
pX=px+stepX
pY=py+stepY
// saving edge point
theEDGE.append px
theEDGE.append py
prevX=stepX
prevY=stepY
// if we returned to the first point visited, the loop has finished
If (pX=startPoint.x And pY=startPoint.y) Then closedLoop=True
Wend
END SUBFUNCTION GetSquareValue(px as integer,py as integer) as integer
dim squareValue as integer
//checking the 2x2 pixel grid, assigning these values to each pixel, if not transparent
//+---+---+
//| 1 | 2 |
//+---+---+
//| 4 | 8 | <- current pixel (pX,pY)
//+---+---+
squareValue=0
// checking upper left pixel
if Color_Compare1(pX-1,pY-1) then squareValue=squarevalue+1
// checking upper pixel
if Color_Compare1(pX,pY-1) then squareValue=squarevalue+2
// checking left pixel
if Color_Compare1(pX-1,pY) then squareValue=squarevalue+4
// checking the pixel itself
if Color_Compare1(pX,pY) then squareValue=squarevalue+8
return squareValue
END FUNCTIONFUNCTION color_compare1(xx as integer,yy as integer) as boolean
Dim px As Color
If xx>=0 And yy>=0 And xx<work_area.Width Or yy<work_area.Height Then
px=temp_rs.Pixel(xx,yy)
Return (px=seed)
Else
Return False
End If
END FUNCTIONPoint_Record is a simple structure X as Integer,Y as integer
Here is the text code I call it with … modify as required… I am providing the code implementation… up to you to adapt appropriately
SUB Magic_Wand(pt as point_record) // pt is where the user clicked on the image (work_area)
#If Not DebugBuild
#pragma DisableBackgroundTasks
#pragma DisableBoundsChecking
#pragma DisableAutoWaitCursor
#pragma StackOverflowchecking False
#pragma NilObjectChecking False
#EndIf
//msgbox "Magic Wand not ready yet"
Dim x As Integer
Dim y As Integer
Dim work_rs As RGBSurface
Dim work_temp As picture
Dim ms As Double
ms=Microseconds
x=pt.x
y=pt.y
// transfer picture to a temp area
work_temp=New picture(work_area.Width,work_area.Height,32)
myDrawPicture work_temp.Graphics,work_area,0,0
temp_rs=work_temp.RGBSurface
work_rs=work_area.RGBSurface
seed=work_rs.Pixel(x,y)
//
//flood_fill x,y
Redim theEDGE(-1)
theEDGE.Append 0
Find_Edge Point_of(x,y)
work_temp.Graphics.ForeColor=&cff0000
work_temp.Graphics.DrawPolygon theEDGE
Dim f As FolderItem
f=SpecialFolder.Desktop.child("xyz.png")
work_temp.save(f,picture.SaveAsPNG)
MsgBox "Complete "+Str((Microseconds-ms)/1000000)