[bb] Rooms and Doors generator by Pakz [ 1+ years ago ]

Started by BlitzBot, June 29, 2017, 00:28:42

Previous topic - Next topic

BlitzBot

Title : Rooms and Doors generator
Author : Pakz
Posted : 1+ years ago

Description : This code I made for me to try and make a 3d level out of it using cubes. This is the 2d part where the map is stored in a array.

I have made something similar as this in Monkey. It did take me a while to get this working again without looking at the monkey version.


Code :
Code (blitzbasic) Select
Graphics 800,600,32,2
SetBuffer BackBuffer()

AppTitle "Map generator"

; mapwidthheight
Global mw=100
Global mh=100
;tilewidthheight
Global tw=GraphicsWidth()/mw
Global th=GraphicsHeight()/mh
;min/maxroomsizewh
Global minroomsize = 5
Global maxroomsize = 15

Dim map(mw,mh)

SeedRnd MilliSecs()

makemap

Global timer=CreateTimer(10)

While KeyDown(1) = False
WaitTimer timer
Cls
drawmap
If KeyDown(57) Or cnt>20 Then newmap:cnt=0
cnt=cnt+1
Color 255,255,255
Text 0,0,"Press space to generate new - esc = exit"
Flip
Wend
End

Function newmap()
For y=0 To mh
For x=0 To mw
map(x,y)=0
Next
Next
makemap
End Function

Function makemap()
map(mw/2,mh/2) = 3
Local total=Rand(20000,150000)
For i=0 To total
x = Rand(maxroomsize+2,mw-(maxroomsize+2))
y = Rand(maxroomsize+2,mh-(maxroomsize+2))
If map(x,y) = 3
a = Rand(0,4)
w=Rand(minroomsize,maxroomsize)
h=Rand(minroomsize,maxroomsize)
Select a
Case 0;nroom
If fits(x-w/2,y-h,w,h-1) = True
mr(x,y-h,x+w/2,y-h/2,x,y,x-w/2,y-h/2)
EndIf
Case 1;eroom
If fits(x+1,y-h/2,w,h) = True
mr(x+w/2,y-h/2,x+w,y,x+w/2,y+h/2,x,y)
EndIf
Case 2;sroom
If fits(x-w/2,y+1,w,h) = True
mr(x,y,x+w/2,y+h/2,x,y+h,x-w/2,y+h/2)
EndIf
Case 3;wroom
If fits(x-w-1,y-h/2,w,h) = True
mr(x-w/2,y-h/2,x,y,x-w/2,y+h/2,x-w,y)
EndIf
End Select
End If
Next
; here we remove left over doors
For y=2 To mh-2
For x=2 To mw-2
If map(x,y) = 3
; if into darkness then remove
If map(x-1,y) = 0 Or map(x+1,y) = 0
map(x,y) = 2
End If
If map(x,y-1) = 0 Or map(x,y+1) = 0
map(x,y) = 2
End If
cnt=0
; every door if blocked remove
For y1=y-1 To y+1
For x1=x-1 To x+1
If map(x1,y1) = 2 Then cnt=cnt+1
Next
Next
If cnt>2 Then map(x,y)=2
End If
Next
Next
End Function

; makeroom
Function mr(x1,y1,x2,y2,x3,y3,x4,y4)
For y5=y1 To y3
For x5=x4 To x2
map(x5,y5) = 1
Next
Next
For y5=y1 To y3
map(x4,y5) = 2
map(x2,y5) = 2
Next
For x5=x4 To x2
map(x5,y1) = 2
map(x5,y3) = 2
Next
map(x1,y1) = 3
map(x2,y2) = 3
map(x3,y3) = 3
map(x4,y4) = 3

End Function

; Is there anything in the map
Function fits(x,y,w,h)
; if outside
If x<0 Or y<0 Or x+w>mw Or y+h>mh Then Return False
; if inside
For y1=y To y+h
For x1=x To x+w
If map(x1,y1)>0 Then Return False
Next
Next
Return True
End Function

