Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
myMaze+(pre)getPath
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 22.03.2013 14:42:48 |
Type tListNode
NextEntry as tListNode ptr
PrevEntry as tListNode ptr
EntryValue as Integer
End Type
Type tList
Declare Sub AddEntry(byval Value as Integer)
Declare Sub DelEntry(byval ListNode as tListNode ptr)
Declare Sub DestroyList()
FirstEntry as tListNode ptr
LastEntry as tListNode ptr
End Type
Sub tList.AddEntry(byval Value as Integer)
Dim NewEntry as tListNode ptr = NEW tListNode
NewEntry -> EntryValue = Value
If (LastEntry = 0) Then
FirstEntry = NewEntry
LastEntry = NewEntry
Else
NewEntry -> PrevEntry = LastEntry
LastEntry -> NextEntry = NewEntry
LastEntry = NewEntry
End If
End Sub
Sub tList.DestroyList()
while FirstEntry
LastEntry = FirstEntry -> NextEntry
Delete FirstEntry
FirstEntry = LastEntry
wend
End Sub
Sub tList.DelEntry(byval ListNode as tListNode ptr)
If (ListNode = 0) Then Exit Sub
'Dim TempNode as tListNode ptr = ListNode
If ListNode -> NextEntry Then ListNode -> NextEntry -> PrevEntry = ListNode -> PrevEntry
If ListNode -> PrevEntry Then ListNode -> PrevEntry -> NextEntry = ListNode -> NextEntry
If ListNode = FirstEntry Then FirstEntry = FirstEntry -> NextEntry
If ListNode = LastEntry Then LastEntry = LastEntry -> PrevEntry
Delete ListNode
End Sub
Randomize Timer
#Define MazeFloor &h00
#Define MazeStart &h01
#Define MazeGoal &h02
#Define MazeWall &h70
Type Vector2
X as Integer
Y as Integer
End Type
Function Distance2d (byval X1 as Integer, byval Y1 as Integer, byval X2 as Integer, byval Y2 as Integer) as Double
Dim PX as Integer = abs(X1-X2)*abs(X1-X2)
Dim PY as Integer = abs(Y1-Y2)*abs(Y1-Y2)
Function = SQR(PX+PY)
End Function
Function Distance2i (byval XY1 as Vector2, Byval XY2 as Vector2) as Integer
Dim PX as Integer = abs(XY1.X-XY2.X)*abs(XY1.X-XY2.X)
Dim PY as Integer = abs(XY1.Y-XY2.Y)*abs(XY1.Y-XY2.Y)
Function = SQR(PX+PY)
End Function
Function getRandom(Byval imin as Integer, Byval imax as Integer) as Integer
Dim rndnum as Integer
Dim as Integer min, max
min = imin : max = imax
If min>max then swap min,max
rndnum = min + int( rnd*( max - (min-1) ) )
return rndnum
End Function
Type tMaze
Private:
Declare Sub fillPath(byval posX as Integer, byval posY as Integer)
MazeControl as Integer
Public:
MazeP as ubyte ptr
MazeW as integer
MazeH as integer
Declare Function genMaze(Byval sizeW as integer, byval sizeH as integer) as Integer
Declare Function delMaze() as Integer
'experimantal path-find
Declare Function getPath(byval fromX as Integer, byval fromY as Integer, byval targetX as Integer, byval targetY as Integer) as Integer ptr
End Type
Sub tMaze.fillPath(byval posX as Integer, byval posY as Integer)
Dim fillmap as byte ptr = NEW byte[MazeW*MazeH]
Dim fillList as tList
Dim fillNode as tListNode ptr
Dim as Integer fX = posX
Dim as Integer fY = posY
Dim mappos as Integer = fX+(fY*MazeW)
fillList.AddEntry(mappos)
fillmap[mappos] = 1
Do
fillNode = fillList.FirstEntry
If fillNode Then
mappos = fillNode -> EntryValue
fillList.DelEntry(fillNode)
if MazeP[mappos] = MazeGoal Then
MazeControl = 1
Exit Do
End If
Else
Exit Do
End If
fX = mappos mod MazeW
fY = mappos \ MazeW
If (fX > 0) andalso ( (fillmap[mappos-1] = 0) and (MazeP[mappos-1] < MazeWall) ) Then fillList.AddEntry(mappos-1) : fillmap[mappos-1] = 1
If (fY > 0) andalso ( (fillmap[mappos-MazeW] = 0) and (MazeP[mappos-MazeW] < MazeWall) ) Then fillList.AddEntry(mappos-MazeW) : fillmap[mappos-MazeW] = 1
If (fX < (MazeW-1)) andalso ( (fillmap[mappos+1] = 0) and (MazeP[mappos+1] < MazeWall) ) Then fillList.AddEntry(mappos+1) : fillmap[mappos+1] = 1
If (fY < (MazeH-1)) andalso ( (fillmap[mappos+MazeW] = 0) and (MazeP[mappos+MazeW] < MazeWall) ) Then fillList.AddEntry(mappos+MazeW) : fillmap[mappos+MazeW] = 1
Loop
Delete[] fillmap
fillList.DestroyList()
End Sub
Function tMaze.genMaze(Byval sizeW as integer, byval sizeH as integer) as Integer
Dim MazeS as Vector2 'start position
Dim MazeG as Vector2 'goal position
Dim granularity as Integer
Dim randomLength as Integer
Dim minLength as Integer
Dim maxLength as Integer
Dim numWalls as Integer
Dim rndWallPosX as Integer
Dim rndWallPosY as Integer
Dim rndDest as Integer
Dim dX as Integer
Dim dY as Integer
Dim mappos as Integer
Dim minDist as Integer
Do
If MazeP Then delMaze()
MazeW = sizeW : MazeH = sizeH
If (MazeW mod 2) = 0 Then MazeW -= 1
If (MazeH mod 2) = 0 Then MazeH -= 1
If (MazeW < 9) Then MazeW = 9
If (MazeH < 9) Then MazeH = 9
MazeP = NEW ubyte[MazeW*MazeH]
'gen outwalls
For WallW as Integer = 0 to MazeW-1
MazeP[WallW] = MazeWall
MazeP[((MazeH-1)*MazeW)+WallW] = MazeWall
Next WallW
For WallH as Integer = 0 to MazeH-1
MazeP[WallH*MazeW] = MazeWall
MazeP[(MazeW-1)+(WallH*MazeW)] = MazeWall
Next WallH
minDist = sqr(sqr(MazeW*MazeH))
'gen random start position
Do : MazeS.X = getRandom(1,MazeW-2) : Loop while ((MazeS.X mod 2) = 0)
Do : MazeS.Y = getRandom(1,MazeH-2) : Loop while ((MazeS.Y mod 2) = 0)
'gen random goal position (with minimal distance)
Do
Do : MazeG.X = getRandom(1,MazeW-2) : Loop while ((MazeG.X mod 2) = 0)
Do : MazeG.Y = getRandom(1,MazeH-2) : Loop while ((MazeG.Y mod 2) = 0)
Loop while (Distance2i(MazeS,MazeG) < minDist)
MazeP[MazeS.X+(MazeS.Y*MazeW)]=MazeStart
MazeP[MazeG.X+(MazeG.Y*MazeW)]=MazeGoal
For G as Integer = 4 to 1 step -1
granularity = 2 ^ G '...16,8,4,2
numWalls = (MazeW*MazeH)/G
For W as Integer = 1 to numWalls '1 to...
rndWallPosX = granularity * (getRandom(1,MazeW-1) \ granularity)
rndWallPosY = granularity * (getRandom(1,MazeH-1) \ granularity)
minLength = getRandom(1,4)
maxLength = getRandom(2,10)
rndDest = getRandom(0,3)
Select Case rndDest
Case 0 'North/Up
dX = 0 : dY = -1
Case 1 'East/Right
dX = 1 : dY = 0
Case 2 'South/Down
dX = 0 : dY = 1
Case 3 'West/Left
dX = -1 : dY = 0
End Select
randomLength = granularity * (getRandom(minLength,maxLength)+1)
For L as Integer = 1 to randomLength
mappos = (rndWallPosX + (rndWallPosY*MazeW))
If MazeP[mappos] <> MazeFloor Then Exit For
MazeP[mappos] = MazeWall
rndWallPosX += dX : rndWallPosY += dY
Next L
Next W
Next G
fillPath(MazeS.X,MazeS.Y) 'mark all reachable tiles (from start)
Loop until MazeControl 'not necassary | just for sure, the goal is reachable from start
Return -1'TRUE
End Function
Function tMaze.delMaze() as Integer
If MazeP Then Delete[] MazeP
MazeP = 0
MazeControl = 0
MazeW = 0
MazeH = 0
return -1'TRUE
End Function
Function tMaze.getPath(byval fromX as Integer, byval fromY as Integer, byval targetX as Integer, byval targetY as Integer) as Integer ptr
Dim PathMap as Integer ptr = NEW Integer[MazeW*MazeH]
Dim PathList as Integer ptr
Dim frompos as Integer = fromX+(fromY*MazeW)
Dim targetpos as Integer = targetX+(targetY*MazeW)
Dim mappos as Integer
Dim nearestpos as Integer
Dim distance as Double
Dim distanceL as Double = MazeW*MazeH
Dim as integer tX,tY
'Dim PathCost as Integer
Dim fillList as tList
fillList.AddEntry(frompos)
While fillList.FirstEntry
mappos = fillList.FirstEntry -> EntryValue
fillList.DelEntry(fillList.FirstEntry)
PathMap[mappos] += 1 'Set PathCost
tX = mappos mod MazeW
tY = mappos \ MazeW
distance = Distance2d(tX,tY,targetX,targetY)
If (distance < distanceL) Then
distanceL = distance
nearestpos = mappos
End If
If (mappos = targetpos) then exit while
If (tX > 0) andalso ( (MazeP[mappos-1] < MazeWall) and PathMap[mappos-1] = 0 ) Then fillList.AddEntry(mappos-1) : PathMap[mappos-1] = PathMap[mappos]
If (tY > 0) andalso ( (MazeP[mappos-MazeW] < MazeWall) and PathMap[mappos-MazeW] = 0 ) Then fillList.AddEntry(mappos-MazeW) : PathMap[mappos-MazeW] = PathMap[mappos]
If (tX < (MazeW-1)) andalso ( (MazeP[mappos+1] < MazeWall) and PathMap[mappos+1] = 0 ) Then fillList.AddEntry(mappos+1) : PathMap[mappos+1] = PathMap[mappos]
If (tY < (MazeH-1)) andalso ( (MazeP[mappos+MazeW] < MazeWall) and PathMap[mappos+MazeW] = 0 ) Then fillList.AddEntry(mappos+MazeW) : PathMap[mappos+MazeW] = PathMap[mappos]
Wend
mappos = 0
do
If PathMap[mappos] Then
tX = mappos mod MazeW
tY = mappos \ MazeW
draw string (tX*20,tY*20),str(PathMap[mappos]),&hFF8800
End If
mappos += 1
loop until (mappos = MazeW*MazeH)
tX = nearestpos mod MazeW
tY = nearestpos \ MazeW
draw string ((tX*20)+8,(tY*20)+8),"X",&hFF0000
'Dim PathLength as Integer = PathMap[nearestpos]
'PathList = New Integer[PathLength+1]
'PathList[0] = PathMap[nearestpos]
'PathList[PathMap[nearestpos]] = PathMap[nearestpos]
fillList.DestroyList()
Delete[] PathMap
return PathList
End Function
screenres 800,600,32',,&h08
Dim myMaze as tMaze
Dim mappos as Integer
Dim mazeread as ubyte
'Dim genTime as Double
Dim fsize as Integer = 20
Dim MazeS as Vector2
Dim MazeG as Vector2
Dim as Integer MX,MY,MB
myMaze.genMaze(40,30)
Do
screenlock
cls
For Y as Integer=0 to myMaze.MazeH-1
For X as Integer=0 to myMaze.MazeW-1
mappos = X+(Y*myMaze.MazeW)
mazeread = myMaze.MazeP[mappos]
If mazeread = MazeWall Then line(X*fsize,Y*fsize)-((fsize-1)+(X*fsize),(fsize-1)+(Y*fsize)),&hFFFFFF,bf
if mazeread = MazeStart Then
MazeS.X = mappos mod myMaze.MazeW
MazeS.Y = mappos \ myMaze.MazeW
line(X*fsize,Y*fsize)-((fsize-1)+(X*fsize),(fsize-1)+(Y*fsize)),&hFFFF00,bf
End If
if mazeread = MazeGoal Then
'MazeG.X = mappos mod myMaze.MazeW
'MazeG.Y = mappos \ myMaze.MazeW
line(X*fsize,Y*fsize)-((fsize-1)+(X*fsize),(fsize-1)+(Y*fsize)),&h00FF00,bf
end if
Next X
Next Y
line(MazeG.X*fsize,MazeG.Y*fsize)-((fsize-1)+(MazeG.X*fsize),(fsize-1)+(MazeG.Y*fsize)),&h6666EE,bf
'genTime = Timer-genTime
'locate 1,1:?genTime
myMaze.getPath(MazeS.X,MazeS.Y,MazeG.X,MazeG.Y)
Screenunlock
do : getmouse MX,MY,,MB : loop while (MB > 0)
do
getmouse MX,MY,,MB
If MB>0 Then MazeG.X = fix(MX/20) : MazeG.Y = fix(MY/20) : Exit Do
sleep 10
loop until multikey(&h01)
Loop until multikey(&h01)
myMaze.delMaze()