Robson » Code » VB2005 » 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
 
© 2004-17 robson | cc unless stated