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

前回のプログラムでは迷路を手動で入力する必要がありました。
大きいサイズの迷路を作成するのは大変なので、自動で迷路を作成する方法を探してみました。
穴掘り法
迷路を作成するアルゴリズムで「穴掘り法」というものがあるので
今回は「穴掘り法」アルゴリズムを使用して、VBAで迷路を作成してみます。
穴掘り法アルゴリズムは下記のページの内容を参考にさせていただきました。
迷路を解くアルゴリズムと組み合わせると、迷路の生成から迷路の解決まで一気にできます。
迷路作成プログラムの作成
実装内容
以下の内容で実装してみます。
- mazeという名前のシートに迷路を作成する。
スタート位置とゴール位置の自動生成はしない。
S | スタート位置です。今回は生成しません。 |
G | ゴール位置です。今回は生成しません。 |
空白 | 通ることができます。 |
# | 壁なので通ることができません。 |
- 正方形の迷路を生成する。長方形や矩形の迷路は生成しない。
- 迷路のサイズを入力できるインプットボックスを表示する。
入力する数値は5以上99以下の奇数とする。- 数値のサイズが大きいとスタック領域不足エラーが発生するため99以下としました。
コード
VBAの穴掘り法のコードは以下になります。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
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 |
穴掘り法で壁を壊す方向をランダムに決める必要があったので
東西南北の方角を配列に格納し、配列をシャッフルして破壊方向をランダムに出してます。
配列をシャッフルする関数は以下のサイトを参考にさせていただきました。

穴掘り法で迷路を生成してみる
createMazeを実行するとインプットボックスが表示されます。
5~99以外の数値や文字を入力するとエラーになります。
15を入力してOKを押してみます。
「迷路作成の途中経過を表示しますか?」とメッセージボックスが表示されます。
「はい」を押すと迷路の作成経過をmazeシートに表示します。
迷路のサイズが大きいと表示処理に時間がかかるので注意してください!
「いいえ」を押すと、作成経過を表示せず迷路を表示します。
迷路の作成が完了すると完了メッセージが表示されます。
迷路作成後、SとGの文字をシートに書き込みます。
以前作成した迷路を探索するアルゴリズムを使用すると
スタートからゴールまでの経路を表示します。
エラー
実行時エラー’28’:スタック領域が不足しています
迷路作成時に再帰処理を行っているため、スタックの容量を超えてしまうとエラーが発生します。
この場合はインプットボックスに入力する迷路のサイズを小さくしてみてください。
コメント