Dungeon Algorithm

'' // Dungeon Generation Algorithm V1.0

'' // I created this to see how easy it would be to upgrade Visual Basic 6 code to Visual Basic 2005
'' // Its intended use is for roguelike games, although it could be used for any games that requires dungeons
'' // This was started about 10 minutes after downloading VB2005 for the first time

'' // Examples:
'' // http://iceyboard.no-ip.org/projects/code/vb2005/dungeon_generation_examples.txt

Module Module1

Public Const SIZE_1 = 200
Public Const SIZE_2 = 78

Dim arrDir(0 To 3, 0 To 1) As Integer
Dim intTiles(0 To SIZE_1, 0 To SIZE_2) As Integer
Dim intX1, intY1 As Integer
Dim intX2, intY2 As Integer

Sub Main()
Randomize()
GenerateMaze()
GenerateRooms()
DestroyDeadEnds()
OutputMaze()
Console.ReadKey()
End Sub

Private Sub OutputMaze()
Dim intA, intB As Integer
For intA = 1 To SIZE_1 + 1
For intB = 1 To SIZE_2 + 1
If intA > SIZE_1 Or intB > SIZE_2 Then
Console.Write(" ")
Else
Select Case intTiles(intA, intB)
Case 0
Console.Write(" ")
Case 1
Console.Write("#")
Case 2
Console.Write("#")
End Select
End If
Next
Console.WriteLine()
Next
End Sub

Private Sub GenerateMaze()
Dim intD, intFilled As Integer
Dim blnBlocked As Boolean
Do
intX1 = Int(((SIZE_1 / 2) * Rnd()) + 1) * 2
intY1 = Int(((SIZE_2 / 2) * Rnd()) + 1) * 2
If intFilled = 0 Then
intTiles(intX1, intY1) = 1
End If
If intTiles(intX1, intY1) Then
Do
RandomDirections()
blnBlocked = True
For intD = 0 To 3
intX2 = intX1 + (arrDir(intD, 0) * 2)
intY2 = intY1 + (arrDir(intD, 1) * 2)
If IsFree(intX2, intY2) Then
intTiles(intX2, intY2) = 1
intTiles(intX1 + arrDir(intD, 0), intY1 + arrDir(intD, 1)) = 1
intX1 = intX2
intY1 = intY2
blnBlocked = False
intFilled = intFilled + 1
Exit For
End If
Next
Loop Until blnBlocked
End If
Loop While intFilled < ((SIZE_1 / 2) * (SIZE_2 / 2)) - 1
End Sub

Private Sub GenerateRooms()
Dim intA, intB As Integer
Dim intX1, intY1 As Integer
Dim intX2, intY2 As Integer
Dim intFailed As Integer
Dim blnValid As Boolean
Do
intX1 = (Int((SIZE_1 / 2) * Rnd()) * 2) + 2
intY1 = (Int((SIZE_2 / 2) * Rnd()) * 2) + 2
intX2 = intX1 + 2 + (Int(4 * Rnd()) * 2)
intY2 = intY1 + 2 + (Int(4 * Rnd()) * 2)
If intX2 <= SIZE_1 And intY2 <= SIZE_2 Then
blnValid = True
For intA = intX1 - 2 To intX2 + 2
For intB = intY1 - 2 To intY2 + 2
If intA < SIZE_1 And intB < SIZE_2 Then
If intTiles(intA, intB) = 2 Then
blnValid = False
Exit For
End If
End If
Next
If blnValid = False Then
Exit For
End If
Next
If blnValid Then
For intA = intX1 To intX2
For intB = intY1 To intY2
intTiles(intA, intB) = 2
Next
Next
Else
intFailed = intFailed + 1
End If
End If
Loop While intFailed < 25
End Sub

Private Sub DestroyDeadEnds()
Dim blnHasDeadEnds As Boolean
Dim intX, intY As Integer
Do
blnHasDeadEnds = False
For intX = 2 To SIZE_1
For intY = 2 To SIZE_2
If intTiles(intX, intY) > 0 And Neighbours(intX, intY) = 1 Then
intTiles(intX, intY) = 0
blnHasDeadEnds = True
End If
Next
Next
Loop While blnHasDeadEnds
End Sub

Public Function Neighbours(ByVal intDrawX As Integer, ByVal intDrawY As Integer) As Integer
If intDrawX > 1 Then
If intTiles(intDrawX - 1, intDrawY) <> 0 Then Neighbours = Neighbours + 1
End If
If intDrawY > 1 Then
If intTiles(intDrawX, intDrawY - 1) <> 0 Then Neighbours = Neighbours + 1
End If
If intDrawX < SIZE_1 Then
If intTiles(intDrawX + 1, intDrawY) <> 0 Then Neighbours = Neighbours + 1
End If
If intDrawY < SIZE_2 Then
If intTiles(intDrawX, intDrawY + 1) <> 0 Then Neighbours = Neighbours + 1
End If
End Function

Private Function IsFree(ByVal intNewX As Integer, ByVal intNewY As Integer) As Boolean
If intNewX < 2 Or intNewX > SIZE_1 Or intNewY < 2 Or intNewY > SIZE_2 Then
IsFree = False
Else
IsFree = (intTiles(intNewX, intNewY) = 0)
End If
End Function

Private Sub RandomDirections()
Dim intN As Integer
For intN = 0 To 3
arrDir(intN, 0) = 0
arrDir(intN, 1) = 0
Next
Select Case Int(3 * Rnd())
Case 0
arrDir(0, 0) = -1
arrDir(1, 0) = 1
arrDir(2, 1) = -1
arrDir(3, 1) = 1
Case 1
arrDir(3, 0) = -1
arrDir(2, 0) = 1
arrDir(1, 1) = -1
arrDir(0, 1) = 1
Case 2
arrDir(2, 0) = -1
arrDir(3, 0) = 1
arrDir(0, 1) = -1
arrDir(1, 1) = 1
Case 3
arrDir(1, 0) = -1
arrDir(0, 0) = 1
arrDir(3, 1) = -1
arrDir(2, 1) = 1
End Select
End Sub

End Module