Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

BMP to OBJ Kanten optimieren

 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC.
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 27.06.2012, 00:52    Titel: BMP to OBJ Kanten optimieren Antworten mit Zitat

Ich hatte vor einiger Zeit mal eine Idee die ich gerade mal eben getestet habe:
Man nehme eine Bitmap (am besten zwei farbig) und lasse sie 'rastern' und in ein 3D OBJ
konvertieren

Das ganze klappt eiegntlich auch ganz gut (wenn man mal von der grösse meines Ergebnisses grad
absieht, aber das optimiere ich später noch happy)

Nun bleibt ein pixel aber nunmal ein pixel und das ganze wirkt noch nicht so recht rund (eher eckig)

ich brauch ein ansatz zum 'nächsgelegene kante finden' um die sache optisch ein wenig zu verfeinern




Code:

#Include "GL/gl.bi"


const TransparentColor = &hFF000000

'' BMP to OBJ

Screenres 100,100,32,,-1

Type texcoord
    U as single
    V as single
End Type

Type vertex
    X as single
    Y as single
    Z as single
End Type

Type mesh
    VCount    as Integer
    Vertices  as vertex ptr
    TexCoords as texcoord ptr
    ICount    as Integer
    Index     as Integer PTR
End Type

Function LoadBMP(filename as string) as any ptr
    Dim ff as Integer = Freefile
    Dim iWidth  as Integer
    Dim iHeight as Integer
   
    Open filename For Binary As #ff
    Get #ff, 19, iWidth  'Breite aus der BMP-Datei holen
    Get #ff, 23, iHeight 'Höhe aus der BMP-Datei holen
    Close #ff   
   
    Dim Image as any ptr = Imagecreate(iWidth,iHeight)
    BLoad filename,Image
   
    Return Image
End Function

Function CalcMesh(filename as string) as mesh ptr
    Dim Image as any ptr = LoadBMP(filename)
    Dim iWidth  as Integer
    Dim iHeight as Integer
    Dim rColor  as Integer
    Imageinfo Image,iWidth,IHeight
   
    Dim BaseVertex  (0 to 3) as vertex
    Dim BaseTexCoord(0 to 3) as texcoord
   
    BaseVertex(0)=type(-0.1f, +0.1f, 0.0f)
    BaseVertex(1)=type(+0.1f, +0.1f, 0.0f)
    BaseVertex(2)=type(+0.1f, -0.1f, 0.0f)
    BaseVertex(3)=type(-0.1f, -0.1f, 0.0f)
   
    BaseTexCoord(0)=type(0.0f,1.0f)
    BaseTexCoord(1)=type(1.0f,1.0f)
    BaseTexCoord(2)=type(1.0f,0.0f)
    BaseTexCoord(3)=type(0.0f,0.0f)
   
    Dim ObjStartX as Single
    Dim ObjStartY as Single
   
    ObjStartX = -((iWidth/2) * 0.2)
    ObjStartY = ((iHeight/2) * 0.2)
   
    Dim meshdata as mesh ptr = NEW mesh
   
    for y as integer=0 to iHeight-1
    For x as integer=0 to iWidth-1
        rColor=Point(x,y,Image)
        If rColor<>TransparentColor Then
            meshdata -> VCount += 4
            meshdata -> ICount += 6
        End If
    next x
    next y

    meshdata -> Vertices  = NEW vertex[meshdata -> VCount]
    meshdata -> TexCoords = NEW texcoord[meshdata -> VCount]
    meshdata -> Index     = NEW Integer[meshdata -> ICount]
   
    Dim vPos as Integer = 0
    Dim iPos as Integer = 0
   
    for y as integer=0 to iHeight-1
    for x as integer=0 to iWidth-1
        rColor=Point(x,y,Image)

        If rColor<>TransparentColor Then
            meshdata -> Vertices[vPos+0].X = ObjStartX + (x * 0.2) + BaseVertex(0).X
            meshdata -> Vertices[vPos+0].Y = ObjStartY - (y * 0.2) + BaseVertex(0).Y
            meshdata -> Vertices[vPos+0].Z = BaseVertex(0).Z
            meshdata -> TexCoords[vPos+0] = BaseTexCoord(0)

            meshdata -> Vertices[vPos+1].X = ObjStartX + (x * 0.2) + BaseVertex(1).X
            meshdata -> Vertices[vPos+1].Y = ObjStartY - (y * 0.2) + BaseVertex(1).Y
            meshdata -> Vertices[vPos+1].Z = BaseVertex(1).Z
            meshdata -> TexCoords[vPos+1] = BaseTexCoord(1)
           
            meshdata -> Vertices[vPos+2].X = ObjStartX + (x * 0.2) + BaseVertex(2).X
            meshdata -> Vertices[vPos+2].Y = ObjStartY - (y * 0.2) + BaseVertex(2).Y
            meshdata -> Vertices[vPos+2].Z = BaseVertex(2).Z
            meshdata -> TexCoords[vPos+2] = BaseTexCoord(2)
           
            meshdata -> Vertices[vPos+3].X = ObjStartX + (x * 0.2) + BaseVertex(3).X
            meshdata -> Vertices[vPos+3].Y = ObjStartY - (y * 0.2) + BaseVertex(3).Y
            meshdata -> Vertices[vPos+3].Z = BaseVertex(3).Z
            meshdata -> TexCoords[vPos+3] = BaseTexCoord(3)
           
            meshdata -> Index[iPos+0] = 1+vPos+0
            meshdata -> Index[iPos+1] = 1+vPos+1
            meshdata -> Index[iPos+2] = 1+vPos+2
            meshdata -> Index[iPos+3] = 1+vPos+2
            meshdata -> Index[iPos+4] = 1+vPos+3
            meshdata -> Index[iPos+5] = 1+vPos+0
           
            vPos += 4 : iPos += 6
        else
        End If
       
    next x
    next y
   
    Return meshdata
End Function
   
   
Sub saveobj(filename as string, meshdata as mesh ptr)
    dim ff as integer = freefile
    dim facestring as string
    open filename for output as #ff
   
    print #ff,"#vertices: "+str(meshdata -> VCount)
    for l as integer=0 to (meshdata -> VCount)-1
        print #ff,"v ";meshdata -> Vertices[l].X;" ";meshdata -> Vertices[l].Y;" ";meshdata -> Vertices[l].Z
    next l
   
    print #ff,"#texcoords: "+str(meshdata -> VCount)
    for l as integer=0 to (meshdata -> VCount)-1
        print #ff,"vt ";meshdata -> TexCoords[l].U;" ";meshdata -> TexCoords[l].V
    next l
   
    print #ff,"#faces: "+str((meshdata -> ICount)/3)
    for l as integer=0 to (meshdata -> ICount)-1 step 3
        facestring="f "
        facestring+=str(meshdata -> Index[l+0])+"/"+str(meshdata -> Index[l+0])
        facestring+=" "
        facestring+=str(meshdata -> Index[l+1])+"/"+str(meshdata -> Index[l+1])
        facestring+=" "
        facestring+=str(meshdata -> Index[l+2])+"/"+str(meshdata -> Index[l+2])
        Print #ff,facestring
    next l
   
    close #ff
End Sub

   
Dim objmesh as mesh ptr
objmesh = CalcMesh("htest.bmp")
saveobj("htest.obj",objmesh)


''Freemem:
objmesh -> ICount = 0
objmesh -> VCount = 0
delete[] objmesh -> Vertices
delete[] objmesh -> TexCoords
delete[] objmesh -> Index
delete objmesh

_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1766
Wohnort: [JN58JR] DeltaLabs.de

