October 28, 2021, 12:33:26

Author Topic: [bb] Rooms and Doors generator by Pakz [ 1+ years ago ]  (Read 611 times)

Offline BlitzBot

  • Jr. Member
  • **
  • Posts: 1
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
  1. Graphics 800,600,32,2
  2. SetBuffer BackBuffer()
  3.  
  4. AppTitle "Map generator"
  5.  
  6. ; mapwidthheight
  7. Global mw=100
  8. Global mh=100
  9. ;tilewidthheight
  10. Global tw=GraphicsWidth()/mw
  11. Global th=GraphicsHeight()/mh
  12. ;min/maxroomsizewh
  13. Global minroomsize = 5
  14. Global maxroomsize = 15
  15.  
  16. Dim map(mw,mh)
  17.  
  18. SeedRnd MilliSecs()
  19.  
  20. makemap
  21.  
  22. Global timer=CreateTimer(10)
  23.  
  24. While KeyDown(1) = False
  25.         WaitTimer timer
  26.         Cls
  27.         drawmap
  28.         If KeyDown(57) Or cnt>20 Then newmap:cnt=0
  29.         cnt=cnt+1
  30.         Color 255,255,255
  31.         Text 0,0,"Press space to generate new - esc = exit"
  32.         Flip
  33. Wend
  34. End
  35.  
  36. Function newmap()
  37.         For y=0 To mh
  38.         For x=0 To mw
  39.                 map(x,y)=0
  40.         Next
  41.         Next
  42.         makemap
  43. End Function
  44.  
  45. Function makemap()
  46.         map(mw/2,mh/2) = 3
  47.         Local total=Rand(20000,150000)
  48.         For i=0 To total
  49.                 x = Rand(maxroomsize+2,mw-(maxroomsize+2))
  50.                 y = Rand(maxroomsize+2,mh-(maxroomsize+2))
  51.                 If map(x,y) = 3
  52.                         a = Rand(0,4)
  53.                         w=Rand(minroomsize,maxroomsize)
  54.                         h=Rand(minroomsize,maxroomsize)
  55.                         Select a
  56.                                 Case 0;nroom
  57.                                 If fits(x-w/2,y-h,w,h-1) = True
  58.                                         mr(x,y-h,x+w/2,y-h/2,x,y,x-w/2,y-h/2)
  59.                                 EndIf
  60.                                 Case 1;eroom
  61.                                 If fits(x+1,y-h/2,w,h) = True
  62.                                         mr(x+w/2,y-h/2,x+w,y,x+w/2,y+h/2,x,y)
  63.                                 EndIf
  64.                                 Case 2;sroom
  65.                                 If fits(x-w/2,y+1,w,h) = True
  66.                                         mr(x,y,x+w/2,y+h/2,x,y+h,x-w/2,y+h/2)
  67.                                 EndIf
  68.                                 Case 3;wroom
  69.                                 If fits(x-w-1,y-h/2,w,h) = True
  70.                                         mr(x-w/2,y-h/2,x,y,x-w/2,y+h/2,x-w,y)
  71.                                 EndIf
  72.                         End Select
  73.                 End If
  74.         Next
  75.         ; here we remove left over doors
  76.         For y=2 To mh-2
  77.         For x=2 To mw-2
  78.                 If map(x,y) = 3
  79.                         ; if into darkness then remove
  80.                         If map(x-1,y) = 0 Or map(x+1,y) = 0
  81.                                 map(x,y) = 2
  82.                         End If
  83.                         If map(x,y-1) = 0 Or map(x,y+1) = 0
  84.                                 map(x,y) = 2
  85.                         End If
  86.                         cnt=0
  87.                         ; every door if blocked remove
  88.                         For y1=y-1 To y+1
  89.                         For x1=x-1 To x+1
  90.                         If map(x1,y1) = 2 Then cnt=cnt+1
  91.                         Next
  92.                         Next
  93.                         If cnt>2 Then map(x,y)=2
  94.                 End If
  95.         Next
  96.         Next
  97. End Function
  98.  
  99. ; makeroom
  100. Function mr(x1,y1,x2,y2,x3,y3,x4,y4)
  101.         For y5=y1 To y3
  102.         For x5=x4 To x2
  103.                 map(x5,y5) = 1
  104.         Next
  105.         Next
  106.         For y5=y1 To y3
  107.                 map(x4,y5) = 2
  108.                 map(x2,y5) = 2         
  109.         Next
  110.         For x5=x4 To x2
  111.                 map(x5,y1) = 2
  112.                 map(x5,y3) = 2
  113.         Next
  114.         map(x1,y1) = 3
  115.         map(x2,y2) = 3
  116.         map(x3,y3) = 3
  117.         map(x4,y4) = 3
  118.  
  119. End Function
  120.  
  121. ; Is there anything in the map
  122. Function fits(x,y,w,h)
  123.         ; if outside
  124.         If x<0 Or y<0 Or x+w>mw Or y+h>mh Then Return False    
  125.         ; if inside
  126.         For y1=y To y+h
  127.         For x1=x To x+w
  128.                 If map(x1,y1)>0 Then Return False
  129.         Next
  130.         Next
  131.         Return True
  132. End Function
  133.  
  134. Function drawmap()
  135.         For y=0 To mh
  136.         For x=0 To mh
  137.                 Select map(x,y)
  138.                         Case 0;nothing
  139.                         Color 0,0,0
  140.                         Case 1;floor
  141.                         Color 255,255,255
  142.                         Case 2;wall
  143.                         Color 100,100,100
  144.                         Case 3;door
  145.                         Color 255,0,0
  146.                 End Select
  147.                 Rect x*tw,y*th,tw,th
  148.         Next
  149.         Next
  150. 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:
Code: [Select]
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
Code: [Select]
Global f_path$="r:" , f_name$="room" , f_num=0 , f_ext$=".map"
to wherever you want them to be saved.
Code: [Select]
;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


 

SimplePortal 2.3.6 © 2008-2014, SimplePortal