|
Das deutsche QBasic- und FreeBASIC-Forum Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
Autor |
Nachricht |
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 27.06.2012, 01:52 Titel: BMP to OBJ Kanten optimieren |
|
|
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 )
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 |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007 Beiträge: 1837 Wohnort: [JN58JR]
|
Verfasst am: 27.06.2012, 11:06 Titel: |
|
|
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 ][ ToOFlo ][ Wiemann.TV ] |
|
Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 27.06.2012, 16:11 Titel: |
|
|
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 |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007 Beiträge: 1837 Wohnort: [JN58JR]
|
Verfasst am: 27.06.2012, 16:17 Titel: |
|
|
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
MfG
TPM
PS: TIP: wichtig ist, das die Umlaufwinkelrichtung beachtet wird, beim umfahren der Kanten. _________________ [ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ]
Zuletzt bearbeitet von ThePuppetMaster am 27.06.2012, 21:28, insgesamt einmal bearbeitet |
|
Nach oben |
|
|
Cherry
Anmeldungsdatum: 20.06.2007 Beiträge: 249
|
Verfasst am: 27.06.2012, 21:07 Titel: |
|
|
@ThePuppetMaster: Wieso verwendest du eigentlich z.B. "Callocate(Sizeof(Point_Type))" und nicht "New Point_Type"?
Ist das schneller? |
|
Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007 Beiträge: 1837 Wohnort: [JN58JR]
|
Verfasst am: 27.06.2012, 21:23 Titel: |
|
|
Gewöhnung
Ob es schneller ist, kann ich nicht beantworten. Habe ich noch nie untersucht.
MfG
TPM _________________ [ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
Nach oben |
|
|
MOD Fleißiger Referenzredakteur
Anmeldungsdatum: 10.09.2007 Beiträge: 1003
|
Verfasst am: 27.06.2012, 22:14 Titel: |
|
|
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 |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007 Beiträge: 1837 Wohnort: [JN58JR]
|
Verfasst am: 28.06.2012, 09:40 Titel: |
|
|
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 ][ ToOFlo ][ Wiemann.TV ] |
|
Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 30.06.2012, 13:10 Titel: |
|
|
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
Hatte mal den hier getestet, vermute der arbeitet ähnlich, allerdings ist der hier elend langsam
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 _________________
|
|
Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007 Beiträge: 1837 Wohnort: [JN58JR]
|
Verfasst am: 01.07.2012, 16:37 Titel: |
|
|
@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 ][ ToOFlo ][ Wiemann.TV ] |
|
Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 03.07.2012, 08:21 Titel: |
|
|
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 )
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 |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 04.07.2012, 02:31 Titel: |
|
|
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' sieht langsam mit sleep richtig lustig aus
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 _________________
|
|
Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 16.07.2012, 22:36 Titel: back to the roots... |
|
|
Zurück zu dieser Baustelle
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 |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007 Beiträge: 1837 Wohnort: [JN58JR]
|
Verfasst am: 16.07.2012, 22:39 Titel: |
|
|
häääää?
kann dir nicht folgen.
was zeigt das bild genau?
MfG
TPM _________________ [ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 16.07.2012, 22:48 Titel: |
|
|
...und ich dachte immer 'seit ich das Wort 'Dings' kenne kann ich alles erklären'
Also neuer Versuch
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 _________________
|
|
Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007 Beiträge: 1837 Wohnort: [JN58JR]
|
Verfasst am: 16.07.2012, 22:57 Titel: |
|
|
ö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 ][ ToOFlo ][ Wiemann.TV ] |
|
Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 16.07.2012, 23:31 Titel: |
|
|
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 ) _________________
|
|
Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006 Beiträge: 1783 Wohnort: BW/KA
|
Verfasst am: 18.07.2012, 20:49 Titel: |
|
|
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
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 |
|
|
|
|
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.
|
|