Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Raster (Triangulierungs-) Vor-sortierung Versuch
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 30.06.2012 13:08:31 |
const deg2rad = (Atn(1)/45.0)
Type Vec2Int
X as Integer
Y as Integer
End Type
Type bMap
Size as Vec2Int
BitMap as Integer ptr
Declare Function Get(byval X as Integer, byval Y as Integer) as Integer
Declare Sub Set(byval X as Integer, byval Y as Integer, byval V as Integer = 1)
End Type
Function bMap.Get(byval X as Integer, byval Y as Integer) as Integer
If (X > -1) andalso (Y > -1) andalso (X < Size.X) and (Y < Size.Y) Then
Return BitMap[X+(Y*Size.X)]
End If
End Function
Sub bMap.Set(byval X as Integer, byval Y as Integer, byval V as Integer = 1)
If (X > -1) andalso (Y > -1) andalso (X < Size.X) and (Y < Size.Y) Then
BitMap[X+(Y*Size.X)] = V
End If
End Sub
Type PointList
prev as PointList ptr
next as PointList ptr
P as Vec2Int
End Type
Type PointManager
points as Integer
Lroot as PointList ptr
Lnow as PointList ptr
LLast as PointList ptr
Declare Sub SetNext()
Declare Sub SetPrev()
Declare Sub SearchNearest(byval SearchMap as bMap ptr)
Declare Sub Add(byval NPoint as Vec2Int)
End Type
Sub PointManager.SearchNearest(byval SearchMap as bMap ptr)
Dim SL as PointList ptr
Dim LL as PointList ptr
Dim PN as Vec2Int
Dim PS as Vec2Int
Dim DM as Single = 100
Dim D as Single
PN = Lnow -> P
SL = Lroot
Do
If (SL <> Lnow) Then
PS = SL -> P
D = sqr( abs((PN.X-PS.X)*(PN.X-PS.X)) + abs((PN.Y-PS.Y)*(PN.Y-PS.Y)) )
If (D < DM) Then
If SearchMap -> Get(PS.X,PS.Y) <> 0 Then
DM = D
LL = SL
End If
End If
End If
SL = SL -> Next
Loop while SL
If LL Then
LNow = LL
Else
SetNext()
'LNow = 0
End If
End Sub
Sub PointManager.SetNext()
If (Lnow <> 0) Then lnow = lnow -> next
End Sub
Sub PointManager.SetPrev()
If (Lnow <> 0) Then lnow = lnow -> prev
End Sub
Sub PointManager.Add(byval NPoint as Vec2Int)
Dim NewPoint as PointList ptr
NewPoint = NEW PointList
If (LLast <> 0) Then
LLast -> next = NewPoint
NewPoint -> prev = LLast
LLast = NewPoint
Else
LLast = NewPoint
Lroot = NewPoint
Lnow = NewPoint
End If
points += 1
NewPoint -> P.X = NPoint.X
NewPoint -> P.Y = NPoint.Y
End Sub
Function GenMap(byval SizeX as Integer, byval SizeY as Integer) as bMap ptr
Dim NewMap as bMap ptr
NewMap = NEW bMap
NewMap -> Size.X = SizeX
NewMap -> Size.Y = SizeY
NewMap -> BitMap = NEW Integer[SizeX*SizeY]
Return NewMap
End Function
Sub DelMap(byref In_Map as bMap ptr)
Delete[] In_Map -> BitMap
Delete In_Map
In_Map = 0
End Sub
Function NextPoint(byval In_PosX as Integer, byval In_PosY as Integer, byval In_Radius as Integer, byval In_Map as bMap ptr) as Vec2Int
static searchclock as single
Dim FP(0 to 99) as Vec2Int
Dim wStep as Single = 0.5
Dim dStep as Single = 0.5
Dim NP as Integer
Dim X as Integer
Dim Y as Integer
Dim TP as Integer
Dim AD as Single
Dim LD as Single
'wStep = 1'90 - ((In_Radius*.1)*45)
'If (wStep < 0) Then wStep = 1
For D as Single=0 to In_Radius step dStep
For W as Single=0 to 359 step wStep
X = In_PosX + (Cos(deg2rad*(searchclock)) * D)
Y = In_PosY + (Sin(deg2rad*(searchclock)) * D)
'locate 1,1:?X,Y
If (X <> In_PosX) andalso (Y <> In_PosY) andalso _
(X > -1) andalso (X < (In_Map -> Size.X)) andalso (Y > -1) andalso (Y < (In_Map -> Size.Y)) Then
If (In_Map -> BitMap[X+(Y*In_Map -> Size.X)] <> 0) Then
FP(NP) = Type(X,Y)
NP += 1
If (NP = 100) Then Exit For,For
End If
End If
searchclock += W
If searchclock > 359 then searchclock -= 360
Next W
Next D
If NP<>0 Then
LD = 9999
For l as Integer=0 to NP-1
AD = sqr( abs((In_PosX-FP(l).X)*(In_PosX-FP(l).X)) + abs((In_PosY-FP(l).Y)*(In_PosY-FP(l).Y)) )
If AD<LD Then
'locate 2,1:?AD
LD=AD
TP=l
End If
Next l
Return FP(TP)
End If
Return Type(-1,-1)
End Function
Function LoadBMP(byval filename as String) as any ptr
Dim ImageHeight as Integer
Dim ImageWidth as Integer
Dim Image as any ptr
Dim FF as Integer = Freefile
If Open (filename for BINARY as #FF) Then
'DBGMSG = "LoadBMP: File not found."
Close #FF
Else
Get #FF, 19, ImageWidth
Get #FF, 23, ImageHeight
Close #FF
Image = Imagecreate(ImageWidth,ImageHeight)
BLoad filename, Image
'
End If
Return Image
End Function
'test NextPoint
Screen 19,32
Dim as Integer BMPX,BMPY
Dim BMP as any ptr = LoadBMP("FBPferd.bmp")
ImageInfo BMP,BMPX,BMPY
Dim mymap as bmap ptr
mymap = GenMap(BMPX,BMPY)
Dim FP as Vec2Int
For Y as INteger=0 to BMPY-1 step 3
For X as Integer=0 to BMPX-1 step 3
If point(X,Y,BMP) <> &hFF000000 Then
pset(X,Y),&hFFFFFFFF
mymap -> Set(X,Y)
If FP.X=0 Then FP.X = X : FP.Y = Y
End If
Next X
Next Y
Dim Points as PointManager
Points.Add(FP)
Dim as integer lx,ly
lX = FP.X
lY = FP.Y
Dim SP as Vec2Int
do
Do
'locate 1,1:?points.lnow -> P.X,points.lnow -> P.X
SP=NextPoint(Points.lnow -> P.X,Points.lnow -> P.Y,9,mymap)
If (SP.X > -1) Then
'PSet (SP.X,SP.Y),&hFF0000FF
Line (lX,lY)-(SP.X,SP.Y),&hFFFF0000
lX=SP.X:ly=SP.Y
mymap -> Set(SP.X,SP.Y,0)
Points.Add(SP)
Else
exit do
End If
sleep 1
Loop
Points.SearchNearest(mymap)
If Points.lnow = 0 Then Exit Do
'locate 3,1:?Points.lnow
loop
?Points.points
sleep