Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
myMaze (Pathfind)
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 23.03.2013 10:57:19 |
#Define Distance2(X1,Y1,X2,Y2) sqr(((X1-X2)*(X1-X2))+((Y1-Y2)*(Y1-Y2)))
#Define MazeFloor &h00
#Define MazeStart &h01
#Define MazeGoal &h02
#Define MazeWall &h70
Randomize Timer
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
Exit Sub
End If
NewEntry -> PrevEntry = LastEntry
LastEntry -> NextEntry = NewEntry
LastEntry = NewEntry
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
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
Type Vector2
X as Integer
Y as Integer
End Type
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:
'if goal reachable from start
Declare Function fillPath(byval posX as Integer, byval posY as Integer) as Integer
Public:
MazeP as ubyte ptr 'Map (pointer)
MazeW as integer 'width
MazeH as integer 'height
MazeS as Vector2 'start position
MazeG as Vector2 'goal position
Declare Function genMaze(Byval sizeW as integer, byval sizeH as integer) as Integer
Declare Function delMaze() as Integer 'destroy/memfre
Declare Function getPath(byval fromX as Integer, byval fromY as Integer, byval targetX as Integer, byval targetY as Integer) as Integer ptr
End Type
Function tMaze.fillPath(byval posX as Integer, byval posY as Integer) as Integer
Dim fillmap as byte ptr = NEW byte[MazeW*MazeH]
Dim fillList as tList
Dim mappos as Integer = posX+(posY*MazeW)
Dim as Integer fX, fY
fillList.AddEntry(mappos)
fillmap[mappos] = 1
While fillList.FirstEntry
mappos = fillList.FirstEntry -> EntryValue
fillList.DelEntry(fillList.FirstEntry)
if (MazeP[mappos] = MazeGoal) Then Function = 1 : Exit While
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
Wend
Delete[] fillmap
fillList.DestroyList()
End Function
Function tMaze.genMaze(Byval sizeW as integer, byval sizeH as integer) as Integer
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 (Distance2(MazeS.X,MazeS.Y,MazeG.X,MazeG.Y) < 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
Loop until fillPath(MazeS.X,MazeS.Y) 'if goal not reachable, then repeat
'replace Start to Floor
MazeP[MazeS.X+(MazeS.Y*MazeW)]=MazeFloor
Return -1'TRUE
End Function
Function tMaze.delMaze() as Integer
If MazeP Then Delete[] MazeP
MazeP = 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
Dim PathList as Integer ptr
Dim PathLength as Integer
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 Single
Dim distanceL as Single = MazeW*MazeH
Dim fillList as tList
Dim as integer tX,tY
If (frompos < 0) or (frompos > ((MazeW*MazeH)-1)) Then return 0
fillList.AddEntry(frompos)
PathMap = NEW Integer[MazeW*MazeH]
While fillList.FirstEntry
mappos = fillList.FirstEntry -> EntryValue
fillList.DelEntry(fillList.FirstEntry)
PathMap[mappos] += 1 'Set PathCost
tX = mappos mod MazeW : tY = mappos \ MazeW
distance = Distance2(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
fillList.DestroyList()
PathLength = PathMap[nearestpos]
PathList = New Integer[PathLength+1]
PathList[0] = PathMap[nearestpos]
PathList[PathMap[nearestpos]] = nearestpos
Do
mappos = nearestpos
PathLength = PathMap[mappos]
PathList[PathLength] = mappos
If (PathLength = 1) Then Exit Do
tX = mappos mod MazeW : tY = mappos \ MazeW
If (tX > 0) andalso PathMap[mappos-1] = PathLength-1 Then nearestpos -= 1 : continue do
If (tY > 0) andalso PathMap[mappos-MazeW] = PathLength-1 Then nearestpos -= MazeW : continue do
If (tX < (MazeW-1)) andalso PathMap[mappos+1] = PathLength-1 Then nearestpos += 1 : continue do
If (tY < (MazeW-1)) andalso PathMap[mappos+MazeW] = PathLength-1 Then nearestpos += MazeW : continue do
exit do
Loop
Delete[] PathMap
return PathList
End Function
Sub DrawMaze(byref Maze as tMaze, byval size as Integer=10)
Dim mappos as Integer
Dim dcolor as UInteger
For Y as Integer = 0 to Maze.MazeH-1
For X as Integer = 0 to Maze.MazeW-1
mappos = X + (Y*Maze.MazeW)
Select Case Maze.MazeP[mappos]
Case MazeFloor
dcolor = &h000000
Case MazeWall
dcolor = &hFFFFFF
Case MazeGoal
dcolor = &hFF0000
Case Else
dColor = &hFF8800
End Select
line(X*size,Y*size)-((size-1)+(X*size),(size-1)+(Y*size)),dcolor,bf
Next X
Next Y
End Sub
Sub PlayerMove(byref Maze as tMaze, byref Player as Vector2, byval dx as integer, byval dy as integer)
Dim playerpos as Integer = Player.X + (Player.Y * Maze.MazeW)
Dim destpos as Integer = playerpos + dx + (dy * Maze.MazeW)
If (Maze.MazeP[destpos] < MazeWall) Then Player.X += dx : Player.Y += dy
End Sub
screenres 800,600,32
Dim myMaze as tMaze
myMaze.genMaze(80,60)
''MAIN:
Dim Player as Vector2 = myMaze.MazeS
Dim KeyTimer as Double = Timer
Dim size as Integer = 10
Dim as Integer MX,MY,MB
Dim PathList as Integer ptr
Dim PathMove as Integer
Do
Screenlock
cls
DrawMaze(myMaze,size)
line(Player.X*size,Player.Y*size)-((size-1)+(Player.X*size),(size-1)+(Player.Y*size)),&hFFFF00,bf
Screenunlock
If PathList Then
If PathMove = PathList[0]+1 Then
Delete[] PathList : PathList = 0
Else
Player.X = PathList[PathMove] mod myMaze.MazeW
Player.Y = PathList[PathMove] \ myMaze.MazeW
PathMove += 1
End If
End If
If ((Timer-KeyTimer) > 0.025) Then
getMouse MX,MY,,MB
If (MB > 0) Then
If PathList Then Delete[] PathList : PathList = 0
PathList = myMaze.getPath(Player.X,Player.Y,fix(MX/size),fix(MY/size))
PathMove = 1
End If
If multikey(&h48) Then PlayerMove(myMaze, Player, 0,-1) 'UP
If multikey(&h4B) Then PlayerMove(myMaze, Player,-1, 0) 'LEFT
If multikey(&h4D) Then PlayerMove(myMaze, Player, 1, 0) 'RIGHT
If multikey(&h50) Then PlayerMove(myMaze, Player, 0, 1) 'DOWN
KeyTimer=Timer
End if
If multikey(&h01) Then exit do'ESC
sleep 1
Loop
If PathList Then Delete[] PathList
myMaze.delMaze()