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

概要
迷路を自動で生成してみる
以前、Excelのシートに入力した文字を迷路に見立てて幅優先探索で迷路を解くプログラムをVBAで作成しました。
https://kazusa-pg.com/vba-solve-maze/
前回のプログラムでは迷路を手動で入力する必要がありました。
大きいサイズの迷路を作成するのは大変なので、自動で迷路を作成する方法を探してみました。
穴掘り法
迷路を作成するアルゴリズムで「穴掘り法」というものがあるので
今回は「穴掘り法」アルゴリズムを使用して、VBAで迷路を作成してみます。
穴掘り法アルゴリズムは下記のページの内容を参考にさせていただきました。
迷路を解くアルゴリズムと組み合わせると、迷路の生成から迷路の解決まで一気にできます。
迷路作成プログラムの作成
実装内容
以下の内容で実装してみます。
- mazeという名前のシートに迷路を作成する。
- スタート位置とゴール位置の自動生成はしない。

記号 | 内容 |
---|---|
S | スタート位置です |
G | ゴール位置です |
空白 | 通ることができます |
# | 壁なので通ることができません |
- 正方形の迷路を生成する。長方形や矩形の迷路は生成しない。
- 迷路のサイズを入力できるインプットボックスを表示する。入力する数値は5以上99以下の奇数とする。
- 数値のサイズが大きいとスタック領域不足エラーが発生するため99以下としました。
コード
VBAの穴掘り法のコードは以下になります。
1Option Explicit
2Sub createMaze()
3
4 Dim sizeStr As String
5
6 sizeStr = InputBox("5以上99以下の奇数を入力してください")
7 If sizeStr = "" Then Exit Sub
8
9 If checkInputNumber(sizeStr) = False Then Exit Sub
10
11 Dim msgboxVal As Long
12 Dim displayFlag As Boolean
13 msgboxVal = MsgBox("迷路作成の途中経過を表示しますか?", vbYesNo + vbQuestion, "確認")
14 If msgboxVal = vbYes Then
15 displayFlag = True
16 Else
17 displayFlag = False
18 Application.ScreenUpdating = False
19 End If
20
21 Dim size As Long
22 size = CLng(sizeStr)
23
24 size = size - 1 '配列数を奇数にする
25 Dim maze() As String
26 ReDim maze(size, size)
27
28 Dim mazeSht As Worksheet
29 Set mazeSht = ThisWorkbook.Worksheets("maze")
30 mazeSht.UsedRange.Clear
31
32 Dim i As Long
33 Dim j As Long
34
35 '外周以外を壁に設定
36 For i = 1 To size - 1
37 For j = 1 To size - 1
38 maze(i, j) = "#"
39 Next j
40 Next i
41 mazeSht.Activate
42 If displayFlag Then Call displayMaze(maze, size)
43
44 Dim y As Long
45 Dim x As Long
46 y = getOdd(size)
47 x = getOdd(size)
48 maze(y, x) = "" '探索スタート地点を通路に変更
49 Call digMaze(maze, y, x, size, displayFlag)
50
51 '外周を壁に設定する
52 For i = 0 To size
53 For j = 0 To size
54 If i = 0 Or i = size Or j = 0 Or j = size Then
55 maze(i, j) = "#"
56 End If
57 Next j
58 Next i
59
60 Call displayMaze(maze, size)
61 mazeSht.UsedRange.Columns.AutoFit
62
63 Application.ScreenUpdating = True
64 MsgBox "迷路を作成しました", vbInformation, "迷路作成完了"
65
66End Sub
67Function checkInputNumber(sizeStr As String) As Boolean
68 'インプットボックスに入力された数値のチェック
69
70 If IsNumeric(sizeStr) = False Then
71 MsgBox "数値を入力してください", vbCritical, "数値以外が入力されました"
72 Exit Function
73 End If
74 Dim size As Long
75 size = CLng(sizeStr)
76 If size Mod 2 = 0 Then
77 MsgBox "奇数を入力してください", vbCritical, "奇数が入力されました"
78 Exit Function
79 End If
80 If size < 5 And 99 < size Then
81 MsgBox "5以上99以下の数値を入力してください", vbCritical, "入力値を確認してください"
82 Exit Function
83 End If
84
85 checkInputNumber = True
86
87End Function
88
89Function getOdd(size As Long) As Long
90
91 '1以上size未満の奇数を取得する
92
93 Dim v As Long
94 Do While v Mod 2 = 0
95 Randomize
96 v = Int(size * Rnd + 1)
97 Loop
98
99 getOdd = v
100
101End Function
102Sub displayMaze(maze() As String, size As Long)
103 '迷路をシートに表示
104
105 Dim sht As Worksheet
106 Set sht = ThisWorkbook.Worksheets("maze")
107
108 Dim i As Long
109 Dim j As Long
110
111 For i = 0 To size
112 For j = 0 To size
113 sht.Cells(i + 1, j + 1) = maze(i, j)
114 Next j
115 Next i
116
117 Set sht = Nothing
118 DoEvents
119
120End Sub
121
122Sub digMaze(maze() As String, y As Long, x As Long, _
123 size As Long, displayFlag As Boolean)
124 '穴掘り法による迷路作成
125 Dim directions(3) As String
126 directions(0) = "N"
127 directions(1) = "E"
128 directions(2) = "S"
129 directions(3) = "W"
130
131 Dim v As Variant
132 v = shuffleAry(directions)
133
134 Dim i As Long
135 Dim c As Collection
136 For i = 0 To UBound(directions)
137 Dim mY As Long
138 Dim mX As Long
139 If directions(i) = "N" Then
140 mY = y - 2
141 mX = x
142 '座標を北に2つ移動してみる。
143 '移動先の座標が外周内に収まり、かつ通路でなければ
144 '現在の座標から北の座標2つ分を通路にする
145 If checkMazeCell(maze, mY, mX, size) Then
146 maze(y - 1, x) = ""
147 maze(y - 2, x) = ""
148 If displayFlag Then Call displayMaze(maze, size)
149 '移動先の座標で再帰処理
150 Call digMaze(maze, mY, mX, size, displayFlag)
151 End If
152 ElseIf directions(i) = "E" Then
153 mY = y
154 mX = x + 2
155 '座標を東に2つ移動してみる。
156 '移動先の座標が外周内に収まり、かつ通路でなければ
157 '現在の座標から東の座標2つ分を通路にする
158 If checkMazeCell(maze, mY, mX, size) Then
159 maze(y, x + 1) = ""
160 maze(y, x + 2) = ""
161 If displayFlag Then Call displayMaze(maze, size)
162 '移動先の座標で再帰処理
163 Call digMaze(maze, mY, mX, size, displayFlag)
164 End If
165 ElseIf directions(i) = "S" Then
166 mY = y + 2
167 mX = x
168 '座標を南に2つ移動してみる。
169 '移動先の座標が外周内に収まり、かつ通路でなければ
170 '現在の座標から南の座標2つ分を通路にする
171 If checkMazeCell(maze, mY, mX, size) Then
172 maze(y + 1, x) = ""
173 maze(y + 2, x) = ""
174 If displayFlag Then Call displayMaze(maze, size)
175 '移動先の座標で再帰処理
176 Call digMaze(maze, mY, mX, size, displayFlag)
177 End If
178 Else
179 mY = y
180 mX = x - 2
181 '座標を西に2つ移動してみる。
182 '移動先の座標が外周内に収まり、かつ通路でなければ
183 '現在の座標から西の座標2つ分を通路にする
184 If checkMazeCell(maze, mY, mX, size) Then
185 maze(y, x - 1) = ""
186 maze(y, x - 2) = ""
187 If displayFlag Then Call displayMaze(maze, size)
188 '移動先の座標で再帰処理
189 Call digMaze(maze, mY, mX, size, displayFlag)
190 End If
191 End If
192 Next i
193
194End Sub
195
196Function checkMazeCell(maze() As String, mY As Long, mX As Long, _
197 size As Long) As Boolean
198 '移動先の座標が配列のサイズに収まり、さらに通路でないことを確認する
199
200 '移動先のyが配列内に収まるか確認
201 If mY < 0 Or size < mY Then
202 Exit Function
203 End If
204
205 '移動先のxが配列内に収まるか確認
206 If mX < 0 Or size < mX Then
207 Exit Function
208 End If
209
210 '移動先の座標が通路かどうか確認する
211 If maze(mY, mX) = "" Then
212 Exit Function
213 End If
214
215 checkMazeCell = True
216
217End Function
218
219' 配列をシャッフルする関数
220'http://techoh.net/vba-shuffle-array/
221Function shuffleAry(list() As String)
222
223 Dim i As Long
224 Dim rn As Long
225 Dim tmp As String
226
227 For i = 0 To UBound(list)
228 Randomize
229 rn = Int(UBound(list) * Rnd)
230 tmp = list(i)
231 list(i) = list(rn)
232 list(rn) = tmp
233 Next
234
235 shuffleAry = list
236End Function
穴掘り法で壁を壊す方向をランダムに決める必要があったので
東西南北の方角を配列に格納し、配列をシャッフルして破壊方向をランダムに出してます。
配列をシャッフルする関数は以下のサイトを参考にさせていただきました。
穴掘り法で迷路を生成してみる
createMazeを実行するとインプットボックスが表示されます。
5~99以外の数値や文字を入力するとエラーになります。

15を入力してOKを押してみます。

「迷路作成の途中経過を表示しますか?」とメッセージボックスが表示されます。

「はい」を押すと迷路の作成経過をmazeシートに表示します。
迷路のサイズが大きいと表示処理に時間がかかるので注意してください!

「いいえ」を押すと、作成経過を表示せず迷路を表示します。
迷路の作成が完了すると完了メッセージが表示されます。

迷路作成後、SとGの文字をシートに書き込みます。
以前作成した迷路を探索するアルゴリズムを使用するとスタートからゴールまでの経路を表示します。

エラー
実行時エラー"28":スタック領域が不足しています
迷路作成時に再帰処理を行っているため、スタックの容量を超えてしまうとエラーが発生します。
この場合はインプットボックスに入力する迷路のサイズを小さくしてみてください。
