Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
myMaze4
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 21.03.2013 20:41:32 |
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(byref 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
If LastEntry Then
NewEntry -> PrevEntry = LastEntry
LastEntry -> NextEntry = NewEntry
LastEntry = NewEntry
End If
End Sub
Sub tList.DestroyList()
Dim ThisNode as tListNode ptr
Dim TempNode as tListNode ptr
ThisNode = LastEntry
Do
If ThisNode Then
TempNode = ThisNode -> PrevEntry
DelEntry(ThisNode)
ThisNode = TempNode
End If
Loop while ThisNode
End Sub
Sub tList.DelEntry(byref ListNode as tListNode ptr)
If ListNode -> NextEntry Then ListNode -> NextEntry -> PrevEntry = ListNode -> PrevEntry
If ListNode -> PrevEntry Then ListNode -> PrevEntry -> NextEntry = ListNode -> NextEntry
If FirstEntry = ListNode Then FirstEntry = FirstEntry -> NextEntry
If LastEntry = ListNode Then LastEntry = LastEntry -> PrevEntry
Delete ListNode
End Sub
Randomize Timer
#Define MazeFloor &h00
#Define MazeStart &h01
#Define MazeGoal &h02
'Ready-Room-Floor: Experimental with ready rooms...
#Define MazeRRFloor_1 &h03
'...define... Items or anything else... here
'MazeReachPath: important to know, to set items and monsters... (or anything else...)
#Define MazeReachPath &h69
#Define MazeWall &h70
'Ready-Room-Wall: Experimental with ready rooms...
#Define MazeRRWall_1 &h71
'...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
Private:
Declare Sub fillPath(byval posX as Integer, byval posY as Integer)
Declare Sub fillPath2(byval posX as Integer, byval posY as Integer)
MazeControl as Integer
MazeStack as UInteger
MazeP as ubyte ptr
MazeW as integer
MazeH as integer
Public:
Declare Function genMaze(Byval sizeW as integer, byval sizeH as integer) as Integer
Declare Function delMaze() as Integer
Declare Function drawMaze(byval Wallsize as Integer = 10) as any ptr'for tests only
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 < 8048) 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.fillPath2(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)
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
mappos = 0
Do
if (fillmap[mappos] = 1) Then
If (MazeP[mappos] = MazeFloor) Then MazeP[mappos] = MazeReachPath
If (MazeP[mappos] = MazeGoal ) Then MazeControl = 1
End If
mappos += 1
Loop while (mappos < (MazeW*MazeH))
Delete[] fillmap
fillList.DestroyList()
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 = &h6666FF'&h222222
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 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
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
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) < 4)
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)
fillPath2(MazeS.X,MazeS.Y) 'mark all reachable tiles (from start)
If (MazeControl = 0) Then ?"Repeat"
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)
MazeP = 0
MazeStack = 0
MazeControl = 0
MazeW = 0
MazeH = 0
return -1'TRUE
End Function
''''TEST
screenres 1920,1080,32,,&h08
Dim myMaze as tMaze
Dim mapMaze as any ptr
Dim mappos as UInteger
Dim savenum as UInteger
Dim cycles as UInteger
Dim sizex as integer
dim sizey as integer
do
cycles += 1
'sizex=getRandom(50,80)
'sizey=getRandom(40,60)
myMaze.genMaze(1920,1080)
mapMaze = myMaze.drawMaze(1)
screenlock
cls
put(0,0),mapMaze,pset
screenunlock
sleep
myMaze.delMaze()
imagedestroy(mapMaze)
mapMaze = 0
loop until multikey(&h01)