Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
myMaze3
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 19.03.2013 14:01:31 |
Randomize Timer
#Define MazeFloor &h00
#Define MazeStart &h01
#Define MazeGoal &h02
#Define MazeReachPath &h19
#Define MazeWall &h20
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 ushort
MazeH as ushort
Declare Function genMaze(Byval sizeW as ushort, byval sizeH as ushort) as Integer
Declare Function delMaze() as Integer
Declare Sub drawMaze(byval Wallsize as Integer = 10) '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
locate 1,1:?MazeStack
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
Sub tMaze.drawMaze(byval Wallsize as Integer = 10)
If (MazeP = 0) or (MazeW = 0) or (MazeH = 0) Then Exit Sub
Dim mappos as Integer
Dim C as UInteger
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
Case MazeGoal
C = &hFF0000
Case MazeWall
C = &hFFFFFF
Case MazeReachPath
C = &h8888FF
Case Else
C = &hFF8800
End Select
line (X*Wallsize,Y*Wallsize)-((Wallsize-1)+(X*Wallsize),(Wallsize-1)+(Y*Wallsize)),C,bf
Next X
Next Y
End Sub
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
dim dd as integer'test
Do
dd+=1
If MazeP Then delMaze()
MazeW = 2 * (sizeW\2) : MazeH = 2 * (sizeH\2) 'resize rect down to (mod 2)
If (MazeW < 8) Then MazeW = 8
If (MazeH < 8) Then MazeH = 8
'MazeW = sizeW:MazeH=sizeH
MazeP = callocate(MazeW*MazeH)'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 = 3 to 1 step -1
granularity = 2 ^ G '...16,8,4,2
numWalls = 1'(MazeW*MazeH)/G
For W as Integer = 0 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 = 0 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)
MazeControl = 1
locate 2,1:?dd
Loop until MazeControl
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
do
myMaze.genMaze(400,300)
myMaze.drawMaze(2)
sleep
myMaze.delMaze()
loop until multikey(&h01)