Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Perfect Maze
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 19.03.2013 15:10:58 |
Randomize Timer
#Define MazeFloor &h00
#Define MazeStart &h01
#Define MazeGoal &h02
'...define... Items or anything else... here
'MazeReachPath: important to know, to set items and monsters... (or anything else...)
#Define MazeReachPath &h69
#Define MazeWall &h70
'...define other solid items like walls... here (up to &hFF)
Type Vector2
X as Integer
Y as Integer
End Type
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
MazeP as ubyte ptr
MazeW as uinteger'ushort
MazeH as uinteger'ushort
Declare Function genMaze(Byval sizeW as ushort, byval sizeH as ushort) as Integer
Declare Function delMaze() as Integer
Declare Function drawMaze(byval Wallsize as Integer = 10) as any ptr'for tests only
Declare Sub fillPath(byval posX as Integer, byval posY as Integer)
Private:
MazeControl as Integer
MazeStack as UInteger
End Type
Sub tMaze.fillPath(byval posX as Integer, byval posY as Integer)
MazeStack += 1
Dim mappos as Integer
mappos = posX+(posY*MazeW)
If MazeP[mappos] = MazeFloor Then MazeP[mappos] = MazeReachPath
If MazeP[mappos] = MazeGoal Then MazeControl = 1
'If (MazeStack < 1024) Then
If (posX > 0) and MazeP[mappos-1] < MazeReachPath Then fillPath(posX-1,posY)
If (posY > 0) and MazeP[mappos-MazeW] < MazeReachPath Then fillPath(posX,posY-1)
If (posX < (MazeW-1)) and MazeP[mappos+1] < MazeReachPath Then fillPath(posX+1,posY)
If (posY < (MazeH-1)) and MazeP[mappos+MazeW] < MazeReachPath Then fillPath(posX,posY+1)
'End If
mazeStack -= 1
End Sub
Function tMaze.drawMaze(byval Wallsize as Integer = 10) as any ptr
If (MazeP = 0) or (MazeW = 0) or (MazeH = 0) Then return 0
Dim mappos as Integer
Dim C as UInteger
Dim startc as Vector2
Dim goalc as Vector2
Dim MapImage as any ptr = ImageCreate(MazeW*WallSize,MazeH*WallSize)
For Y as Integer = 0 to MazeH-1
For X as Integer = 0 to MazeW-1
mappos = X+(Y*MazeW)
Select Case mazeP[mappos]
Case MazeFloor
C = &h222222
Case MazeStart
C = &h00FF00
startc.X = (Wallsize/2)+(X*Wallsize) : startc.Y = (Wallsize/2)+(Y*Wallsize)
Case MazeGoal
C = &hFFFF00
goalc.X = (Wallsize/2)+(X*Wallsize) : goalc.Y = (Wallsize/2)+(Y*Wallsize)
Case MazeWall
C = &hFFFFFF
Case MazeReachPath 'important to know, to set items and monsters... (or anything else...)
C = &h3333EE'&h222222'&hFF8800
Case Else
C = &hFF8800
End Select
line MapImage,(X*Wallsize,Y*Wallsize)-((Wallsize-1)+(X*Wallsize),(Wallsize-1)+(Y*Wallsize)),C,bf
Next X
Next Y
'start'n'goal help circles
'circle MapImage,(startc.X,startc.Y),100,&hFF0000'&h00FF00
'circle MapImage,(startc.X,startc.Y),Wallsize*4,&h00FF00
'circle MapImage,(goalc.X,goalc.Y),100,&hFF0000'&hFFFF00
'circle MapImage,(goalc.X,goalc.Y),Wallsize*4,&hFFFF00
return MapImage
End Function
Function tMaze.genMaze(Byval sizeW as ushort, byval sizeH as ushort) 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
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
'gen random start position
MazeS = type(getRandom(1,MazeW-2),getRandom(1,MazeH-2))
'gen random goals position (with minimal distance)
Do
MazeG = type(getRandom(1,MazeW-2),getRandom(1,MazeH-2))
Loop while Distance2i(MazeS,MazeG) < 2
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
'If MazeP Then deallocate(MazeP)
MazeStack = 0
MazeControl = 0
MazeW = 0
MazeH = 0
return -1'TRUE
End Function
''''TEST
screenres 800,600,32
Dim myMaze as tMaze
Dim mapMaze as any ptr
Dim genTime as double
do
genTime = Timer
myMaze.genMaze(80,60)
mapMaze = myMaze.drawMaze(10)
put(0,0),mapMaze,pset
genTime = Timer-genTime
locate 1,1:?genTime
sleep 100
myMaze.delMaze()
imagedestroy(mapMaze)
loop until multikey(&h01)