【VBA】穴掘り法で迷路を自動生成

迷路を自動で生成してみる
#

以前、Excelのシートに入力した文字を迷路に見立てて幅優先探索で迷路を解くプログラムをVBAで作成しました。

【VBA】迷路を解く

2018/07/26·更新日: 2024/01/30·6 分

Programming VBA アルゴリズム

前回のプログラムでは迷路を手動で入力する必要がありました。
大きいサイズの迷路を作成するのは大変なので、自動で迷路を作成する方法を探してみました。

穴掘り法
#

迷路を作成するアルゴリズムで「穴掘り法」というものがあるので
今回は「穴掘り法」アルゴリズムを使用して、VBAで迷路を作成してみます。

穴掘り法アルゴリズムは下記のページの内容を参考にさせていただきました。

迷路生成(穴掘り法) - Algoful

algoful.com

迷路を解くアルゴリズムと組み合わせると、迷路の生成から迷路の解決まで一気にできます。

迷路作成プログラムの作成
#

実装内容
#

以下の内容で実装してみます。

mazeという名前のシートに迷路を作成する。
スタート位置とゴール位置の自動生成はしない。

記号	内容
S	スタート位置です
G	ゴール位置です
空白	通ることができます
#	壁なので通ることができません

正方形の迷路を生成する。長方形や矩形の迷路は生成しない。
迷路のサイズを入力できるインプットボックスを表示する。入力する数値は5以上99以下の奇数とする。
数値のサイズが大きいとスタック領域不足エラーが発生するため99以下としました。

コード
#

VBAの穴掘り法のコードは以下になります。

Option Explicit
Sub createMaze()
  
  Dim sizeStr As String
  
  sizeStr = InputBox("5以上99以下の奇数を入力してください")
  If sizeStr = "" Then Exit Sub
  
  If checkInputNumber(sizeStr) = False Then Exit Sub
  
  Dim msgboxVal As Long
  Dim displayFlag As Boolean
  msgboxVal = MsgBox("迷路作成の途中経過を表示しますか？", vbYesNo + vbQuestion, "確認")
  If msgboxVal = vbYes Then
    displayFlag = True
  Else
    displayFlag = False
    Application.ScreenUpdating = False
  End If
  
  Dim size As Long
  size = CLng(sizeStr)
  
  size = size - 1 '配列数を奇数にする
  Dim maze() As String
  ReDim maze(size, size)
  
  Dim mazeSht As Worksheet
  Set mazeSht = ThisWorkbook.Worksheets("maze")
  mazeSht.UsedRange.Clear
  
  Dim i As Long
  Dim j As Long
    
  '外周以外を壁に設定
  For i = 1 To size - 1
    For j = 1 To size - 1
      maze(i, j) = "#"
    Next j
  Next i
  mazeSht.Activate
  If displayFlag Then Call displayMaze(maze, size)
  
  Dim y As Long
  Dim x As Long
  y = getOdd(size)
  x = getOdd(size)
  maze(y, x) = "" '探索スタート地点を通路に変更
  Call digMaze(maze, y, x, size, displayFlag)
  
  '外周を壁に設定する
  For i = 0 To size
    For j = 0 To size
      If i = 0 Or i = size Or j = 0 Or j = size Then
        maze(i, j) = "#"
      End If
    Next j
  Next i
  
  Call displayMaze(maze, size)
  mazeSht.UsedRange.Columns.AutoFit
  
  Application.ScreenUpdating = True
  MsgBox "迷路を作成しました", vbInformation, "迷路作成完了"
  
End Sub
Function checkInputNumber(sizeStr As String) As Boolean
  'インプットボックスに入力された数値のチェック
  
  If IsNumeric(sizeStr) = False Then
    MsgBox "数値を入力してください", vbCritical, "数値以外が入力されました"
    Exit Function
  End If
  Dim size As Long
  size = CLng(sizeStr)
  If size Mod 2 = 0 Then
    MsgBox "奇数を入力してください", vbCritical, "奇数が入力されました"
    Exit Function
  End If
  If size < 5 And 99 < size Then
    MsgBox "5以上99以下の数値を入力してください", vbCritical, "入力値を確認してください"
    Exit Function
  End If

  checkInputNumber = True

End Function

Function getOdd(size As Long) As Long
  
  '1以上size未満の奇数を取得する
  
  Dim v As Long
  Do While v Mod 2 = 0
    Randomize
    v = Int(size * Rnd + 1)
  Loop
  
  getOdd = v
  
End Function
Sub displayMaze(maze() As String, size As Long)
  '迷路をシートに表示
  
  Dim sht As Worksheet
  Set sht = ThisWorkbook.Worksheets("maze")
  
  Dim i As Long
  Dim j As Long
  
  For i = 0 To size
    For j = 0 To size
      sht.Cells(i + 1, j + 1) = maze(i, j)
    Next j
  Next i
  
  Set sht = Nothing
  DoEvents
  
End Sub

Sub digMaze(maze() As String, y As Long, x As Long, _
            size As Long, displayFlag As Boolean)
  '穴掘り法による迷路作成
  Dim directions(3) As String
  directions(0) = "N"
  directions(1) = "E"
  directions(2) = "S"
  directions(3) = "W"
  
  Dim v As Variant
  v = shuffleAry(directions)
  
  Dim i As Long
  Dim c As Collection
  For i = 0 To UBound(directions)
    Dim mY As Long
    Dim mX As Long
    If directions(i) = "N" Then
      mY = y - 2
      mX = x
      '座標を北に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から北の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y - 1, x) = ""
        maze(y - 2, x) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    ElseIf directions(i) = "E" Then
      mY = y
      mX = x + 2
      '座標を東に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から東の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y, x + 1) = ""
        maze(y, x + 2) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    ElseIf directions(i) = "S" Then
      mY = y + 2
      mX = x
      '座標を南に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から南の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y + 1, x) = ""
        maze(y + 2, x) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    Else
      mY = y
      mX = x - 2
      '座標を西に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から西の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y, x - 1) = ""
        maze(y, x - 2) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    End If
  Next i
  
End Sub

Function checkMazeCell(maze() As String, mY As Long, mX As Long, _
                       size As Long) As Boolean
  '移動先の座標が配列のサイズに収まり、さらに通路でないことを確認する
  
  '移動先のyが配列内に収まるか確認
  If mY < 0 Or size < mY Then
    Exit Function
  End If
  
  '移動先のxが配列内に収まるか確認
  If mX < 0 Or size < mX Then
    Exit Function
  End If
  
  '移動先の座標が通路かどうか確認する
  If maze(mY, mX) = "" Then
    Exit Function
  End If
  
  checkMazeCell = True
  
End Function

' 配列をシャッフルする関数
'http://techoh.net/vba-shuffle-array/
Function shuffleAry(list() As String)
    
  Dim i As Long
  Dim rn As Long
  Dim tmp As String
    
  For i = 0 To UBound(list)
    Randomize
    rn = Int(UBound(list) * Rnd)
    tmp = list(i)
    list(i) = list(rn)
    list(rn) = tmp
  Next
    
  shuffleAry = list
End Function