Rooms and Doors generator

This code has been declared by its author to be Public Domain code.

Rooms and Doors generator by Pakz

2016

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.

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

2016

Nicely done.

Thanks!

Rick Nasher

2016

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

dna

2016

Nice Job

Useful for many other things

Dan

2016

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

Code Archives Forum