Based on https://www.youtube.com/watch?v=ZZY9YE7rZJw
This code creates from a seed a labyrinth.
Code: Select all
; 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()
