Code: Select all
DeclareModule Dungeon
Structure ROOM
x.i
y.i
w.i
h.i
EndStructure
Declare.b generate(w.i,h.i,minRooms.i,maxRooms.i,minRoomSize,maxRoomSize.i)
Declare.b DoesCollide(*room.ROOM,ignore.i=-1)
Declare SquashRooms()
Declare.b FindClosestRoom(*room.ROOM,*org.ROOM)
Declare Test()
EndDeclareModule
Module Dungeon
EnableExplicit
#INVALID = -1
Enumeration TILE_TYPE
#EMPTY = 0
#TILE
#WALL
EndEnumeration
Structure XY
x.i
y.i
EndStructure
Declare.i Min(x.i,y.i)
Declare.i max(x.i,y.i)
Declare.b checkConnectivity(floorVal.i)
Declare.b floodFill(x.i,y.i,oldVal.i,newVal.i)
Declare.b findLoneRoom(x.i,y.i)
Declare.b isRoomAlreadyInLoneList(List orphanIndex.i(),index.i)
Declare.b DrawCorridor(*roomB.ROOM,*roomA.room)
Declare.b ProcessCorridor(oIndex.i)
Declare.i findNonOrphanedRoom(List orphanIndex.i(),index.i,dir.i)
Global.i width,height
Global.i min_size=5
Global.i max_size=15
Global Dim _map(0,0)
Global NewList rooms.ROOM()
Global NewList stack.XY()
Procedure.b generate(w.i,h.i,minRooms.i,maxRooms.i,minRoomSize,maxRoomSize.i)
Define.i x,y,xx,yy,room_count,i
Define room.ROOM
Define.i try
Define roomB.ROOM
Define pointA.POINT
Define pointB.POINT
If w<3 Or h<3 Or minRooms<1 Or maxRooms<1 Or minRoomSize<1 Or maxRoomSize<1 : ProcedureReturn #False : EndIf
width=w+3
height=h+3
room_count=Random(maxRooms,minRooms)
min_size=minRoomSize
max_size=maxRoomSize
Dim _map(width,height)
For y=0 To height-1
For x=0 To width-1
_map(x,y)=#EMPTY
Next
Next
ClearList(rooms())
While ListSize(rooms())<room_count
room\x=Random(width-max_size-1,1)
room\y=Random(height-max_size-1,1)
room\w=Random(max_size,min_size)
room\h=Random(max_size,min_size)
If DoesCollide(@room)=#False
room\w-1
room\h-1
AddElement(rooms())
rooms()=room
EndIf
Wend
SquashRooms()
ForEach rooms()
For x=rooms()\x To rooms()\x+rooms()\w-1
For y=rooms()\y To rooms()\y+rooms()\h-1
_map(x,y)=#TILE
Next
Next
Next
For i=0 To ListSize(rooms())-1
ProcessCorridor(i)
Next
; For x=0 To width-1
; For y=0 To height-1
; If _map(x,y)=#TILE
; For xx=x-1 To x+1
; For yy=y-1 To y+1
; If _map(xx,yy)=#EMPTY : _map(xx,yy)=#WALL : EndIf
; Next
; Next
; EndIf
; Next
; Next
If checkConnectivity(#TILE)
For x=0 To width-1
For y=0 To height-1
If _map(x,y)=#TILE
For xx=x-1 To x+1
For yy=y-1 To y+1
If _map(xx,yy)=#EMPTY : _map(xx,yy)=#WALL : EndIf
Next
Next
EndIf
Next
Next
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
Procedure.b FindClosestRoom(*room.ROOM,*org.ROOM)
Define *oldRoom.ROOM
Define mid.POINT
Define check_mid.POINT
Define *check.ROOM
; Define *closest.ROOM
;Define *room.ROOM
Define.i closest_distance,distance
Define.i i
Define.b found
If *org=#Null : ProcedureReturn #False : EndIf
mid\x=*org\x+(*org\w/2)
mid\y=*org\y+(*org\h/2)
;*closest=#Null
closest_distance=1000
; Store the current room index
*oldRoom=@rooms()
ForEach rooms()
If rooms()=*org
;Debug Str(rooms()\x)+" "+Str(rooms()\y)+" "+Str(rooms()\w)+" "+Str(rooms()\h)
;Debug Str(*org\x)+" "+Str(*org\y)+" "+Str(*org\w)+" "+Str(*org\h)
Continue
Else
check_mid\x=rooms()\x+(rooms()\w/2)
check_mid\y=rooms()\y+(rooms()\h/2)
distance=Min(Abs(mid\x-check_mid\x)-(*org\w/2)-(rooms()\w/2),Abs(mid\y-check_mid\y)-(*org\h/2)-(rooms()\h/2))
If distance<closest_distance
closest_distance=distance
CopyStructure(@rooms(),*room,ROOM)
found=#True
EndIf
EndIf
Next
ChangeCurrentElement(rooms(),*oldRoom)
ProcedureReturn Bool(found=#True)
EndProcedure
Procedure.b checkConnectivity(floorVal.i)
Define.i floorX,floorY,index,loop,x,y,orgIndex,newIndex
Define NewList orphanIndex.i()
Define roomA.ROOM
Define roomB.ROOM
Repeat
floorX=Random(width-1)
floorY=Random(height-1)
Until _map(floorX,floorY)=floorVal
floodFill(floorX,floorY,#INVALID,3)
;ProcedureReturn #True
; Check If anything wasn't flooded
ClearList(orphanIndex())
For x=0 To width-1
For y=0 To height-1
If _map(x,y)=floorVal
index=findLoneRoom(x,y)
If index>=0
If isRoomAlreadyInLoneList(orphanIndex(),index)=#False
AddElement(orphanIndex())
orphanIndex()=index
EndIf
EndIf
EndIf
Next
Next
floodFill(floorX, floorY, #INVALID, floorVal)
;Debug "Number of orphaned rooms : "+ListSize(orphanIndex())
;ProcedureReturn #True
For index=0 To ListSize(orphanIndex())-1
If SelectElement(orphanIndex(),index)
orgIndex=orphanIndex()
newIndex=findNonOrphanedRoom(orphanIndex(),orgIndex,-1)
If newIndex<0 : newIndex=findNonOrphanedRoom(orphanIndex(),orgIndex,1) : EndIf
If newIndex<0 : ProcedureReturn #False : EndIf
If SelectElement(rooms(),orgIndex)
roomA=rooms()
If SelectElement(rooms(),newIndex)
roomB=rooms()
DrawCorridor(@roomB,@roomA)
Else
ProcedureReturn #False
EndIf
Else
ProcedureReturn #False
EndIf
EndIf
Next
ProcedureReturn #True
EndProcedure
Procedure.b DrawCorridor(*roomB.ROOM,*roomA.room)
Define pointA.XY
Define pointB.XY
; End
pointA\x=Random(*roomA\x+*roomA\w,*roomA\x)
pointA\y=Random(*roomA\y+*roomA\h,*roomA\y)
; Start
pointB\x=Random(*roomB\x+*roomB\w,*roomB\x)
pointB\y=Random(*roomB\y+*roomB\h,*roomB\y)
While pointB\x<>pointA\x Or pointB\y<>pointA\y
If pointB\x<>pointA\x
If pointB\x>pointA\x
pointB\x-1
Else
pointB\x+1
EndIf
ElseIf pointB\y<>pointA\y
If pointB\y>pointA\y
pointB\y-1
Else
pointB\y+1
EndIf
EndIf
_map(pointB\x,pointB\y)=#TILE
Wend
EndProcedure
Procedure.b ProcessCorridor(oIndex.i)
Define roomB.ROOM
If SelectElement(rooms(),oIndex)
If FindClosestRoom(@roomB,@rooms())
DrawCorridor(@roomB,@rooms())
ProcedureReturn #True
EndIf
EndIf
ProcedureReturn #False
EndProcedure
Procedure.i findNonOrphanedRoom(List orphanIndex.i(),index.i,dir.i)
Define start.i
start=index+Sign(dir)
While (start>=0 And start<ListSize(orphanIndex())) And isRoomAlreadyInLoneList(orphanIndex(),start)
start+Sign(dir)
Wend
If start<0 Or start>=ListSize(orphanIndex())
ProcedureReturn #INVALID
Else
ProcedureReturn start
EndIf
EndProcedure
Procedure.b findLoneRoom(x.i,y.i)
Define.i loop,mn,mx,pos
For loop=0 To ListSize(rooms())-1
If SelectElement(rooms(),loop)
If x>=rooms()\x And x<rooms()\x+rooms()\w And y>=rooms()\y And y<rooms()\y+rooms()\h
ProcedureReturn loop
EndIf
EndIf
Next
ProcedureReturn #INVALID
EndProcedure
Procedure.b isRoomAlreadyInLoneList(List orphanIndex.i(),index.i)
ForEach orphanIndex()
If orphanIndex()=index
ProcedureReturn #True
EndIf
Next
ProcedureReturn #False
EndProcedure
Procedure.b floodFill(x.i,y.i,oldVal.i,newVal.i)
ClearList(stack())
AddElement(stack())
stack()\x=x
stack()\y=y
;stack()\oldVal=oldVal
;stack()\newVal=newVal
While FirstElement(stack())
x=stack()\x
y=stack()\y
DeleteElement(stack())
If x<0 Or y<0 Or x>=width Or y>=height : Continue : EndIf
If oldVal=#INVALID : oldVal=_map(x,y) : EndIf
;Debug Str(oldVal)+" "+Str(_map(x,y))
If _map(x,y)<>oldVal : Continue : EndIf
;Debug "N:"+Str(newVal)
_map(x,y)=newVal
AddElement(stack()) : stack()\x=x-1 : stack()\y=y
AddElement(stack()) : stack()\x=x+1 : stack()\y=y
AddElement(stack()) : stack()\x=x : stack()\y=y-1
AddElement(stack()) : stack()\x=x : stack()\y=y+1
Wend
ProcedureReturn #True
EndProcedure
Procedure.b DoesCollide(*room.ROOM,ignore.i=-1)
Define.i loop
For loop=0 To ListSize(rooms())-1
If loop=ignore
Continue
ElseIf SelectElement(rooms(),loop)
If Not((*room\x+*room\w<rooms()\x) Or (*room\x>rooms()\x+rooms()\w) Or
(*room\y+*room\h<rooms()\y) Or (*room\y>rooms()\y+rooms()\h))
ProcedureReturn #True
EndIf
EndIf
Next
ProcedureReturn #False
EndProcedure
Procedure SquashRooms()
Define.i i
Define.i j
Define old_position.XY
; Must use select element as the DoesCollide routine would affect the position of an array loop, causing rooms to be disconnected
For i=0 To 16
For j=0 To ListSize(rooms())-1
If SelectElement(rooms(),j)
While #True
old_position\x=rooms()\x
old_position\y=rooms()\y
If rooms()\x>1 : rooms()\x-1 : EndIf
If rooms()\y>1 : rooms()\y-1 : EndIf
If rooms()\x=1 And rooms()\y=1
Break
ElseIf DoesCollide(@rooms(),j)
rooms()\x=old_position\x
rooms()\y=old_position\y
Break
EndIf
Wend
EndIf
Next
Next
EndProcedure
Procedure.i Min(x.i,y.i)
If x<y
ProcedureReturn x
Else
ProcedureReturn y
EndIf
EndProcedure
Procedure.i Max(x.i,y.i)
If x>y
ProcedureReturn y
Else
ProcedureReturn x
EndIf
EndProcedure
Procedure Test()
Define.i x,y
Define.s t
For y=0 To height-1
t=""
For x=0 To width-1
If _map(x,y)=#EMPTY
t+" "
ElseIf _map(x,y)=#TILE
t+"X"
ElseIf _map(x,y)=#WALL
t+"#"
Else
t+Chr(_map(x,y))
EndIf
Next
Debug t
Next
EndProcedure
EndModule
Debug "Result :"+Str(Dungeon::generate(128,128,8,32,4,24))
Dungeon::Test()