Function drawmap()
For y=0 To mh
For x=0 To mh
Select map(x,y)
Case 0;nothing
Color 0,0,0
Case 1;floor
Color 255,255,255
Case 2;wall
Color 100,100,100
Case 3;door
Color 255,0,0
End Select
Rect x*tw,y*th,tw,th
Next
Next
End Function


Comments :


Andy_A(Posted 1+ years ago)

 Nicely done.Thanks!


Rick Nasher(Posted 1+ years ago)

 Good stuff, now it only needs to savable and cube-ified.


dna(Posted 1+ years ago)

 Nice JobUseful for many other things


Dan(Posted 1+ years ago)

 Just4fun, i have written loading and saving function and while it i saw a small error in the above code:
Function drawmap()
For y=0 To mh
For x=0 To mh
the second mh should be mw. ( For x=0 To mw )Map Generator with loading and saving, make sure to change the Global f_path$="r:" , f_name$="room" , f_num=0 , f_ext$=".map"
to wherever you want them to be saved.;Map Generator - pakz
;load/save - dan

Graphics 800,600,32,2
SetBuffer BackBuffer()

AppTitle "Map generator"

Global f_path$="r:" , f_name$="room" , f_num=0 , f_ext$=".map"
Global key_delay=MilliSecs()
Global RN_Max=CheckFile()

; mapwidthheight
Global mw=100
Global mh=100
;tilewidthheight
Global tw=GraphicsWidth()/mw
Global th=GraphicsHeight()/mh
;min/maxroomsizewh
Global minroomsize = 5
Global maxroomsize = 15

Dim map(mw,mh)

SeedRnd MilliSecs()

makemap

Global timer=CreateTimer(10)

While KeyDown(1) = False
WaitTimer timer
Cls
drawmap
If KeyDown(57) Then newmap : AppTitle "Map generator" ;" "

If KeyDown(31) And KD(200) ;"s"
KD()
b$=savemap()
EndIf

If (KeyDown(38) Or KeyDown(28)) And KD(200) ;"l"
KD()
   If RN_Max=>0 Then
If loadmap(lr) = 1
drawmap
AppTitle "Viewing: "+f_path$+f_name$+getnum$(lr)+f_ext$
EndIf
EndIf
EndIf

If KeyDown(200) And KD(200) ;"Arrow Up"
KD()
LR=LR+1
If LR>RN_Max Then LR=0
EndIf

If KeyDown(208) And KD(200) ;"Arrow Down"
KD()
LR=LR-1
If LR<0 Then LR=RN_Max
If lr<0 Then lr=0
EndIf


Color 255,255,255
Text 0,0,"Press space to generate new - esc = exit s=save L,Enter=Load map - Arrow Up-Down select"
Text 0,14,"FileSaved="+RSet(b$,13)+"      Load room number: "+LSet(getnum$(LR),5)
   
Flip
Wend
End

Function newmap()
For y=0 To mh
For x=0 To mw
map(x,y)=0
Next
Next
makemap
End Function

