Buchempfehlung
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
"Der" Petzold, das über 1000 Seiten starke Standardwerk zum Win32-API - besonders nützlich u. a. bei der GUI-Programmierung in FreeBASIC! [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

Delaunay (Trianglation) versuch

Uploader:MitgliedEternal_Pain
Datum/Zeit:30.06.2012 13:09:58

'You have time to fetch a cup of coffee.'

'Token's
'OBJMODE (SUB Optimize)
#Define DeleteFragment    &h0001
#Define ExpandFragment    &h0002

'-----------------------------------------------------------------------------------------------------------------------------'
Function WhichSide(xp as Integer, yp as Integer, x1 as Integer, y1 as Integer, x2 as Integer, y2 as Integer) As Integer
    'Determines which side of a line the point (xp,yp) lies.
    'The line goes from (x1,y1) to (x2,y2)
    'Returns -1 for a point to the left
    '         0 for a point on the line
    '        +1 for a point to the right

    Dim equation As Double

    equation = ((yp - y1) * (x2 - x1)) - ((y2 - y1) * (xp - x1))

    If equation > 0 Then
        Function = -1
    ElseIf equation = 0 Then
        Function = 0
    Else
        Function = 1
    End If

End Function
    '--------------------------------------------------------------------------------------------------'
Function InCircle(byval xp as Integer, byval yp as Integer, byval x1 as Integer, byval y1 as Integer,_
                  byval x2 as Integer, byval y2 as Integer, byval x3 as Integer, byval y3 as Integer,_
                  byref xc as Double , byref yc as Double , byref r as Double) as Integer

    'Return TRUE if the point (xp,yp) lies inside the circumcircle
    'made up by points (x1,y1) (x2,y2) (x3,y3)
    'The circumcircle centre is returned in (xc,yc) and the radius r
    'NOTE: A point on the edge is inside the circumcircle

    Dim eps   As Double
    Dim m1    As Double
    Dim m2    As Double
    Dim mx1   As Double
    Dim mx2   As Double
    Dim my1   As Double
    Dim my2   As Double
    Dim dx    As Double
    Dim dy    As Double
    Dim rsqr  As Double
    Dim drsqr As Double

    eps = 0.000001

    Function = 0

    If Abs(y1 - y2) < eps And Abs(y2 - y3) < eps Then
        'Print "INCIRCUM - F - Points are coincident !!"
        Exit Function
    End If

    If Abs(y2 - y1) < eps Then
        m2 = -(x3 - x2) / (y3 - y2)
        mx2 = (x2 + x3) / 2
        my2 = (y2 + y3) / 2
        xc = (x2 + x1) / 2
        yc = m2 * (xc - mx2) + my2
    ElseIf Abs(y3 - y2) < eps Then
        m1 = -(x2 - x1) / (y2 - y1)
        mx1 = (x1 + x2) / 2
        my1 = (y1 + y2) / 2
        xc = (x3 + x2) / 2
        yc = m1 * (xc - mx1) + my1
    Else
        m1 = -(x2 - x1) / (y2 - y1)
        m2 = -(x3 - x2) / (y3 - y2)
        mx1 = (x1 + x2) / 2
        mx2 = (x2 + x3) / 2
        my1 = (y1 + y2) / 2
        my2 = (y2 + y3) / 2
        xc = (m1 * mx1 - m2 * mx2 + my2 - my1) / (m1 - m2)
        yc = m1 * (xc - mx1) + my1
    End If

    dx = x2 - xc
    dy = y2 - yc
    rsqr = dx * dx + dy * dy
    r = Sqr(rsqr)
    dx = xp - xc
    dy = yp - yc
    drsqr = dx * dx + dy * dy

    If drsqr <= rsqr Then Function = 1
End Function
'-----------------------------------------------------------------------------------------------------------------------------'



Type Vec2Int
    X as Integer
    Y as Integer
End Type

Type P3Index
    P1 as Integer
    P2 as Integer
    P3 as Integer
End Type

'------------------------------------------------------------------------------------'
Type C_RasterToVector
    Declare Constructor()
    Declare Destructor()

    Declare SUB LoadBMP(byval filename as String)
    tColor       as UInteger
    ImageWidth   as Integer
    ImageHeight  as Integer
    BMPImage     as any ptr


    OBJCount     as Integer
    OBJPCount    as Integer
    OBJPos       as Vec2Int ptr
    OBJMask      as byte ptr
    Directions(0 to 7) as Vec2Int

    Declare SUB Optimize(byval OBJMODE as Integer)
    Declare SUB NextPoint(byval XIn as Integer, byval YIn as Integer)

    VertexMap     as byte ptr
    VertexList    as Vec2Int ptr ptr
    VertexCount   as Integer ptr

    Declare SUB GenVertexLists()
    'private
    Declare Function GetOBJVertexMap(byval OBJX as Integer, byval OBJY as Integer) as byte ptr
    Declare Sub Triangulate(byval OBJN as Integer)'(nvert as Integer) as Integer
    TriangleList  as P3Index ptr ptr
    TriangleCount as Integer ptr
    DBGMSG        as String
End Type
'------------------------------------------------------------------------------------'
Constructor C_RasterToVector()
    Directions(0).X = -1 : Directions(0).Y =  0 ''Left
    Directions(1).X =  0 : Directions(1).Y = -1 ''Up
    Directions(2).X = +1 : Directions(2).Y =  0 ''Right
    Directions(3).X =  0 : Directions(3).Y = +1 ''Down
    Directions(4).X = +1 : Directions(4).Y = +1 ''RightDown
    Directions(5).X = -1 : Directions(5).Y = +1 ''LeftDown
    Directions(6).X = -1 : Directions(6).Y = -1 ''LeftUp
    Directions(7).X = +1 : Directions(7).Y = -1 ''RightUp

    OBJPCount = 0
    OBJPos    = allocate(sizeof(Vec2Int))

    DBGMSG = "Class: RasterToVector initiated."
End Constructor
'------------------------------------------------------------------------------------'
Destructor C_RasterToVector()
    If BMPImage  Then ImageDestroy(BMPImage)
    If VertexMap Then Delete[] VertexMap
    If OBJMask   Then Delete[] OBJMask
    If OBJPos    Then Delete[] OBJPos

    DBGMSG = "Class: RasterToVector finalized."
End Destructor

'------------------------------------------------------------------------------------'
Sub C_RasterToVector.LoadBMP(byval filename as String)
    Dim FF         as Integer = Freefile

    If Open (filename for BINARY as #FF) Then
        DBGMSG = "LoadBMP: File not found."
        Close #FF
    Else
        Get   #FF, 19, ImageWidth
        Get   #FF, 23, ImageHeight
        Close #FF

        BMPImage = Imagecreate(ImageWidth,ImageHeight)
        BLoad filename, BMPImage

        '
        OBJMask  = NEW byte[ImageWidth*ImageHeight]
    End If
End Sub
'------------------------------------------------------------------------------------'
Sub C_RasterToVector.NextPoint(byval XIn as Integer, byval YIn as Integer)
    Dim Temp   as byte ptr = NEW byte[ImageWidth * ImageHeight]
    Dim rColor as UInteger
    Dim PX     as Integer = XIn
    Dim PY     as Integer = YIn
    Dim NX     as Integer
    Dim NY     as Integer

    OBJMask[PX+(PY*ImageWidth)] =  1
    OBJPCount                  +=  1
    Temp[PX+(PY*ImageWidth)]    = -1

    Do
        PX = -1 : PY = -1
        For Y as Integer=0 to ImageHeight-1
        For X as Integer=0 to ImageWidth-1
            If (Temp[X+(Y*ImageWidth)] = -1) Then
                Temp[X+(Y*ImageWidth)] = -2
                PX = X : PY = Y

        For np as Integer=0 to 7
            NX=PX+Directions(np).X : NY=PY+Directions(np).Y
            If (NX > -1) andalso (NY > -1) andalso (NX < ImageWidth) andalso (NY < ImageWidth) Then
                rColor = Point(NX,NY,BMPImage)
                If (rColor <> tColor) andalso (OBJMask[NX+(NY*ImageWidth)] = 0) Then
                    If (Temp[NX+(NY*ImageWidth)]) = 0 Then

                        OBJMask[NX+(NY*ImageWidth)] =  1
                        OBJPCount                  +=  1
                        Temp[NX+(NY*ImageWidth)]    = -1

                        Pset (NX,NY),&hFFFFFF00

                    End If
                End If
            End If
        Next np

            End If
        Next X
        Next Y

        If PX = -1 Then Exit Do
    Loop
    Delete[] Temp
End Sub

'------------------------------------------------------------------------------------'
Function C_RasterToVector.GetOBJVertexMap(byval OBJX as Integer, byval OBJY as Integer) as byte ptr
    Dim OBJVertexMap    as byte ptr = NEW byte[ImageWidth*ImageHeight]
    Dim Temp            as byte ptr = NEW byte[ImageWidth*ImageHeight]
    Dim TempVertexCount as Integer
    Dim rColor          as UInteger
    Dim PX              as Integer
    Dim PY              as Integer
    Dim NX              as Integer
    Dim NY              as Integer

    OBJMask[PX+(PY*ImageWidth)] =  1
    Temp[PX+(PY*ImageWidth)]    = -1
    ?"HALLOOO??"
    Do
        PX = -1 : PY = -1
        For Y as Integer=OBJX to ImageHeight-1
        For X as Integer=OBJY to ImageWidth-1
            If (Temp[X+(Y*ImageWidth)] = -1) Then
                Temp[X+(Y*ImageWidth)] = -2
                PX = X : PY = Y

        For np as Integer=0 to 7
            NX=PX+Directions(np).X : NY=PY+Directions(np).Y
            If (NX > -1) andalso (NY > -1) andalso (NX < ImageWidth) andalso (NY < ImageWidth) Then
                rColor = Point(NX,NY,BMPImage)
                If (rColor <> tColor) andalso (VertexMap[NX+(NY*ImageWidth)] = 1) Then
                    If (Temp[NX+(NY*ImageWidth)]) = 0 Then

                        'OBJMask[NX+(NY*ImageWidth)] =  1
                        'TempVertexCount            +=  1
                        Temp[NX+(NY*ImageWidth)]    = -1
                        OBJVertexMap[NX+(NY*ImageWidth)] = 1
                    End If
                End If
            End If
        Next np

            End If
        Next X
        Next Y

        If PX = -1 Then Exit Do
    Loop
    Delete[] Temp

    Function = OBJVertexMap
End Function
'------------------------------------------------------------------------------------'
Sub C_RasterToVector.Optimize(byval OBJMODE as Integer)
    Dim Temp       as any ptr
    Dim rColor     as UInteger
    Dim LoopFlag   as Integer
    Dim DeleteFlag as Integer
    Dim NX         as Integer
    Dim NY         as Integer

    Do
        OBJPCount = 0 : LoopFlag = 0

        For Y as Integer=0 to ImageHeight-1
        For X as Integer=0 to ImageWidth-1
            rColor = Point(X,Y,BMPImage)
            If (rColor <> tColor) andalso (OBJMask[X+(Y*ImageWidth)] = 0) Then
                LoopFlag = 1
                NextPoint(X,Y)

                If (OBJPCount > 4) Then
                    Temp = ReAllocate(OBJPos, (OBJCount+1)*SizeOf(Vec2Int))
                    OBJPos = Temp
                    OBJPos[OBJCount].X = X
                    OBJPos[OBJCount].Y = Y
                    OBJCount += 1
                    Exit For,For
                Else'Fragment
                    If     (OBJMODE = ExpandFragment) Then
                        NY = IIF(Y > (ImageHeight/2), Y-1, Y+1)
                        NX = IIF(X > (ImageWidth/2), X-1, X+1)

                        OBJMask[NX+(Y*ImageWidth)] = 1
                        OBJMask[X+(NY*ImageWidth)] = 1
                        Pset (NX,Y),&hFF0000FF 'DBG
                        Pset (X,NY),&hFF0000FF 'DBG
                        Temp = ReAllocate(OBJPos, (OBJCount+1)*SizeOf(Vec2Int))
                        OBJPos = Temp
                        OBJPos[OBJCount].X = X
                        OBJPos[OBJCount].Y = Y
                        OBJCount += 1
                        Exit For,For
                    ElseIf (OBJMODE = DeleteFragment) Then
                        NX = X : NY = Y : DeleteFlag = 0
                        OBJMask[X+(Y*ImageWidth)]    = 0
                        PSet BMPImage,(NX,NY),tColor
                        Pset (NX,NY),0 ''DBG
                        Do
                            DeleteFlag = 0
                            For np as Integer=0 to 7
                                NX = NX+Directions(np).X : NY = NY+Directions(np).Y
                                If (NX > -1) andalso (NX < ImageWidth) andalso _
                                   (NY > -1) andalso (NY < ImageWidth) andalso _
                                   ( OBJMask[NX+(NY+ImageWidth)] = 1 ) Then

                                    PSet BMPImage,(NX,NY),tColor
                                    OBJMask[NX+(NY+ImageWidth)] = 0 : DeleteFlag = 1
                                    Pset (NX,NY),0 ''DBG
                                Else
                                    NX = X : NY = Y
                                End If
                            Next np
                        Loop While DeleteFlag
                        Exit For,For
                    End If
                End If
            End If
        Next X
        Next Y
    Loop While LoopFlag
End Sub
'------------------------------------------------------------------------------------'



Sub C_RasterToVector.Triangulate(byval OBJN as Integer)'(nvert as Integer) as Integer
    'Takes as input NVERT vertices in arrays Vertex()
    'Returned is a list of NTRI triangular faces in the array
    'Triangle(). These triangles are arranged in clockwise order.

    TriangleList[OBJN] = NEW P3Index[VertexCount[OBJN]*5]

    Dim Edges    as Integer ptr ptr
    Edges    = callocate(2*sizeOf(any ptr))
    Edges[0] = NEW Integer[VertexCount[OBJN]*15] 'MaxTriangles*3
    Edges[1] = NEW Integer[VertexCount[OBJN]*15] 'MaxTriangles*3
    Dim Complete as byte ptr
    Complete = NEW    byte[VertexCount[OBJN]*5] 'MaxTriangles
    Dim NEdge    as Integer
    Dim nvert    as Integer

    'Dim Complete(MaxTriangles) as Boolean
    'Dim Edges(2, MaxTriangles * 3) as Integer
    'Dim Nedge as Integer

    'For Super Triangle
    Dim xmin as Integer
    Dim xmax as Integer
    Dim ymin as Integer
    Dim ymax as Integer
    Dim xmid as Integer
    Dim ymid as Integer
    Dim dx   as Double
    Dim dy   as Double
    Dim dmax as Double

    'General Variables
    Dim i    as Integer
    Dim j    as Integer
    Dim k    as Integer
    Dim ntri as Integer
    Dim xc   as Double
    Dim yc   as Double
    Dim r    as Double
    Dim inc  as Integer

    'Find the maximum and minimum vertex bounds.
    'This is to allow calculation of the bounding triangle
    xmin = VertexList[OBJN][0].X
    ymin = VertexList[OBJN][0].Y
    xmax = xmin
    ymax = ymin
    For i= 0 To VertexCount[OBJN]-1
        If (VertexList[OBJN][i].X < xmin) Then xmin = VertexList[OBJN][i].X
        If (VertexList[OBJN][i].X > xmax) Then xmax = VertexList[OBJN][i].X
        If (VertexList[OBJN][i].Y < ymin) Then ymin = VertexList[OBJN][i].Y
        If (VertexList[OBJN][i].Y > ymax) Then ymax = VertexList[OBJN][i].Y
    Next i

    dx = xmax - xmin
    dy = ymax - ymin

    If dx > dy Then
        dmax = dx
    Else
        dmax = dy
    End If

    xmid = (xmax + xmin) / 2
    ymid = (ymax + ymin) / 2

    'Set up the supertriangle
    'This is a triangle which encompasses all the sample points.
    'The supertriangle coordinates are added to the end of the
    'vertex list. The supertriangle is the first triangle in
    'the triangle list.

    VertexList[OBJN][VertexCount[OBJN]+0].X = xmid - 2 * dmax
    VertexList[OBJN][VertexCount[OBJN]+0].Y = ymid - dmax

    VertexList[OBJN][VertexCount[OBJN]+1].X = xmid
    VertexList[OBJN][VertexCount[OBJN]+1].Y = ymid + 2 * dmax

    VertexList[OBJN][VertexCount[OBJN]+2].X = xmid + 2 * dmax
    VertexList[OBJN][VertexCount[OBJN]+2].Y = ymid - dmax

    'Vertex(nvert + 1).x = xmid - 2 * dmax
    'Vertex(nvert + 1).y = ymid - dmax
    'Vertex(nvert + 2).x = xmid
    'Vertex(nvert + 2).y = ymid + 2 * dmax
    'Vertex(nvert + 3).x = xmid + 2 * dmax
    'Vertex(nvert + 3).y = ymid - dmax

    TriangleList[OBJN][0].P1 = VertexCount[OBJN]-1 + 0
    TriangleList[OBJN][0].P2 = VertexCount[OBJN]-1 + 1
    TriangleList[OBJN][0].P3 = VertexCount[OBJN]-1 + 2

    'Triangle(1).vv0 = nvert + 1
    'Triangle(1).vv1 = nvert + 2
    'Triangle(1).vv2 = nvert + 3

    Complete[0] = 0'False
    ntri = 1

    'Include each point one at a time into the existing mesh
    For i= 0 To VertexCount[OBJN]-1
        'locate 2,1:?ntri,i
        NEdge = 0
        'Set up the edge buffer.
        'If the point (Vertex(i).x,Vertex(i).y) lies inside the circumcircle then the
        'three edges of that triangle are added to the edge buffer.
        j = -1
        Do
            j = j + 1
            If (Complete[j] <> 0) Then
                inc = InCircle(VertexList[OBJN][i].X, VertexList[OBJN][i].Y, _
                               VertexList[OBJN][TriangleList[OBJN][j].P1].X, _
                               VertexList[OBJN][TriangleList[OBJN][j].P1].Y, _
                               VertexList[OBJN][TriangleList[OBJN][j].P2].X, _
                               VertexList[OBJN][TriangleList[OBJN][j].P2].Y, _
                               VertexList[OBJN][TriangleList[OBJN][j].P3].X, _
                               VertexList[OBJN][TriangleList[OBJN][j].P3].Y, xc, yc, r)

                               'Vertex(Triangle(j).vv0).y, Vertex(Triangle(j).vv1).x, Vertex(Triangle(j).vv1).y, Vertex(Triangle(j).vv2).x, Vertex(Triangle(j).vv2).y, xc, yc, r)
                'Include this if points are sorted by X
                If ((xc + r) < VertexList[OBJN][i].X) Then 'Vertex(i).x Then
                    Complete[j] = 1
                Else
                    If inc Then
                        Edges[0][NEdge+0] = TriangleList[OBJN][j].P1
                        Edges[1][NEdge+0] = TriangleList[OBJN][j].P2
                        Edges[0][NEdge+1] = TriangleList[OBJN][j].P2
                        Edges[1][NEdge+1] = TriangleList[OBJN][j].P3
                        Edges[0][NEdge+2] = TriangleList[OBJN][j].P3
                        Edges[1][NEdge+2] = TriangleList[OBJN][j].P1
                        'Edges(1, Nedge + 1) = Triangle(j).vv0
                        'Edges(2, Nedge + 1) = Triangle(j).vv1
                        'Edges(1, Nedge + 2) = Triangle(j).vv1
                        'Edges(2, Nedge + 2) = Triangle(j).vv2
                        'Edges(1, Nedge + 3) = Triangle(j).vv2
                        'Edges(2, Nedge + 3) = Triangle(j).vv0
                        NEdge = NEdge + 3

                        TriangleList[OBJN][j].P1 = TriangleList[OBJN][ntri].P1
                        TriangleList[OBJN][j].P2 = TriangleList[OBJN][ntri].P2
                        TriangleList[OBJN][j].P3 = TriangleList[OBJN][ntri].P3

                        'Triangle(j).vv0 = Triangle(ntri).vv0
                        'Triangle(j).vv1 = Triangle(ntri).vv1
                        'Triangle(j).vv2 = Triangle(ntri).vv2

                        Complete[j] = Complete[ntri]
                        j -= 1
                        ntri -= 1
                    End If
                End If
            End If
        Loop While j < ntri

        'Tag multiple edges
        'Note: if all triangles are specified anticlockwise then all
        'interior edges are opposite pointing in direction.
        For j= 0 To NEdge-2
            'If Not Edges(1, j) = 0 And Not Edges(2, j) = 0 Then
            If (Edges[0][j] <> 0) andalso (Edges[1][j] <> 0) Then
                For k as Integer =j+1 To NEdge-1
                    'If Not Edges(1, k) = 0 And Not Edges(2, k) = 0 Then
                    If (Edges[0][k] <> 0) andalso (Edges[1][k] <> 0) Then
                        'If Edges(1, j) = Edges(2, k) Then
                        If (Edges[0][j] = Edges[1][k]) Then
                            'If Edges(2, j) = Edges(1, k) Then
                            If (Edges[1][j] = Edges[0][k]) Then
                                Edges[0][j] = 0
                                Edges[1][j] = 0
                                Edges[0][k] = 0
                                Edges[1][k] = 0

                                'Edges(1, j) = 0
                                'Edges(2, j) = 0
                                'Edges(1, k) = 0
                                'Edges(2, k) = 0
                            End If
                        End If
                    End If
                Next k
            End If
        Next j

        'Form new triangles for the current point
        'Skipping over any tagged edges.
        'All edges are arranged in clockwise order.
        For j as Integer=0 To NEdge-1
                'If Not Edges(1, j) = 0 And Not Edges(2, j) = 0 Then
                If (Edges[0][j] <> 0) andalso (Edges[1][j] <> 0) Then
                    ntri = ntri + 1

                    TriangleList[OBJN][ntri].P1 = Edges[0][j]
                    TriangleList[OBJN][ntri].P2 = Edges[1][j]
                    TriangleList[OBJN][ntri].P3 = i

                    'Triangle(ntri).vv0 = Edges(1, j)
                    'Triangle(ntri).vv1 = Edges(2, j)
                    'Triangle(ntri).vv2 = i

                    Complete[ntri] = 0
                End If
        Next j

    Next i

    'Remove triangles with supertriangle vertices
    'These are triangles which have a vertex number greater than NVERT

    i = -1
    Do
        i = i + 1
        If (TriangleList[OBJN][i].P1 > (VertexCount[OBJN]-1)) or _
           (TriangleList[OBJN][i].P2 > (VertexCount[OBJN]-1)) or _
           (TriangleList[OBJN][i].P3 > (VertexCount[OBJN]-1)) Then

        'If Triangle(i).vv0 > nvert Or Triangle(i).vv1 > nvert Or Triangle(i).vv2 > nvert Then
            TriangleList[OBJN][i].P1 = TriangleList[OBJN][ntri].P1
            TriangleList[OBJN][i].P2 = TriangleList[OBJN][ntri].P2
            TriangleList[OBJN][i].P3 = TriangleList[OBJN][ntri].P3

            'Triangle(i).vv0 = Triangle(ntri).vv0
            'Triangle(i).vv1 = Triangle(ntri).vv1
            'Triangle(i).vv2 = Triangle(ntri).vv2
            i -= 1
            ntri -= 1
        End If
    Loop While i < ntri
    ?ntri
    TriangleCount[OBJN] = ntri
    'Triangulate = ntri
End Sub



'---------------------------------'





Sub C_RasterToVector.GenVertexLists()
    VertexMap = NEW byte[ImageWidth*ImageHeight]
    Dim TempVertexCount as Integer
    Dim VertexCountALL  as Integer
    Dim OBJVertexMap    as byte ptr

    '---------------------------------------------'
    Dim NX                  as Integer
    Dim NY                  as Integer

    Dim TracePos            as Vec2Int
    Dim TraceStep           as Integer =  2
    Dim TraceSize           as Integer =  6
    Dim YDirection          as Integer = +1
    Dim CDirections(0 to 7) as Vec2Int = { Type( +1,  0),_ 'Right
                                           Type( +1, +1),_ 'RightDown
                                           Type(  0, +1),_ 'Down
                                           Type( -1, +1),_ 'LeftDown
                                           Type( -1,  0),_ 'Left
                                           Type( -1, -1),_ 'LeftUp
                                           Type(  0, -1),_ 'Up
                                           Type( +1, -1) } 'RightUp
    '---------------------------------------------'

    For Y as Integer=0 to ImageHeight-1 step 2
    For X as Integer=0 to ImageWidth-1 step 2
        If (Point(X,Y,BMPImage) <> tColor) Then
            VertexMap[X+(Y*ImageWidth)]=1
        End If
    Next X
    Next Y

    VertexList  = allocate(OBJCount*SizeOf(any ptr))
    VertexCount = NEW Integer[OBJCount]

    TriangleList  = allocate(OBJCount*SizeOf(any ptr))
    TriangleCount = NEW Integer[OBJCount]

    For O as Integer=0 to OBJCount-1
        OBJVertexMap = GetOBJVertexMap(OBJPos[O].X,OBJPos[O].Y)
        'Count Object Vertices
        For cy as Integer=0 to ImageHeight-1
        For cx as Integer=0 to ImageWidth-1
            If (OBJVertexMap[cx+(cy*ImageWidth)] = 1) Then VertexCount[O] += 1
        Next cx
        Next cy

        VertexList[O]   = NEW Vec2Int[VertexCount[O]+5]
        TempVertexCount = 0

        'read vertices
        locate 4,1:?VertexCount[O]
    '---------------------------------------------'
    Do
        NX = TracePos.X : NY = TracePos.Y

        For X as Integer=0 to TraceSize
        For Y as Integer=0 to TraceSize
            NX = TracePos.X + X : NY = TracePos.Y + Y

            If (NX > -1) and (NY > -1) and (NX < ImageWidth) and (NY < ImageHeight) Then

                If (OBJVertexMap[NX+(NY*ImageWidth)] = 1) Then
                    OBJVertexMap[NX+(NY*ImageWidth)] = -1

                    VertexList[O][TempVertexCount].X = NX : VertexList[O][TempVertexCount].Y = NY
                    TempVertexCount += 1

                    For D as Integer=0 to 7
                        NX = TracePos.X+X : NY = TracePos.Y+Y
                        For L as Integer=0 to 2
                            NX += CDirections(D).X : NY += CDirections(D).Y

                            If (NX > -1) and (NY > -1) and (NX < ImageWidth) and (NY < ImageHeight) Then
                                If (OBJVertexMap[NX+(NY*ImageWidth)] = 1) Then
                                    OBJVertexMap[NX+(NY*ImageWidth)] = -1

                                    VertexList[O][TempVertexCount].X = NX : VertexList[O][TempVertexCount].Y = NY
                                    TempVertexCount += 1

                                End If
                            End If
                        Next L
                    Next D
                End If
            End If
        Next Y
        Next X

        TracePos.Y += (YDirection * TraceStep)
        If (TracePos.Y > (ImageHeight-1)) Then
            TracePos.Y = ImageHeight-1
            YDirection = -1 : TracePos.X += TraceStep
        ElseIf (TracePos.Y < 0) Then
            TracePos.Y = 0
            YDirection = +1 : TracePos.X += TraceStep
        End If
        If (TracePos.X > (ImageWidth-1)) Then TracePos.X = ImageWidth-1

        'locate 5,1:?TempVertexCount
    Loop until ( (TracePos.X=(ImageWidth-1)) and (TracePos.Y=(ImageHeight-1)) )
    '---------------------------------------------'
    'Triangulate:
    Triangulate(O)

    ?TriangleCount[O]
    For t as Integer=0 to TriangleCount[O]-1

        ?1,VertexList[O][TriangleList[O][t].P1].X
        line ( VertexList[O][TriangleList[O][t].P1].X, VertexList[O][TriangleList[O][t].P1].Y ) -_
             ( VertexList[O][TriangleList[O][t].P2].X, VertexList[O][TriangleList[O][t].P2].Y ), &hFFFF0000

        line ( VertexList[O][TriangleList[O][t].P2].X, VertexList[O][TriangleList[O][t].P2].Y ) -_
             ( VertexList[O][TriangleList[O][t].P3].X, VertexList[O][TriangleList[O][t].P3].Y ), &hFFFF0000

        line ( VertexList[O][TriangleList[O][t].P3].X, VertexList[O][TriangleList[O][t].P3].Y ) -_
             ( VertexList[O][TriangleList[O][t].P1].X, VertexList[O][TriangleList[O][t].P1].Y ), &hFFFF0000
    Next t

    sleep
    '---------------------------------------------'
        Delete[] OBJVertexMap
        Delete[] VertexList[O]
    Next O

    Delete[] VertexMap
    Deallocate VertexList
End Sub






Screen 19,32
Dim test as C_RasterToVector
test.tColor  = &hFF000000
test.LoadBMP("htest.bmp")
Put (0,0),test.BMPImage,pset
test.Optimize(ExpandFragment)
'?test.OBJCount
test.GenVertexLists()

sleep