Dungeon creation routine

Share your advanced knowledge/code with the community.
User avatar
MrTAToad
Posts: 291
Joined: Sun Apr 20, 2014 11:43 am
Location: Chichester, England
Contact:

Dungeon creation routine

Post by MrTAToad »

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()
This is a dungeon generator routine (originally based on code by Big Bad Waffle). His original code had a very simple idea for non-connected rooms : restart it. As this wasn't really acceptable, I had to add code to make sure all rooms are connected.
tj1010
Posts: 201
Joined: Wed May 27, 2015 1:36 pm
Contact:

Re: Dungeon creation routine

Post by tj1010 »

Nice work you could probably do it in half or a third of the code if you spent a lot of time on it.

I didn't really look at how you did path selection which is probably the hard part since you can't just do collision and levels would ideally be finite. I'm really in to AI stuff but am too lazy to build and test networks.
User avatar
MrTAToad
Posts: 291
Joined: Sun Apr 20, 2014 11:43 am
Location: Chichester, England
Contact:

Re: Dungeon creation routine

Post by MrTAToad »

It would all depend on readability v performance. There isn't really much that could be done to reduce the code size, beyond removing all the debug statements.
tj1010
Posts: 201
Joined: Wed May 27, 2015 1:36 pm
Contact:

Re: Dungeon creation routine

Post by tj1010 »

You could crunch most of those conditional stacks, for example, but yeah it doesn't consume enough CPU and bytes to matter as is.
User avatar
MrTAToad
Posts: 291
Joined: Sun Apr 20, 2014 11:43 am
Location: Chichester, England
Contact:

Re: Dungeon creation routine

Post by MrTAToad »

Amusingly, I converted it from Javascript... ` Which SpiderBasic will turn it back into...
Post Reply