Function makemap()
map(mw/2,mh/2) = 3
Local total=Rand(20000,150000)
For i=0 To total
x = Rand(maxroomsize+2,mw-(maxroomsize+2))
y = Rand(maxroomsize+2,mh-(maxroomsize+2))
If map(x,y) = 3
a = Rand(0,4)
w=Rand(minroomsize,maxroomsize)
h=Rand(minroomsize,maxroomsize)
Select a
Case 0;nroom
If fits(x-w/2,y-h,w,h-1) = True
mr(x,y-h,x+w/2,y-h/2,x,y,x-w/2,y-h/2)
EndIf
Case 1;eroom
If fits(x+1,y-h/2,w,h) = True
mr(x+w/2,y-h/2,x+w,y,x+w/2,y+h/2,x,y)
EndIf
Case 2;sroom
If fits(x-w/2,y+1,w,h) = True
mr(x,y,x+w/2,y+h/2,x,y+h,x-w/2,y+h/2)
EndIf
Case 3;wroom
If fits(x-w-1,y-h/2,w,h) = True
mr(x-w/2,y-h/2,x,y,x-w/2,y+h/2,x-w,y)
EndIf
End Select
End If
Next
; here we remove left over doors
For y=2 To mh-2
For x=2 To mw-2
If map(x,y) = 3
; if into darkness then remove
If map(x-1,y) = 0 Or map(x+1,y) = 0
map(x,y) = 2
End If
If map(x,y-1) = 0 Or map(x,y+1) = 0
map(x,y) = 2
End If
cnt=0
; every door if blocked remove
For y1=y-1 To y+1
For x1=x-1 To x+1
If map(x1,y1) = 2 Then cnt=cnt+1
Next
Next
If cnt>2 Then map(x,y)=2
End If
Next
Next
End Function

; makeroom
Function mr(x1,y1,x2,y2,x3,y3,x4,y4)
For y5=y1 To y3
For x5=x4 To x2
map(x5,y5) = 1
Next
Next
For y5=y1 To y3
map(x4,y5) = 2
map(x2,y5) = 2
Next
For x5=x4 To x2
map(x5,y1) = 2
map(x5,y3) = 2
Next
map(x1,y1) = 3
map(x2,y2) = 3
map(x3,y3) = 3
map(x4,y4) = 3

End Function

; Is there anything in the map
Function fits(x,y,w,h)
; if outside
If x<0 Or y<0 Or x+w>mw Or y+h>mh Then Return False
; if inside
For y1=y To y+h
For x1=x To x+w
If map(x1,y1)>0 Then Return False
Next
Next
Return True
End Function

Function drawmap()
For y=0 To mh
For x=0 To mw
Select map(x,y)
Case 0;nothing
Color 0,0,0
Case 1;floor
Color 255,255,255
Case 2;wall
Color 100,100,100
Case 3;door
Color 255,0,0
End Select
Rect x*tw,y*th,tw,th
Next
Next
End Function

Function savemap$()
    Repeat
   f_out$=f_path$+f_name$+getnum$(f_num)+f_ext$
check=FileType(f_out$)
If check=0
   RN_Max=f_num
file=WriteFile (f_out$)
Exit
ElseIf check=1
f_num=f_num+1
EndIf
Delay 1
Forever
WriteByte file,mh
WriteByte file,mw
For y=0 To mh
For x=0 To mw
WriteByte file,map(x,y)
Next
Next
CloseFile file
Return f_out$
End Function

Function loadmap$(x)
    Repeat
   f_out$=f_path$+f_name$+getnum$(x)+f_ext$
check=FileType(f_out$)
If check=1
file=ReadFile (f_out$)
Exit
ElseIf check=0 Or check=2
Return 0
EndIf
Delay 1
Forever
mh=ReadByte (file)
mw=ReadByte (file)
For y=0 To mh
For x=0 To mw
map(x,y)=ReadByte(file)
Next
Next
CloseFile file
Return 1
End Function

Function getnum$(number)
    ;adds "0" infront of the number,
b=5
If Len(number)<=b
a$=String("0",b-Len(number))+Str$(number)
Else
RuntimeError "File numbers are out"
EndIf
Return a$
End Function

Function KD(x=0)
;Keyboard delay
If x<=0 Then
key_delay=MilliSecs()
Else
If MilliSecs()-key_delay=>x Then Return 1
EndIf

Return 0
End Function

Function CheckFile()
;Check files for extension
myDir=ReadDir(f_path$)
Local num=-1

Repeat

file$=NextFile$(myDir)
If file$="" Then Exit

If FileType(f_path$+""+file$) = 1 Then
If Right$(file$,Len(f_ext$)) = f_ext Then num=num+1
EndIf
Forever

CloseDir myDir
Return num
End Function