BeitragVerfasst am: 27.06.2012, 10:06    Titel: Antworten mit Zitat

Wandel das Bild in eine Vektorgrafik um. Damit hast du keine Probleme mehr diesbezüglich, und du kannst sie beliebig skalieren.


Alternativ könntest du auch folgendermassen vorgehen:
Du suchst dir irgend einen Punkt auf der Grafik, welcher zum Bildinhalt gehört. Idealer weise Punkt für Punkt von LO nach RU absuchen.

Anschliessend "umläufst" du diese Bildkante und erzeugst um Gefällemodel des Umlaufs. Dieses kannst du nutzen, um Splines zu erzeugen welche bei stetigem anstieg / abfall gleichbleibend dem verlauf forlgen. Bei Änderungen der Steigrate kann ein weiterer Punkt hinzugefügt werden.

Das ganze wird solange wiederholt, bis alle Kanten erfasst wurden.
Zu guter letzt noch die Füllbereiche wieder herstellen.


MfG
TPM
_________________
[ WebFBC ][ OPS ][ DeltaLab's ][ ToOFlo ][ BGB-Movie ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 27.06.2012, 15:11    Titel: Antworten mit Zitat

Ich hab erstmal versucht einfach nur die kante entlang zu gehen ( die aussenlinien/punkte hab ich komplett) schein da aber ein komplett schlechten ansatz zu verfolgen:

Code:

const outline_left     = &b00000001
const outline_right    = &b00000010
const outline_up       = &b00000100
const outline_down     = &b00001000

const outline_trileft  = &b00010000
const outline_triright = &b00100000
const outline_triup    = &b01000000
const outline_tridown  = &b10000000

Type Vec2Int
    X as Integer
    Y as Integer
End Type

Type Class_OBJGen
    TColor           as UInteger
   
    ImageWidth       as Integer
    ImageHeight      as Integer
   
    BMPImage         as any ptr
    Outlines         as any ptr
   
    vertices         as Integer
    vIndex           as Integer ptr
   
    Declare Sub      LoadBMP(byval BMPfile as String)
    Declare Sub      scanOutlines()
    Declare Sub      triOutlines()
    Declare Function findOutline(byval OutlineType as Integer, byval sx as Integer, byval sy as Integer) as Vec2Int
    Declare Function checkTri(byval P1 as Vec2Int, byval P2 as Vec2Int, byval P3 as Vec2Int) as Integer
   
    Declare Sub      SetIndex(byval posx as Integer, byval posy as Integer, byval Value as Integer)
    Declare Function GetIndex(byval posx as Integer, byval posy as Integer) as Integer
    Declare Function NextType(byval NType as UInteger) as UInteger   
    Declare Function TriType(byval NType as UInteger) as UInteger   
    Declare Function BitNum(byval NType as UInteger) as UInteger   
   
    DBGMSG           as String
End Type

Sub Class_OBJGen.SetIndex(byval posx as Integer, byval posy as Integer, byval Value as Integer)
    If vIndex Then vIndex[posx+(posy*ImageWidth)]=Value
End Sub

Function Class_OBJGen.GetIndex(byval posx as Integer, byval posy as Integer) as Integer
    If vIndex Then Return vIndex[posx+(posy*ImageWidth)]
    Return -1
End Function
   

Sub Class_OBJGen.LoadBMP(byval BMPfile as String)
    Dim FF as Integer = Freefile
    If Open (BMPfile for BINARY as #FF) Then
        DBGMSG = "File not Found"
        close #FF
    Else
        Get #FF, 19, ImageWidth 
        Get #FF, 23, ImageHeight
        Close #FF
       
        'Load BMP
        BMPImage = Imagecreate(ImageWidth,ImageHeight)
        Outlines = Imagecreate(ImageWidth,ImageHeight)
        BLoad BMPfile,BMPImage       
        'create Index
        vIndex = NEW UInteger[ImageWidth*ImageHeight]
        'clear Index
        For Y as Integer=0 to ImageHeight-1
        For X as Integer=0 to ImageWidth-1
            SetIndex(X,Y,-1)
            Pset Outlines,(X,Y),&h00000000
        Next X
        Next Y
    End If
End Sub

Sub Class_OBJGen.scanOutlines()
    Dim uptodown    as ubyte ptr = NEW ubyte [ImageWidth*ImageHeight]
    Dim downtoup    as ubyte ptr = NEW ubyte [ImageWidth*ImageHeight]
    Dim lefttoright as ubyte ptr = NEW ubyte [ImageWidth*ImageHeight]
    Dim righttoleft as ubyte ptr = NEW ubyte [ImageWidth*ImageHeight]
   
    Dim rColor      as Integer
    Dim wColor      as Integer   
   
    Dim OpenFlag    as Integer
   
    'uptodown:
    For X as Integer=0 to ImageWidth-1
        OpenFlag = 0
    For Y as Integer=0 to ImageHeight-1
        rColor = Point(X,Y,BMPImage)
        If rColor<>TColor Then
            If (OpenFlag = 0) Then
               
                uptodown[X+(Y*ImageWidth)]=1
               
                If (Y+1)<ImageHeight Then
                    rColor = Point(X,Y+1,BMPImage)
                    If rColor<>TColor Then OpenFlag = 1
                End If
            End If
        Else
            If (OpenFlag = 1) Then
                OpenFlag = 0
            End If
        End If
    Next Y
    Next X
       
    'downtoup:
    For X as Integer=0 to ImageWidth-1
        OpenFlag = 0
    For Y as Integer=ImageHeight-1 to 0 step -1
        rColor = Point(X,Y,BMPImage)
        If rColor<>TColor Then
            If (OpenFlag = 0) Then
               
                downtoup[X+(Y*ImageWidth)]=1
               
                If (Y-1)>-1 Then
                    rColor = Point(X,Y-1,BMPImage)
                    If rColor<>TColor Then OpenFlag = 1
                End If
            End If
        Else
            If (OpenFlag = 1) Then
                OpenFlag = 0
            End If
        End If
    Next Y
    Next X

    'lefttoright:
    For Y as Integer=0 to ImageHeight-1
        OpenFlag = 0
    For X as Integer=0 to ImageWidth-1
        rColor = Point(X,Y,BMPImage)
        If rColor<>TColor Then
            If (OpenFlag = 0) Then
               
                lefttoright[X+(Y*ImageWidth)]=1
               
                If (X+1)<ImageWidth Then
                    rColor = Point(X+1,Y,BMPImage)
                    If rColor<>TColor Then OpenFlag = 1
                End If
            End If
        Else
            If (OpenFlag = 1) Then
                OpenFlag = 0
            End If
        End If
    Next X
    Next Y
       
    'righttoleft:
    For Y as Integer=0 to ImageHeight-1
        OpenFlag = 0
    For X as Integer=ImageWidth-1 to 0 step -1
        rColor = Point(X,Y,BMPImage)
        If rColor<>TColor Then
            If (OpenFlag = 0) Then
               
                righttoleft[X+(Y*ImageWidth)]=1
               
                If (X-1)>-1 Then
                    rColor = Point(X-1,Y,BMPImage)
                    If rColor<>TColor Then OpenFlag = 1
                End If
            End If
        Else
            If (OpenFlag = 1) Then
                OpenFlag = 0
            End If
        End If
    Next X
    Next Y
   
    '"write" Outline's
    For Y as Integer=0 to ImageHeight-1
    For X as Integer=0 to ImageWidth-1
        wColor = &h00000000
        If uptodown   [X+(Y*ImageWidth)] Then wColor = wColor OR Outline_up
        If Downtoup   [X+(Y*ImageWidth)] Then wColor = wColor OR Outline_down
        If lefttoright[X+(Y*ImageWidth)] Then wColor = wColor OR Outline_left
        If righttoleft[X+(Y*ImageWidth)] Then wColor = wColor OR Outline_right
        PSet Outlines,(X,Y),wColor
    Next X
    Next Y

    Delete[] uptodown
    Delete[] downtoup
    Delete[] lefttoright
    Delete[] righttoleft
End Sub


Function Class_OBJGen.findOutline(byval OutlineType as Integer, byval ix as Integer, byval iy as Integer) as Vec2Int
    Dim Outline_Point as Vec2Int = Type(-1,-1)
    Dim rColor        as Integer
    Dim sx            as Integer = ix
    Dim sy            as Integer = iy
   
    If (OutlineType = outline_up) Then
        sy -= 5 : If sy<0 then sy=0
        For Y as Integer=sy to ImageHeight-1
            rColor = Point (sx,Y,Outlines)
            If (rColor and OutlineType) Then
                Outline_Point = Type (sx,Y)
                Return Outline_Point
            End If
        Next Y
    ElseIf (OutlineType = outline_down) Then
        sy += 5 : If sy > (ImageHeight-1) Then sy = ImageHeight-1
        For Y as Integer=ImageHeight-1 to sy step -1
            rColor = Point (sx,Y,Outlines)
            If (rColor and OutlineType) Then
                Outline_Point = Type (sx,Y)
                Return Outline_Point
            End If
        Next Y
    ElseIf (OutlineType = outline_left) Then
        sx -= 5 : If sx<0 Then sx=0
        For X as Integer=sx to ImageWidth-1
            rColor = Point (X,sy,Outlines)
            If (rColor and OutlineType) Then
                Outline_Point = Type (X,sy)
                Return Outline_Point
            End If
        Next X
    ElseIf (OutlineType = outline_right) Then
        sx += 5 : If sx > (ImageWidth-1) Then sx=ImageWidth-1
        For X as Integer=ImageWidth-1 to sx step -1
            rColor = Point (X,sy,Outlines)
            If (rColor and OutlineType) Then
                Outline_Point = Type (X,sy)
                Return Outline_Point
            End If
        Next X
    End If
   
    Return Outline_Point
End Function

   
Function Class_OBJGen.checkTri(byval P1 as Vec2Int, byval P2 as Vec2Int, byval P3 as Vec2Int) as Integer
    Dim minX as Integer = IIF(P1.X<P2.X, IIF(P1.X<P3.X, P1.X, P3.X), IIF(P2.X<P3.X, P2.X, P3.X))
    Dim minY as Integer = IIF(P1.Y<P2.Y, IIF(P1.Y<P3.Y, P1.Y, P3.Y), IIF(P2.Y<P3.Y, P2.Y, P3.Y))
    Dim maxX as Integer = IIF(P1.X>P2.X, IIF(P1.X>P3.X, P1.X, P3.X), IIF(P2.X>P3.X, P2.X, P3.X))
    Dim maxY as Integer = IIF(P1.Y>P2.Y, IIF(P1.Y>P3.Y, P1.Y, P3.Y), IIF(P2.Y>P3.Y, P2.Y, P3.Y))
   
    Dim faceFlag as byte ptr = NEW byte[ImageWidth*ImageHeight]
    Dim P1flag as Integer
    Dim P2flag as Integer
    Dim P3flag as Integer
   
    Dim X as Integer = minX
    Dim Y as Integer = minY
    Dim C as Integer
    Do
        If Point(X,Y,BMPImage)<>TColor Then
            If faceFlag[X+(Y*ImageWidth)]=0 Then
                faceFlag[X+(Y*ImageWidth)]=1
                If X=P1.X and Y=P1.Y Then P1flag = 1
                If X=P2.X and Y=P2.Y Then P2flag = 1
                If X=P3.X and Y=P3.Y Then P3flag = 1
               
                If P1flag=1 andalso P2flag=1 andalso P3flag=1 Then
                    Function = 1
                    Exit Do
                End If
            End If
        Else
            faceFlag[X+(Y*ImageWidth)]=-1
        End If
       
        If X<maxX and faceFlag[X+1+(Y*ImageWidth)]>-1 Then
            X+=1
        ElseIf Y<maxY and faceFlag[X+((Y+1)*ImageWidth)]>-1 Then
            Y+=1
        Else
            Exit Do
        End If
    Loop
    Delete[] faceFlag
End Function

Sub Class_OBJGen.triOutlines()
    Dim dummycount as Integer
   
   
    Dim OutlineType as Integer = outline_up
    Dim OutType     as Integer
   
    Dim X as Integer
    Dim Y as Integer
    Dim FP as Vec2Int
    Dim P1 as Vec2Int
    Dim P2 as Vec2Int
    Dim P3 as Vec2Int
    Dim rColor as Integer
   
    Dim PColor as Integer

    do 'Find first Outline Up
        OutlineType = outline_up
        X=0:Y=0
        Do
            FP=findOutline(OutlineType,X,Y)
            If FP.X = -1 Then
                If X<ImageWidth Then
                    X+=1
                Else
                    DBGMSG = "no outlines"
                    Exit Sub
                End If
            Else
                Exit Do
            End If
        Loop
   
        Y=FP.Y
       
        do 'clockwise
       
            P1=findOutline(OutlineType,X,Y)
            If P1.X=-1 Then
                OutlineType=NextType(OutlineType)
                P1=findOutline(OutlineType,X,Y)
                If P1.X=-1 Then
                    OutlineType=NextType(OutlineType)
                    P1=findOutline(OutlineType,X,Y)
                    If P1.X=-1 Then
                        OutlineType=NextType(OutlineType)
                        P1=findOutline(OutlineType,X,Y)
                        If P1.X=-1 Then
                            ?"break P1"
                            Exit do,do
                        End If
                    End If
                End If
            End If
           
            rColor = Point(P1.X,P1.Y,Outlines)
            rColor = Bitreset(rColor,BitNum(OutlineType))
            rColor = BitSet(rColor,BitNum(TriType(OutlineType)))
            Pset Outlines,(P1.X,P1.Y),rColor
       
            Select Case OutlineType
                Case outline_up
                    P2=findOutline(OutlineType,X+1,Y)
                    X+=1 : PColor=&hFF0000
                Case outline_left
                    P2=findOutline(OutlineType,X,Y+1)
                    Y-=1 : PColor=&hFF00FF
                Case outline_down
                    P2=findOutline(OutlineType,X-1,Y)
                    X-=1: PColor=&hFFFF00
                Case outline_right
                    P2=findOutline(OutlineType,X,Y-1)
                    Y+=1: PColor=&h00FFFF
            End Select
       
            If P2.X=-1 Then
                OutlineType=NextType(OutlineType)
                P2=findOutline(OutlineType,X,Y)
                If P2.X=-1 Then
                    OutlineType=NextType(OutlineType)
                    P2=findOutline(OutlineType,X,Y)
                    If P2.X=-1 Then
                        OutlineType=NextType(OutlineType)
                        P2=findOutline(OutlineType,X,Y)
                        If P2.X=-1 Then
                            ?"break P2"
                            Exit do,do
                        End If
                    End If
                End If
            End If
       
            rColor = Point(P2.X,P2.Y,Outlines)
            rColor = Bitreset(rColor,BitNum(OutlineType))
            rColor = BitSet(rColor,BitNum(TriType(OutlineType)))
            Pset Outlines,(P2.X,P2.Y),rColor
           
            Pset (P1.X,P1.Y),PColor
            Pset (P2.X,P2.Y),PColor
           
            If ((P2.X=FP.X) and (P2.Y=FP.Y)) and ((P1.X<>P2.X) and (P1.Y<>P2.Y)) Then exit do
            If (X>(ImageWidth-1)) orelse (X<0) orelse (Y>(ImageHeight-1)) orelse (Y<0) Then Exit do
           
        loop
        '?"1 more loop"
    loop
End Sub       

Function Class_OBJGen.NextType(byval NType as UInteger) as UInteger
    If NType = outline_up Then
        Return outline_left
    ElseIf NType = outline_left Then
        Return outline_down
    ElseIf NType = outline_down Then
        Return outline_right
    ElseIf NType = outline_right Then
        Return outline_up
    End If
End Function

Function Class_OBJGen.TriType(byval NType as UInteger) as UInteger
    If NType = outline_up Then
        Return outline_trileft
    ElseIf NType = outline_left Then
        Return outline_tridown
    ElseIf NType = outline_down Then
        Return outline_triright
    ElseIf NType = outline_right Then
        Return outline_triup
    End If
End Function

Function Class_OBJGen.BitNum(byval NType as UInteger) as UInteger
    If NType = outline_left Then
        Return 0
    ElseIf NType = outline_right Then
        Return 1
    ElseIf NType = outline_up Then
        Return 2
    ElseIf NType = outline_down Then
        Return 3
    ElseIf NType = outline_trileft Then
        Return 4
    ElseIf NType = outline_triright Then
        Return 5
    ElseIf NType = outline_triup Then
        Return 6
    ElseIf NType = outline_tridown Then
        Return 7
    End If
End Function
       

   
screen 19,32   
Dim test as Class_OBJGen
test.TColor=&hFF000000
test.LoadBMP("htest.bmp")
test.scanOutlines()
test.triOutlines()
/'
dim c as uinteger
for y as integer=0 to test.ImageHeight-1
for x as integer=0 to test.ImageWidth-1
    c=Point(x,y,test.Outlines)
    If c<>0 Then
        If c<16 then
            Pset(x,y),&hFFFF0000
        else
            Pset(x,y),&hFFFFFFFF
        End If
    End If
next x
next y
'/
?test.DBGMSG


sleep

_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1766
Wohnort: [JN58JR] DeltaLabs.de

BeitragVerfasst am: 27.06.2012, 15:17    Titel: Antworten mit Zitat

In .dat sind die Daten in Form von 8Bit Grayscal enthalten. Pro Pixel = 1 Byte

Mit V_Key kann man den Wert der detektion der Kantenfarbe festlegen. Beispiel: Schwarzer Hintergrund (Key=0), Weiße Farbe des Bildes (Key=255)

Der Algo kann noch angepasst werden. je nachdem, wie gross deine Feldgrösen sind, welche erkannt werden sollen.

Zeile 176: Hier muss die anzahl punkte festgelegt werden, die minimal nötig sind, um einen Verlauf als Linie zu validieren. in deinem falle wäre dies wohl schon bei 1 gegeben. (wenn du jeden fund in die LL speichern willst)

Einfach etwas mit rumspielen.

http://ops.ath.cx/code?id=247

Sieht dann im endeffekt wie auf dem 3. unterem bild aus: http://mln.ath.cx/9.png
Der nächste schritt wäre dann aus diesem "Punktehaufen" eine Verktorisierung im sinne von pic 4. unten, zu generieren. aber das überlasse ich erstmal deinem geschick zwinkern



MfG
TPM

PS: TIP: wichtig ist, das die Umlaufwinkelrichtung beachtet wird, beim umfahren der Kanten.
_________________
[ WebFBC ][ OPS ][ DeltaLab's ][ ToOFlo ][ BGB-Movie ]


Zuletzt bearbeitet von ThePuppetMaster am 27.06.2012, 20:28, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Cherry



Anmeldungsdatum: 20.06.2007
Beiträge: 249

BeitragVerfasst am: 27.06.2012, 20:07    Titel: Antworten mit Zitat

@ThePuppetMaster: Wieso verwendest du eigentlich z.B. "Callocate(Sizeof(Point_Type))" und nicht "New Point_Type"?

Ist das schneller?
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1766
Wohnort: [JN58JR] DeltaLabs.de

BeitragVerfasst am: 27.06.2012, 20:23    Titel: Antworten mit Zitat

Gewöhnung zwinkern

Ob es schneller ist, kann ich nicht beantworten. Habe ich noch nie untersucht.


MfG
TPM
_________________
[ WebFBC ][ OPS ][ DeltaLab's ][ ToOFlo ][ BGB-Movie ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
MOD
Fleißiger Referenzredakteur


Anmeldungsdatum: 10.09.2007
Beiträge: 991

BeitragVerfasst am: 27.06.2012, 21:14    Titel: Antworten mit Zitat

Es ist zumindest anders. Immerhin erfordert NEW DELETE und (C)ALLOCATE DEALLOCATE. Letztere sind Aliase zu entsprechenden Funktionen der crt. Bei ersteren bin ich mir gar nicht mehr sicher, hab lange nicht mehr in den Code geschaut, meine mich aber an einige zusätzliche Prüfungen zwecks OOP zu erinnern, wodurch es langsamer wäre, mag mich aber auch irren.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1766
Wohnort: [JN58JR] DeltaLabs.de

BeitragVerfasst am: 28.06.2012, 08:40    Titel: Antworten mit Zitat

Hier mal ein Pic welches beschreibt, wie der obrige Algo arbeitet:



Zuerst wird pixel für pixel das bild abgearbeitet, bis ein Punkt gefunden wird.
von diesem an wird dann in Kreisförmdiger richtung aus dem zuletzt gesuchtem Winkel nach einem weiterem gesucht (1 > 2 > 3 ...) wurde eines gefunden, dann geht es zu diesem. von dort an wird erneut nach dem nächstem gesucht.

Hierbei muss die "Umlaufwinkelrichtung" beachtet werden. Oder, anders ausgedrückt: es muss beachtet werden, aus welcher richtung man das nächste Pixel gefunden hat. Von diesem Winkel ausgehend wird ein winkelschritt (bei Mehrfarbige Bilder mit "swing") oder mehrere (bei monochrome) weiter gefahren. Von dort an wird begonnen nach dem nächstem Pixel zu suchen.

Das ganez wird anschliessend solange wiederholt, bis man an den ausgangs-koordinaten angekommen ist, an welchem das erste pixel gefunden wurde.


Damit hat man dann ein Objekt durchlaufen.

Um zu verhindern, das bereits gefundene Objekte erneut gefunden werden, wird eine Temporäre 1Byte-Pixelmap angelegt, in dieser wird gespeichert, welches pixel bereits gefunden wurde. Dadurch kann beim nächsten durchlauf geprüft werden, ob das zu untersuchende pixel bereits durchlaufen wurde. Hierbei wird auserdem gespeichert, wie oft ein pixel untersucht wird ( +1). Überschreitet dieser wert ein maximum, wird die suchroutine verlassen, und als "nicht valid" markiert.


MfG
TPM
_________________
[ WebFBC ][ OPS ][ DeltaLab's ][ ToOFlo ][ BGB-Movie ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 30.06.2012, 12:10    Titel: Antworten mit Zitat

Ich bin mal fertig, versuch das nun seit Tagen hinzubekommen....

@ThePuppetMaster
Danke für den Algo, aber ich hab leider nicht durchgeblickt wie ich welche Form daten rein bringe und entsprechend auch nicht wie sie raus kommen zwinkern

Hatte mal den hier getestet, vermute der arbeitet ähnlich, allerdings ist der hier elend langsam happy
http://cardhouse.com/computer/vector.htm

Nuja, ich hab nu endlos viele versuche unternommen meine Punkte/Raster vor zu sortieren zum Triangulieren habe ich den Delaunay algo verwendet.
Der trianguliert zwar toll, aber ich kriegs ums verrecken nicht geschafft bestimmte punkte zum triangulieren auszuschliessen das er ausserhalb des objekts trianguliert (was ziemlich mistig aussieht)

Habs mit einer prioritätenliste versucht (rand/skelet/normal) hab versucht immer den nächsten vom nächsten zu finden, aber auch das wird irgendwie nichts, wollte noch mit Octree technik versuchen, aber ist mir inzwischen ZU viel arbeit ohne erfolgsgarantie....

Hab hier mal zwei (bastel-) codes, mit denen ich experimentiert habe...
der aufwand für den müll waren die schlaflosen nächte wirklich nicht wert... das muss doch gehen...



http://www.freebasic-portal.de/porticula/raster-triangulierungs-vor-sortierung-versuch-1535.html

http://www.freebasic-portal.de/porticula/delaunay-trianglation-versuch-1536.html

Ach ja, nochwas zur obigen Diskussion: (c)allocate versus NEW
Ich nutze meistens NEW, allerdings hat (c)allocate den Vorteil wegen dem redimension wenn man ein speicherbereich eben expandieren muss.
Keine ahnung ob das mit NEW auch möglich ist, jedenfalls für Dynamisches speichermanagment nehm ich dann eben (c)allocate happy
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1766
Wohnort: [JN58JR] DeltaLabs.de

BeitragVerfasst am: 01.07.2012, 15:37    Titel: Antworten mit Zitat

@Eternal_pain

Im grunde ist das wie ein post vor dir beschrieben. Zuerst wird einfach von links nach rechts, zeile für zeile abgesucht. Dann im kreis das Pixel utnersucht.

Daten reinbekommen ist eigentlich recht simplel

Wenn du ein Schwarz/weiß Bild, oder ein BIld mit Graustufen hast, dann funzt der alog ohne ihn umbauen zu müssen.

Du erzeugst ein "Data_Type" in welches die daten liegen

Code:
Dim TData as Data_Type


Dieses musst du mit Informationen Füllen
Code:

With TData
    .V_Width = BIldbreite
    .V_Height = Bildhöhe
    .V_Raster = 1 'das ist nur, für eienn spzialfall den ich mit dieser funktion umsetze. Du kannst hier 1 rein schreiben, weil du ein step 1 nutzt (pixel für pixel, und nicht step 5 um jeweils im 5pixel breite zu springen)
    .V_Dat = CAllocate(SizeOf(.V_Width * .V_Height)) 'speicher für die daten erzeugen
    for y as uinteger = 0 to .v_height - 1
        For X as UInteger = 0 to .V_width - 1
            .V_Dat[Y * .v_width + x] = <Pixel von koordinate x und y deiner quelle>
        next
    next
End with


damit hast du das übergabe feld erzeugt, welches du anschliessend an die funktion übergeben kannst

Code:

'die pixelergebenisse der objekte
dim titem_First as Item_Type ptr
dim titem_last as Item_Type ptr

'funktion aufrufen
Cluster(TData, titem_first, titem_last, 255) '255 ist der Farbkey .. 255 = weiß Das heist, er sucht nach der Farbe 255 und erkennt diese als pixel

'ergebniss extrahieren
Dim C as integer
dim tptr as item_type = titem_first
do until tptr = 0
    c += 1
    tptr = tptr->v_next
loop
print "habe " & Str(C) & " objekte erkannt"

'du kannst jetzt jedes erkannte, umrandete objekt extrahieren, udn zwar pixel für pixel
dim tpoint as point_type
tptr = titem_first
do until tptr = 0
    tpoint = tptr->point_f
    print "dieses objekt hat " & Str(tptr->V_pointc) & " pixel"
    c = 0
    do until tpoint = 0
        c += 1
        print "pixel: " & Str(C) & " it bei koordinate: " & str(tpoint->V_x) & "x" & str(tpoint->v_y)
    loop
    tptr = tptr->v_next
loop


Dabei wird jedes Pixel als 8Bit SW-Wert definiert. du musst also dein bild in ein 8bit graustufen bild umwandeln.

alternativ müsste man den algo leicht umbauen, um auch farbwerte erkennbar zu machen.

das ganze müsste dann in zeile ( http://ops.ath.cx/code?id=247 ) 91 und 138 geschehen.

hier müsste der Wert extrahier, in RGB aufgespalten
für den key welcher stat ubyte ein uinteger sein müsste (&H00FFFFFF) für 32Bit Weiß
Code:

Dim tkeyr as integer
dim tkeyg as integer
dim tkeyb as integer
tkeyr = (V_Key shr 16) and 255
tkeyg = (V_Key shr 8) and 255
tkeyb = (V_Key shr 0) and 255


für jedes pixel
Code:

Dim tr as integer
dim tg as integer
dim tb as integer
tr = (.V_Dat[...] shr 16) and 255
tg = (.V_Dat[...] shr 8) and 255
tb = (.V_Dat[...] shr 0) and 255


und dann (idealerweise mit einer tolleranz) verglichen werden
Code:

'V_Tolleranz = 10 -> +- 10 pro frabe -> bei pixelwert 200 wäre es 190 bis 210 als "valid"
if (tr >= (tkeyr - V_Tolleranz)) and (tr <= (tkeyr + V_Tolleranz)) Then 'für rot
    if (tg >= (tkeyg - V_Tolleranz)) and (tg <= (tkeyg + V_Tolleranz)) Then 'für grün
        if (tb >= (tkeyb - V_Tolleranz)) and (tb <= (tkeyb + V_Tolleranz)) Then 'für blau
           'pixel gefunden, und valid
        end if
    end if
end if


mit tolleranz kann dann ein wertebereich definiert werden. hier liese sich natürlich für jede farbe ein bereich definieren.

sinvoll wäre, wenn die toleranz vorher in jeweils seperate variablen gespeichert, udn vor der suche schon erzeugt werden würde, so das beim if vergleich rechenzeit gespart werden kann. das erhöht die geschwindigkeit sehr!!


zum verfahren: dazu einfach das bild oben ansehen. diese "kreisbewegung" wird in den zeilen ab 108 ausgeführt.

die do loop bei 108 ist die schleife, in welche gesprungen wird, wenn ein pixel mithilfe von zeilenweise links nach rechts gefunden wurde. diese do loop durchläuft dann das bild solange, bis die ausgangskoordinaten erreichet sind, oder ein pixel zu oft untersucht wurde.

109 ist die vorrechnugn für den winkel, mit dem gestartet wird. je nachdem, aus welcher richtung man kommt, muss entsprechend der winkel für das nächste zu suchende pixel bestimmt werden. (siehe bild bei "1" in den pixeln).

danach wird das nächste pixel bestimmt, welches untersucht werden soll (zeile 121 im code)

dies wird solange durchlaufen bis ein pixel gefunden wird (zeile 138). dabei wird von 1 bis 16 gelaufen, da die drehung sich je nach start winkel (z.B. 7) mit +8 winkel (1x im kreis drehen) addiert wird.

in zeile 168 wird geprüft, ob der durchlauf erfolgreich war. sprich, ob das ursprüngliche startpiexel erreicht wurde, bei dem die suche bzw. die umrandung des objektes egstartet hat. wenn dem so ist, dann wird das flag (tgroupok) gesetzt. und die schleife verlassen.

darunter wird dann geprüft (zeile 175), ob dies der fall war. wenn ja, dann wird dieser pixel-haufen in eine LL übertragen, und als "gefundenes Objekt" gespeichert, welches anschliessend von dir ausgelesen werden kann. (siehe etwas weiter oben in diesem post bei den sources)


das komplizierteste an diesem algo ist in der tat diese winkelsache. das ist auch das, was die optik an dem source so kurios macht. (Ab zeile 109).

Es ist wichtig, das der winkel von dem aus das letzte pixel gefunden wurde, entsprechend angepast wird. da sonst pixel verloren gehen können, oder die umrandung fehlerhaft abläuft.


MfG
TPM
_________________
[ WebFBC ][ OPS ][ DeltaLab's ][ ToOFlo ][ BGB-Movie ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 03.07.2012, 07:21    Titel: Antworten mit Zitat



Das Ergebnis ist im grunde genommen genau das gleiche das ich mit For/next in 2 schritten (oben nach unten) (links nach recht) (oder umgekehrt ist egal) unternehme, nur das ich inzwischen sogar noch kreuzpunkte suche,
dazu allerdings ist eine suche aus allen 4 richtungen notwendig...
Mag nicht ganz so elegant sein, aber wie gesagt sind die Ergebnisse recht ähnlich



Jedenfalls lassen sich mit meinem trivialen verfahren die 'Out Points' finden (wobei das ganze noch leichte probleme mit 'schrägen' hat)



Welche ich dann eigentlich nutzen möchte....

Viel komplizierter ist dagegen das eigentliche Problem dahinter das ganze zu Triangulieren und die Mathematik dahinter
ist mir glaube um einiges zu hoch (heisst wohl nicht umsonst höhere Mathematik grinsen)

Ich habe einen recht einfachen Delaunay Triangulation algo (einer der wenigen die ich finden konnte)
Dieser benutzt ein recht simples aufgebautes 'Incremental Construction' verfahren.

Ich komm nur nicht drauf wie ich diesen in einklang mit dem objekt das zu triangulieren ist
abstimmen kann das nur der inhalt und nicht auch alles drumherum trianguliert werd was zu triangulieren ist....

Auch meine bisher grössten bemühungen damit endeten wie dieser 'schnellvergleich/versuch' der ungefähr so aussieht:



Ich müsste wohl erst einmal das Voronoi Diagram und die verschiedenen
Techniken bei der Triangulation richtig verstehen, aber ich find ausser
unmengen an Theoretischem Material kaum ein praktisches Beispiel
in form von Sourcecode, das ich dann zudem auch noch nachvollziehen kann....

Code:

'Attribute VB_Name = "Module1"
'Credit to Paul Bourke (pbourke@swin.edu.au) for the original Fortran 77 Program :))
'Conversion by EluZioN (EluZioN@casesladder.com)
'You can use this code however you like providing the above credits remain in tact

'Option Explicit

'Points (Vertices)
Public Type dVertex
    x As Long
    y As Long
    z As Long
End Type

'Created Triangles, vv# are the vertex pointers
Public Type dTriangle
    vv0 As Long
    vv1 As Long
    vv2 As Long
End Type

'Set these as applicable
Public Const MaxVertices = 500
Public Const MaxTriangles = 1000

'Our points
dim shared Vertex(MaxVertices) As dVertex

'Our Created Triangles
dim shared  Triangle(MaxTriangles) As dTriangle

Function InCircle(xp As Long, yp As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long, x3 As Long, y3 As Long, 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

InCircle = 0'False
     
If Abs(y1 - y2) < eps And Abs(y2 - y3) < eps Then
'    MsgBox "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 InCircle = 1'True
       
End Function
Private Function WhichSide(xp As Long, yp As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long) 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
    WhichSide = -1
ElseIf equation = 0 Then
    WhichSide = 0
Else
    WhichSide = 1
End If

End Function

Public Function Triangulate(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.

Dim Complete(MaxTriangles) As integer'Boolean
Dim Edges(2, MaxTriangles * 3) As Long
Dim Nedge As Long

'For Super Triangle
Dim xmin As Long
Dim xmax As Long
Dim ymin As Long
Dim ymax As Long
Dim xmid As Long
Dim ymid As Long
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'Boolean

'Find the maximum and minimum vertex bounds.
'This is to allow calculation of the bounding triangle
xmin = Vertex(1).x
ymin = Vertex(1).y
xmax = xmin
ymax = ymin
For i = 2 To nvert
    If Vertex(i).x < xmin Then xmin = Vertex(i).x
    If Vertex(i).x > xmax Then xmax = Vertex(i).x
    If Vertex(i).y < ymin Then ymin = Vertex(i).y
    If Vertex(i).y > ymax Then ymax = Vertex(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.

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
Triangle(1).vv0 = nvert + 1
Triangle(1).vv1 = nvert + 2
Triangle(1).vv2 = nvert + 3
Complete(1) = 0'False
ntri = 1

'Include each point one at a time into the existing mesh
For i = 1 To nvert
    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 = 0
    Do
        j = j + 1
        If Complete(j) <> 1 Then
            inc = InCircle(Vertex(i).x, Vertex(i).y, Vertex(Triangle(j).vv0).x, 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) < Vertex(i).x Then
                'complete(j) = True
            'Else
            If inc Then
                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
                Triangle(j).vv0 = Triangle(ntri).vv0
                Triangle(j).vv1 = Triangle(ntri).vv1
                Triangle(j).vv2 = Triangle(ntri).vv2
                Complete(j) = Complete(ntri)
                j = j - 1
                ntri = 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 = 1 To Nedge - 1
        If Not Edges(1, j) = 0 And Not Edges(2, j) = 0 Then
            For k = j + 1 To Nedge
                If Not Edges(1, k) = 0 And Not Edges(2, k) = 0 Then
                    If Edges(1, j) = Edges(2, k) Then
                        If Edges(2, j) = Edges(1, k) Then
                            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 = 1 To Nedge
            If Not Edges(1, j) = 0 And Not Edges(2, j) = 0 Then
                ntri = ntri + 1
                Triangle(ntri).vv0 = Edges(1, j)
                Triangle(ntri).vv1 = Edges(2, j)
                Triangle(ntri).vv2 = i
                Complete(ntri) = 0'False
            End If
    Next j
Next i

'Remove triangles with supertriangle vertices
'These are triangles which have a vertex number greater than NVERT
i = 0
Do
    i = i + 1
    If Triangle(i).vv0 > nvert Or Triangle(i).vv1 > nvert Or Triangle(i).vv2 > nvert Then
        Triangle(i).vv0 = Triangle(ntri).vv0
        Triangle(i).vv1 = Triangle(ntri).vv1
        Triangle(i).vv2 = Triangle(ntri).vv2
        i = i - 1
        ntri = ntri - 1
    End If
Loop While i < ntri

Triangulate = ntri
End Function

dim ntri as integer
Vertex(1).x = 100 : Vertex(1).y = 100
Vertex(2).x = 200 : Vertex(2).y = 100
Vertex(3).x = 200 : Vertex(3).y = 200
Vertex(4).x = 123 : Vertex(4).y = 123
ntri=Triangulate(4)

screen 19,32

for l as integer=1 to ntri
    line (vertex(Triangle(l).vv0).x,vertex(Triangle(l).vv0).y) - (vertex(Triangle(l).vv1).x, vertex(Triangle(l).vv1).y)
    line (vertex(Triangle(l).vv1).x,vertex(Triangle(l).vv1).y) - (vertex(Triangle(l).vv2).x, vertex(Triangle(l).vv2).y)
    line (vertex(Triangle(l).vv2).x,vertex(Triangle(l).vv2).y) - (vertex(Triangle(l).vv0).x, vertex(Triangle(l).vv0).y)
next l

sleep

_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 04.07.2012, 01:31    Titel: Antworten mit Zitat

Habe bis gerade nochmal versucht mein eigenes kanten/umlauf 'dingen' zu basteln... eigentlich sollte er solange umrunden bis er wieder am startpunkt ankommt, aber wegen meiner überprüfungsbedingungen umrundet er solange er kann und ignoriert den 'zielpunkt' happy sieht langsam mit sleep richtig lustig aus grinsen

Code:

Function LoadBMP(byval filename as String, byref ImageWidth as Integer, byref ImageHeight as Integer) as any ptr
    Dim FF    as Integer = Freefile
    Dim Image as any ptr
   
    If Open (filename for BINARY as #FF) Then
        'DBGMSG = "BMP File not Found."
        close #FF
    Else
        Get #FF, 19, ImageWidth 
        Get #FF, 23, ImageHeight
        Close #FF
       
        Image  = Imagecreate(ImageWidth,ImageHeight)
        BLoad filename, Image
        'tColor = point(0,0,Image)
        Function = Image
    End If
End Function


Function Outline(byval ObjectMap as byte ptr, byval ImageWidth as Integer, byval ImageHeight as Integer) as byte ptr
    Dim FrameMap as byte ptr = NEW byte[ImageWidth*ImageHeight]
   
    Dim Mat (0 to 8) as byte
    Dim WMat(0 to 8) as byte
   
    '' X X X       1 2 3
    '' X X X  <->  8 0 4
    '' X X X       7 6 5
   
    Dim DX(0 to 8) as byte = { 0,-1, 0,+1,+1,+1, 0,-1,-1}
    Dim DY(0 to 8) as byte = { 0,-1,-1,-1, 0,+1,+1,+1, 0}
    Dim DW(0 to 8) as byte = { 0, 2, 4, 2, 4, 2, 4, 2, 4}
   
    Dim DPX as Integer
    Dim DPY as Integer
    Dim SPX as Integer
    Dim SPY as Integer
    Dim LP  as Integer
    Dim NP  as Integer
    Dim CW  as Integer
    Dim W as Integer
   
    Dim MapPos as Integer
    'Step1: Ersten 'rand' pixel finden:
   
    For Y as Integer = 0 to ImageHeight-1
        For X as Integer = 0 to ImageWidth-1
            MapPos = X+(Y*ImageWidth)
           
            If (ObjectMap[MapPos] <> 0) andalso (FrameMap[MapPos] = 0) Then
                DPX = X : DPY = Y
                SPX = X : SPY = Y
                Exit For, For
            End If
        Next X
    Next Y
   
    Do
        MapPos = SPX+(SPY*ImageWidth)
       
        If (SPX > 0) Then
            'Left
            If (ObjectMap[MapPos-1] <> 0) andalso (FrameMap[MapPos-1] = 0) Then
                Mat(8) =  1
            Else
                Mat(8) = -1
            End If
           
            If (SPY > 0) Then
                'UpLeft
                If (ObjectMap[MapPos-ImageWidth-1] <> 0) andalso (FrameMap[MapPos-ImageWidth-1] = 0) Then
                    Mat(1) =  1
                Else
                    Mat(1) = -1
                End If
            End If
           
            If (SPY < (ImageHeight-1)) Then
                'DownLeft
                If (ObjectMap[MapPos+ImageWidth-1] <> 0) andalso (FrameMap[MapPos+ImageWidth-1] = 0) Then
                    Mat(7) =  1
                Else
                    Mat(7) = -1
                End If
            End If
        Else
            Mat(8) = -1
            Mat(1) = -1
            Mat(7) = -1
        End If
       
        If (SPY > 0) Then
            'Up
            If (ObjectMap[MapPos-ImageWidth] <> 0) andalso (FrameMap[MapPos-ImageWidth] = 0) Then
                Mat(2) =  1
            Else
                Mat(2) = -1
            End If
        Else
            Mat(2) = -1
        End If
               
        If (SPY < (ImageHeight-1)) Then
            'Down
            If (ObjectMap[MapPos+ImageWidth] <> 0) andalso (FrameMap[MapPos+ImageWidth] = 0) Then
                Mat(6) =  1
            Else
                Mat(6) = -1
            End If
        Else
            Mat(6) = -1
        End If
       
        If (SPX < (ImageWidth-1)) Then
            'Right
            If (ObjectMap[MapPos+1] <> 0) andalso (FrameMap[MapPos+1] = 0) Then
                Mat(4) =  1
            Else
                Mat(4) = -1
            End If
           
            If (SPY > 0) Then
                'UpRight
                If (ObjectMap[MapPos-ImageWidth+1] <> 0) andalso (FrameMap[MapPos-ImageWidth+1] = 0) Then
                    Mat(3) =  1
                Else
                    Mat(3) = -1
                End If
            End If
           
            If (SPY < (ImageHeight-1)) Then
                'Down
                If (ObjectMap[MapPos+ImageWidth+1] <> 0) andalso (FrameMap[MapPos+ImageWidth+1] = 0) Then
                    Mat(5) =  1
                Else
                    Mat(5) = -1
                End If
            End If
        Else
            Mat(4) = -1
            Mat(3) = -1
            Mat(5) = -1
        End If
       
        Mat(LP) = -1
    '' X X X       1 2 3
    '' X X X  <->  8 0 4
    '' X X X       7 6 5
       
        WMat(1) = DW(1)' + ((DW(5) * .5))' * Mat(5))
        WMat(2) = DW(2)' + ((DW(6) * .5))' * Mat(6))
        WMat(3) = DW(3)' + ((DW(7) * .5))' * Mat(7))
        WMat(4) = DW(4)' + ((DW(8) * .5))' * Mat(8))
        WMat(5) = DW(5)' + ((DW(1) * .5))' * Mat(1))
        WMat(6) = DW(6)' + ((DW(2) * .5))' * Mat(2))
        WMat(7) = DW(7)' + ((DW(3) * .5))' * Mat(3))
        WMat(8) = DW(8)' + ((DW(4) * .5))' * Mat(4))
       
        NP = 0 : CW = 0 : W = LP
        For L as Integer=1 to 8
        'Do
            If (WMat(W) > CW) and (Mat(W) = 1) Then
                'MapPos = SPX+DX(W) + ((SPY+DY(W))*ImageWidth)
                'If (MapPos > -1) andalso (MapPos < (ImageWidth*ImageHeight)) andalso (FrameMap[MapPos] = 0)
                CW=WMat(W) : NP = W
                'Exit Do
            End If
            W += 1
            If W = 9 Then W = 1
        'Loop
        Next L
       
        Select Case NP
            Case 1
                LP = 5
            Case 2
                LP = 6
            Case 3
                LP = 7
            Case 4
                LP = 8
            Case 5
                LP = 1
            Case 6
                LP = 2
            Case 7
                LP = 3
            Case 8
                LP = 4
            Case Else
                Exit Do
        End Select
       
        MapPos = SPX + (SPY*ImageWidth)
        FrameMap[MapPos] = 1
       
        pset(SPX,SPY),&hFF00FF
       
        SPX += DX(NP)
        SPY += DY(NP)
       
       
        If (SPX = DPX) and (SPY = DPY) Then Exit Do
        sleep 10
        If Multikey(&h01) Then Exit Do 'Abbruch-Bedingung -> zu debug zwecken
    Loop
    Function = FrameMap
End Function



screen 19,32
Dim Image       as any ptr
Dim ImageWidth  as Integer
Dim ImageHeight as Integer
Image = LoadBMP("htest.bmp",ImageWidth,ImageHeight)



put (0,0),Image,pset
Dim ObjectMap as byte ptr = NEW byte [ImageWidth*ImageHeight]

For Y as Integer=0 to ImageHeight-1
    For X as Integer=0 to ImageWidth-1
        if point(X,Y,Image) <> &hFF000000 Then
            ObjectMap[X+(Y*ImageWidth)] = 1
        End If
    Next X
Next Y

Dim FrameMap as byte ptr
FrameMap = OutLIne(ObjectMap,ImageWidth,ImageHeight)



sleep
Delete[] ObjectMap
Delete[] FrameMap


Bin erstmal 'ne Woche in Urlaub, meine paar Hirnzellen die noch nicht ganz matsch sind erholen... vielleicht fällt mir ja dann etwas sinnvolles
ein das Problem zu lösen lächeln
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 16.07.2012, 21:36    Titel: back to the roots... Antworten mit Zitat

Zurück zu dieser Baustelle grinsen

Nachdem ich ja nun einige Zeit hatte über das Problem nachzudenken kam ich zu den Entschluss 'Warum kompliziert wenns auch einfach geht' (mehr oder weniger) in diesem Sinne, back to the roots... alles an Anfang...

mein letzter Versuch entspricht im prinzip das erkennen von pixel und seine nachbarn und setzt darauf Vertices die dann zu einem bzw zwei Triangles geformt werden falls dieses möglich ist... das Ergebnis ist schon ganz ansehnlich (jedenfalls das beste bisher)

Allerdings hab ich grad vor mich hingegrübelt und gekritzelt (da ich schon über den nächsten schritt, höheninterpretation bei graustufenbilder, nachgedacht habe) und dachte eigentlich, das ganze geht im prinzip NOCH einfacher... ich lasse die pixel pixel sein und interpretiere den rand bzw kante nach aussen hin neu... leider ist mir auch gleich ein neues schweres problem mit der idee aufgefallen, als beispiel mal ein bild meiner kritzelei um es besser nachvollziehen zu können was ich eigentlich meine...



Da ich bei meinem jetztigen Versuch probleme mit schrägen linien hatte, kam mir eben diese Idee, was auf der rechten seite ein gutes und richtiges ergebnis erzielen würde, zeigt auf der linken seite den interpretationsfehler auf....

die blauen (schlecht gezeichneten) punkte und dreiecke stammen vom pixel, die grünen von seinen nachbarn der die pixel als seine nachbarn erkannt hat

Jemand einen Tipp das bisschen noch zu lösen?
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1766
Wohnort: [JN58JR] DeltaLabs.de

BeitragVerfasst am: 16.07.2012, 21:39    Titel: Antworten mit Zitat

häääää?

kann dir nicht folgen.

was zeigt das bild genau?


MfG
TPM
_________________
[ WebFBC ][ OPS ][ DeltaLab's ][ ToOFlo ][ BGB-Movie ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 16.07.2012, 21:48    Titel: Antworten mit Zitat

...und ich dachte immer 'seit ich das Wort 'Dings' kenne kann ich alles erklären' grinsen

Also neuer Versuch happy

Da ich (später) vorhabe auch eine 3D interpretation eines Graustufenbildes zu generieren (wo die Grauwerte für die Höhe stehen, ähnlich eines Heightmap verfahrens) habe ich beschlossen einen gefunden Pixel in 4 Dreiecke aufzuteilen, wie auf den Bild als blaue punkte und linien zu sehen.
der in der mitte hat dann die den ZLevel/Höhe/Tiefe des gefundenen Pixels, die äusseren die der Nachbarpixel (FALLS dort pixel sind, ansonsten übernehmen sie die höhre des Pixels) soweit so gut

Das war im prinzip mein aller erster versuch der alles kantig dastellte, wo wir zum Thema Randerkennung kamen

Meine Idee war, nun auch die NULL-Pixel zu prüfen, ob dieser Pixel als Nachbarn hat und soll entprechend (wie im Bild mit roten punkten und grünen dreiecken dargestellt) quasi eine art kantenglättung erstellen:

wie gesagt wäre ein ergebnis wie auf der rechten seite allgemein wünschenswert, aber die Idee hat eben auch fehler wie auf der Linken Seite zu sehen da nachbarn auch über eine kleinere Distanz interpretiert werden. somit werden hier zwei nicht zusammenhängende pixel zu einem objekt... und das soll eben nicht sein...

Hoffe die erklärung war etwas besser zwinkern
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1766
Wohnort: [JN58JR] DeltaLabs.de

BeitragVerfasst am: 16.07.2012, 21:57    Titel: Antworten mit Zitat

öm ... ich glaube, verstanden habe ich es noch nicht so ganz ... lass es mich mal zusammenfassen.

du willst nachbarn der ecken eines pixels (hää?!?) ... prüfen, um festzustellen ob dort pixel vorhanden sind?!?

öm .... warum?

also .. was genau ist denn dein ziel? .. was soll denn der alog letztendlich machen? ich kann dem irgend wie nicht folgen.


MfG
TPM
_________________
[ WebFBC ][ OPS ][ DeltaLab's ][ ToOFlo ][ BGB-Movie ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 16.07.2012, 22:31    Titel: Antworten mit Zitat

Zum auslesen meines Bildes nutze ich ein Pixel/Vertex Array ( 0 to 8 )


Wenn sich an der Stelle ein Pixel befindet werden hier 5 vertices gesetzt und trianguliert;

fertig

Wenn sich dort kein pixel befindet schaue ich ob herum pixel sind um so nachher eine art kantenglättung durchzuführen
daher dachte ich das die funktion es dann folgenermassen macht als bsp.


oder


So jedenfalls meine überlegung, anschliessend soll geprüft werden ob diese zu triangulieren sind
meine überdachten ergebnisse sind oben im bild

ich hoffe damit ist die problemerklärung etwas besser...

(wenn erklären und verstehen schon so schwer ist wundere ich mich gar nicht mehr das ich mich schon so lange daran versuche grinsen)
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 18.07.2012, 19:49    Titel: Antworten mit Zitat

Habs nun endlich, jedenfalls was das 2D Triangulieren angeht...


Bei 3D Interpretation durch graustufen muss ich nochmal gucken, man weiss nicht was es ist, sieht aber irgendwie geil aus grinsen


Hab allerdings noch eine Sache, und zwar das berechnen der Normalen, die Werte scheinen mir irgendwie 'falsch'
auch wenn Tests in OpenGL sie richtig interpretiert...

Meine Funktion der Berechnung der Normalen:
Code:
Sub CalcNormal(byval InX1 as Single, byval InY1 as Single, byval InZ1 as Single, _
               byval InX2 as Single, byval InY2 as Single, byval InZ2 as Single, _
               byval InX3 as Single, byval InY3 as Single, byval InZ3 as Single, _
               byref OutX as Single, byref OutY as Single, byref OutZ as Single)
   
   Dim as Single Qx, Qy, Qz, Px, Py, Pz, Nx, Ny, Nz, f
   

   Qx = InX2-InX1 : Qy = InY2-InY1 : Qz = InZ2-InZ1
   Px = InX3-InX1 : Py = InY3-InY1 : Pz = InZ3-InZ1

   Nx = ((Py * Qz) - (Pz * Qy)) : Ny = ((Pz * Qx) - (Px * Qz)) : Nz = ((Px * Qy) - (Py * Qx))
   
   f = 1 / sqr((Nx*Nx)+(Ny*Ny)+(Nz*Nz))
   
   OutX = f*Nx : OutY = f*Ny : OutZ = f*Nz
End Sub


Wie gesagt interpretiert OpenGL das ganze richtig, aber es kann eigentlich nicht sein das ich bei knapp 500000 Triangles nur 2,3 Normale rausbekomme?
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC. Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz