Procedural Generation Labyrinth

Hier könnt Ihr gute, von Euch geschriebene Codes posten. Sie müssen auf jeden Fall funktionieren und sollten möglichst effizient, elegant und beispielhaft oder einfach nur cool sein.
GPI
Beiträge: 1511
Registriert: 29.08.2004 13:18
Kontaktdaten:

Procedural Generation Labyrinth

Beitrag von GPI »

Bild

Basiert grob auf https://www.youtube.com/watch?v=ZZY9YE7rZJw

Der Code erzeugt anhand eines Seeds ein eindeutiges Labyrinth.

Code: Alles auswählen

; Based on https://www.youtube.com/watch?v=ZZY9YE7rZJw

DeclareModule RND
  EnableExplicit
  
  ; get a random number (32bit)
  Declare.l get()
  
  ; get a random double value - between min and max (inclusiv)
  Declare.d double(min.d, max.d)
  
  ; get a  random long value - beween min and max (inclusiv)
  Declare.l long(min.l, max.l)
  
  ; flip a coin (true or false)
  Declare.l coin()
  
  ; get the current Seed-Status
  Declare.l GetSeed()
  
  ; set a seed-status. subseed is optional and is xor-ed with the seed.
  Declare Seed(seed.l, subseed.l = 0)
  
  ; convert a string to 4 diffrent seed-values.
  Declare SeedSplitter(seed.s, *s1.long, *s2.long=#Null, *s3.long=#Null, *s4.long=#Null)
EndDeclareModule

Module RND
  Global nProcGen
  
  Procedure.d double(min.d, max.d)
    Protected.q rnd = get() & $ffffffff
    ProcedureReturn rnd / $FFFFFFFF * (max - min) + min
  EndProcedure
  
  Procedure.l long(min.l, max.l)
    Protected.q rnd = get() & $ffffffff
    ProcedureReturn (rnd % ( max - min +1) ) + min
  EndProcedure
  
  Procedure.l coin()
    ProcedureReturn Bool(get()>=0)
  EndProcedure
  
  Procedure Seed(seed.l, subseed.l = 0)
    nProcGen = seed ! subseed
  EndProcedure
  
  Procedure.l GetSeed()
    ProcedureReturn nProcGen
  EndProcedure
		
	; Modified from this for 64-bit systems:
	; https://lemire.me/blog/2019/03/19/the-fastest-conventional-random-number-generator-that-can-pass-big-crush/
	; Now I found the link again - Also, check out his blog, it's a fantastic resource!
	Procedure.l get()
	  Protected.q tmp
	  Protected.l m1, m2
	  
	  nProcGen + $e120fc15
	  tmp = nProcGen * $4a39b70d
	  m1 = (tmp >> 32) ! tmp;
		tmp = m1 * $12fad5c9
		m2 = (tmp >> 32) ! tmp
		ProcedureReturn m2
	EndProcedure	
	
	UseMD5Fingerprint()
	Procedure SeedSplitter(seed.s, *s1.long, *s2.long=#Null, *s3.long=#Null, *s4.long=#Null)
	  Protected.s md5
	  Protected *buf = Ascii(seed)
	  md5.s=Fingerprint(*buf, Len(seed) ,#PB_Cipher_MD5)
	  FreeMemory(*buf)
	  If *s1
	    *s1\l = Val("$" + Mid(md5,1+ 8*0,8))
	  EndIf
	  If *s2
	    *s2\l = Val("$" + Mid(md5,1+ 8*1,8))
	  EndIf
	  If *s3
	    *s3\l = Val("$" + Mid(md5,1+ 8*2,8))
	  EndIf
	  If *s4
	    *s4\l = Val("$" + Mid(md5,1+ 8*3,8))
	  EndIf
; 	  Debug md5
; 	  Debug Hex(*s1\l)
; 	  Debug Hex(*s2\l)
; 	  Debug Hex(*s3\l)
; 	  Debug Hex(*s4\l)
	EndProcedure
	
EndModule 


;- example labyrinth

EnableExplicit

;- our seed
Define.s mySeed = "This can be any string!"

;- settings
#width = 79
#height = 23
#maxRoom = 10

; OpenConsole("Random-Test")
; For y=0 To 23
;   For x=0 To 79
;     rnd::Seed(s1, x<<16 | y)
;     Print( Chr( rnd::long('a','z') ) )
;   Next
;   PrintN("")
; Next
; Input()
; CloseConsole()

;- field-enumeration
Enumeration
  #empty
  #wall
  #roomwall
  #roomwall10 = #roomwall+#maxRoom
  #cornerwall
  #cornerwall10 = #cornerwall+#maxRoom
  #room 
  #room10 = #room+#maxRoom
  #door
  #door10 = #door+#maxRoom
EndEnumeration

;- direcitons enumeration
EnumerationBinary
  #noway = 0
  #left
  #right
  #up
  #down
EndEnumeration

; room-variables
Structure sRoom
  entries.l ; max number of entries (will be decreased during creation)
  dir.l ; check if the room is enterable from this direction (prevent creation of two doors on one side)
  accessable.l ; is connected to floor
EndStructure  

Global Dim field(#width -1, #height -1)
Global Dim Room.sRoom(#maxRoom-1)

; move x/y in direction
Procedure move(*x.long, *y.long, dir.l)
  Select dir
    Case #left : *x\l -1
    Case #right : *x\l +1
    Case #up : *y\l -1
    Case #down : *y\l +1
  EndSelect
EndProcedure

; test if it is a wall - used for checks, if a wall can be removed
Procedure isWall(x.l,y.l)
  ; outside the field -> no wall
  If x < 0 Or y < 0 Or x >= #width Or y >= #height
    ProcedureReturn #False
  EndIf
  
  Select field(x,y)
    Case #empty
      ProcedureReturn #False
    Case #wall
      ProcedureReturn #True
    Case #roomwall To #roomwall10
      ProcedureReturn #True
    Case #cornerwall To #cornerwall10
      ProcedureReturn #True
    Case #room To #room10 ; roomfield are handeld as wall, so the floor can connect
      ProcedureReturn #True
    Case #door To #door10
      ProcedureReturn #False
    Default
      ProcedureReturn #False
  EndSelect
EndProcedure

; can the field removed?
Procedure isRemoveableWall(x.l,y.l,dir.l)
  Protected.l room
  ; outside -> no
  If x < 0 Or y < 0 Or x >= #width Or y >= #height
    ProcedureReturn #False
  EndIf
  
  Select field(x,y)
    Case #empty
      ProcedureReturn #False
    Case #wall
      ProcedureReturn #True
    Case #roomwall To #roomwall10
      room = field(x,y) - #roomwall
      ; only when in this direction is no door and the max amount of entries is high engough
      If Room(room)\entries > 0 And Room(room)\dir & dir = #False
        ProcedureReturn #True
      Else
        ProcedureReturn #False
      EndIf
    Case #cornerwall To #cornerwall10
      ProcedureReturn #False
    Case #room To #room10
      ProcedureReturn #False
    Case #door To #door10
      ProcedureReturn #False
    Default
      ProcedureReturn #False
  EndSelect
  
EndProcedure

; check, if floor generation should stop on the field
Procedure isStopFloor(x.l,y.l)
  If x < 0 Or y < 0 Or x >= #width Or y >= #height
    ProcedureReturn #False
  EndIf
  
  Select field(x,y)
    Case #empty
      ProcedureReturn #False
    Case #wall
      ProcedureReturn #False
    Case #roomwall To #roomwall10
      ProcedureReturn #True
    Case #cornerwall To #cornerwall10
      ProcedureReturn #True
    Case #room To #room10
      ProcedureReturn #True
    Case #door To #door10
      ProcedureReturn #True
    Default
      ProcedureReturn #False
  EndSelect
  
EndProcedure

; remove a wall
Procedure Remove(x.l,y.l,dir.l)
  Protected.l room
  
  If x < 0 Or y < 0 Or x >= #width Or y >= #height
    ProcedureReturn #False
  EndIf
  Select field(x,y)
    Case #empty
      ; empty field - nothing to do
    Case #wall
      field(x,y) = #empty
    Case #cornerwall To #cornerwall10
      ; corners should not removed!
    Case #roomwall To #roomwall10
      room =  field(x,y) - #roomwall
      Room( room )\entries -1 ; lower max entries
      Room( room )\accessable = #True ; is accesable
      Room( room )\dir | dir; from this direction
      field(x,y) = field(x,y) - #roomwall + #door; set to door
    Case #room To #room10
      ; room is already empty
    Default
      ; nothing to do
  EndSelect
EndProcedure
     
; check if the next wall in that direction can be removed
Procedure.l CanRemoved(x.l,y.l, dir.l)
  move(@x, @y, dir); on step in the direction
  
  If Not isRemoveableWall(x,y,dir)
    ProcedureReturn #False
  EndIf
  
  ; borders must be a wall, otherwise it can't removed without connecting to floors
  
  If dir <> #right And Not isWall(x-1,y)
    ProcedureReturn #False
  EndIf
  
  If dir <> #left And Not isWall(x+1,y)
    ProcedureReturn #False
  EndIf
  
  If dir <> #down And Not isWall(x,y-1)
    ProcedureReturn #False
  EndIf
  
  If dir <> #up And Not isWall(x,y+1)
    ProcedureReturn #False
  EndIf
  
  ProcedureReturn #True
EndProcedure

; find possibles directions
Procedure.l possibleMoves(x,y)
  Protected.l ret
  If CanRemoved(x,y, #left)
    ret | #left
  EndIf
  If CanRemoved(x,y, #right)
    ret | #right
  EndIf
  If CanRemoved(x,y, #up)
    ret | #up
  EndIf
  If CanRemoved(x,y, #down)
    ret | #down
  EndIf
  ProcedureReturn ret
EndProcedure

; choose a direction
Procedure.l ChooseDirection(dir.l)
  Protected.l count
  If dir & #left
    count+1
  EndIf
  If dir & #right
    count+1
  EndIf
  If dir & #up
    count+1
  EndIf
  If dir & #down
    count+1
  EndIf
  
  If count = 0
    ProcedureReturn #noway
  EndIf
  
  Protected.l rnd
  rnd=rnd::long(1,count)
  
  If dir & #left
    rnd-1
    If rnd <=0 
      ProcedureReturn #left
    EndIf
  EndIf
  If dir & #right
    rnd-1
    If rnd <=0 
      ProcedureReturn #right
    EndIf
  EndIf
  If dir & #up
    rnd-1
    If rnd <=0 
      ProcedureReturn #up
    EndIf
  EndIf
  If dir & #down
    rnd-1
    If rnd <=0 
      ProcedureReturn #down
    EndIf
  EndIf
  Debug "SHOULD NOT HAPPEN!"
  ProcedureReturn #noway
EndProcedure

; draw field x,y
Procedure DrawXY(x.l,y.l)
  ConsoleLocate(x,y)
  Select field(x,y)
    Case #empty
      ConsoleColor(15,0)
      Print(".")
    Case #wall
      ConsoleColor(15,15)
      Print("#")
    Case #roomwall To #roomwall10
      ConsoleColor(field(x,y)-#roomwall+1,15)
      Print("#")
    Case #cornerwall To #cornerwall10
      ConsoleColor(field(x,y)-#cornerwall+1,15)
      Print("#")
    Case #room To #room10
      ConsoleColor(field(x,y)-#room+1,0)
      Print(".")
    Case #door To #door10
      ConsoleColor(field(x,y)-#door+1,0)
      Print("X")
    Default
      ConsoleColor(15,0)
      Print("?")
      Debug field(x,y)
      
  EndSelect
EndProcedure

; draw complete field
Procedure outputField()
  Protected.l x,y
  ;ClearConsole()
  ConsoleLocate(0,0)
  For y=0 To #height -1
    For x=0 To #width -1
      DrawXY(x,y)
    Next
  Next
EndProcedure


;- main

Define.l x,xx,y,yy,i,w,h

; cache for old postion. Needed for generation a new connected floor
Structure xy
  x.l
  y.l
EndStructure
NewList oldposition.xy()

OpenConsole("Procedural Generation Labytest: "+mySeed)
EnableGraphicalConsole(#True)

;- split our seed to 4 values. 
Define.l s1,s2,s3,s4
rnd::SeedSplitter(mySeed, @s1,@s2,@s3,@s4)

;- set creation-variables
rnd::Seed(s1)
Define.l StartPosX = rnd::long(1, #width - 2)
Define.l StartPosY = rnd::long(1, #height - 2)
Define.l FloorSize = rnd::long(1,10)
Define.l FloorMulti = rnd::long(1,3)

FloorSize / FloorMulti
If FloorSize <1 : FloorSize = 1 : EndIf

Define.l rooms = rnd::long(0,#maxRoom-1)

;- initalize field
For x=0 To #width-1
  For y=0 To #height-1
    field(x,y) = #wall
  Next
Next

; Clear start-position
field(startposX, StartPosY) = #empty

;- create rooms
For i = 0 To rooms
  w = rnd::long(3,10)
  h = rnd::long(3,10)
  Room(i)\entries = rnd::long(1,4)
  Room(i)\accessable = #False
  Room(i)\dir = #noway
  
  Define.l errortry = 0; prevent a endless loop
  Repeat
    x = rnd::long(0,#width -1 - w)
    y = rnd::long(0,#height -1 - h)
    
    ; check if position is free
    Define.l ok = #True
    For xx= x To x+w
      For yy = y To y+h
        If field(xx,yy) <> #wall
          ok=#False
        EndIf
      Next
    Next
    
    ErrorTry + 1
  Until ok Or errortry > 10
  
  If ok
    ; initalize room
    For yy=y To y+h
      For xx=x To x+w
        If (yy=y Or yy=y+h) And (xx=x Or xx=x+w)
          field(xx,yy) = #cornerwall +i
        ElseIf yy=y Or yy=y+h Or xx=x Or xx=x+w
          field(xx,yy) = #roomwall +i
        Else
          field(xx,yy) = #room+i
        EndIf
      Next
    Next
  EndIf
  
Next

; output complete field
outputField()

;- creationllopp
x=startposX
y=StartPosY

Repeat
  Repeat
    Define.l dir = possibleMoves(x,y)
    
    ; no direction or in room?
    If dir = 0 Or isStopFloor(x,y)
      ; remove current position in oldposition
      DeleteElement(oldposition())
      If  ListSize(oldposition()) =0  
        Break
      EndIf
      
      ; choose a random position with seed s3
      rnd::seed(s3, x<<16 | y )
      Define.l newpos = rnd::long(0, ListSize(oldposition()) -1 )
       
      SelectElement(oldposition(), newpos )
          
      x = oldposition()\x
      y = oldposition()\y
      ConsoleLocate(x,y)
    EndIf
  Until dir 
  
  If dir = 0 
    Break
  EndIf
  
  ; choos a direction and size of this floor
  rnd::seed(s2, x<<16 | y)
  Define.l count = rnd::long(1,floorSize) * FloorMulti
  Define.l dir = ChooseDirection(dir)  
  
  ; remove walls
  While count > 0 And isStopFloor(x,y) = #False
    count -1
    If Not CanRemoved(x,y,dir)
      Break
    EndIf
    
    move(@x,@y, dir)
    
    AddElement(oldposition())
    oldposition()\x = x
    oldposition()\y = y
    
    remove(x,y,dir)
   
    DrawXY(x,y)
    
    Delay(16) ; otherwise it would be too fast
  Wend  
  
ForEver

; set cursor on start-postion
ConsoleLocate(StartPosX, StartPosY)

Input()
CloseConsole()
CodeArchiv Rebirth: Deutsches Forum Github Hilfe ist immer gern gesehen!