VBAで迷路を解いてみよう!
今回はPythonで習ったアルゴリズムをVBAに使用して迷路を解いてみたいと思います。
迷路ってどうやって解くの?
数年前の話ですが、転職するときにプログラミングの試験がありました。
そのときに出題された問題の中で「平面上の迷路のスタートからゴールまでの経路を
表示してください」という問題がありました。
アルゴリズムを使用すれば解ける問題だったのですが
当時のわたしはアルゴリズムについて知らなかったので
問題に全く歯が立ちませんでした。
ここ1~2年でPythonでアルゴリズムを勉強する機会に恵まれ
とあるアルゴリズムを使用すると簡単に迷路を解けることが分かりました。
幅優先探索を使うと迷路を解ける
アルゴリズムの中で幅優先探索というものがあります。
幅優先探索(はばゆうせんたんさく、英: breadth first search)はグラフ理論(Graph theory)において木構造(tree structure)やグラフ(graph)の探索に用いられるアルゴリズム。アルゴリズムは根ノードで始まり隣接した全てのノードを探索する。それからこれらの最も近いノードのそれぞれに対して同様のことを繰り返して探索対象ノードをみつける。「横型探索」とも言われる。
出典:Wikipedia 幅優先探索
スタート地点から、隣り合う地点をどんどん検索していき
最終的にゴールを見つけるようなイメージです。
幅優先探索を迷路問題に適用すると、簡単に迷路を解くことができたので
そのスゴさにびっくりしました。
キュー(Queue)がない・・・
幅優先探索ではキュー(Queue)というデータ構造を使用します。
Pythonだとdequeがあるのですが、VBAにはキューがありません。
VBAのクラスモジュールの練習のため、以前キューをクラスとして実装しました。
こちらのキュークラスを使用して、迷路を解いてみます。

迷路をVBAで解いてみる
Mazeという名前のシートを作成し
セルに文字入力したものを迷路とみなします。
シート上の各文字の意味は以下になります。
S | スタート位置です |
G | ゴール位置です |
空白 | 通ることができます |
# | 壁なので通ることができません |
幅優先探索で迷路を解くコードは以下になります。
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 |
Option Explicit Dim maze() As String Dim visited() As Boolean Dim goalFlag As Boolean Dim prevCoordinate() As Collection Sub solveMaze() Dim mazeSht As Worksheet Set mazeSht = ThisWorkbook.Worksheets("Maze") Dim lastRow As Long Dim lastCol As Long lastRow = getMaxRow(mazeSht, 1) - 1 lastCol = getMaxCol(mazeSht, 1) - 1 mazeSht.Range(mazeSht.Cells(1, 1), mazeSht.Cells(lastRow, lastCol)).Interior.ColorIndex = -4142 ReDim maze(lastRow, lastCol) '迷路全体を格納する2次元配列 ReDim visited(lastRow, lastCol) '迷路でそのセルを既に訪れたか確認するための2次元配列 ReDim prevCoordinate(lastRow, lastCol) '迷路でどのセルから到達したかを保存しておくための2次元配列 '正解の経路を割り出すために使用する '迷路のデータをmaze配列に格納し 'visited配列とprevCoordinateを初期化する Dim i As Long Dim j As Long For i = 0 To lastRow For j = 0 To lastCol maze(i, j) = mazeSht.Cells(i + 1, j + 1) visited(i, j) = False 'prevCoordinateにはY座標-1、X座標-1のCollection型を初期値として格納する Dim prevYx As Collection Set prevYx = New Collection prevYx.Add -1, "Y" prevYx.Add -1, "X" Set prevCoordinate(i, j) = prevYx Next j Next i 'スタート位置のy座標とx座標を抽出 Dim pos() As Long Dim startYx As Collection pos = findChar(maze, "S", lastRow, lastCol) If pos(0) = -1 And pos(1) = -1 Then MsgBox "迷路からスタート位置を見つけることができませんでした。" & vbNewLine & _ "迷路に大文字のSが入力されているか確認してください。" & vbNewLine & _ "処理を中止します。", vbCritical, "スタート位置が見つかりませんでした" GoTo Finally End If Set startYx = New Collection startYx.Add pos(0), "Y" startYx.Add pos(1), "X" 'ゴール位置のy座標とx座標を抽出 Erase pos Dim goalYx As Collection pos = findChar(maze, "G", lastRow, lastCol) If pos(0) = -1 And pos(1) = -1 Then MsgBox "迷路からゴール位置を見つけることができませんでした。" & vbNewLine & _ "迷路に大文字のGが入力されているか確認してください。" & vbNewLine & _ "処理を中止します。", vbCritical, "ゴール位置が見つかりませんでした" GoTo Finally End If Set goalYx = New Collection goalYx.Add pos(0), "Y" goalYx.Add pos(1), "X" goalFlag = False '幅優先探索のためキューを使用する Dim q As Queue Set q = New Queue q.enqueue startYx Do While q.count > 0 And goalFlag = False '幅優先探索で探索を開始 Call bfs(q, lastRow, lastCol) Loop If goalFlag Then Call paintPath(mazeSht, goalYx("Y"), goalYx("X")) MsgBox "ゴールできます!", vbInformation, "探索完了" Else MsgBox "ゴールできません・・・", vbInformation, "探索完了" End If Finally: Set mazeSht = Nothing Set prevYx = Nothing Set startYx = Nothing Set goalYx = Nothing Set q = Nothing End Sub Function findChar(maze() As String, c As String, lastRow As Long, lastCol As Long) As Long() 'スタート位置とゴール位置を見つける '配列の0にy座標,配列の1にx座標を格納する '位置が見つからない場合はpos(0)とpos(1)に '-1を格納した配列を戻す Dim i As Long Dim j As Long Dim pos(1) As Long For i = 0 To lastRow For j = 0 To lastCol If maze(i, j) = c Then pos(0) = i pos(1) = j findChar = pos Exit Function End If Next j Next i pos(0) = -1 pos(1) = -1 findChar = pos End Function Function bfs(q As Queue, lastRow As Long, lastCol As Long) As Variant '幅優先探索を行う Dim mY(3) As Long Dim mX(3) As Long 'mYとmXの配列を組み合わせて、現在のセルの位置から上、下、左、右の 'セルを探索する mY(0) = -1 mY(1) = 1 mY(2) = 0 mY(3) = 0 mX(0) = 0 mX(1) = 0 mX(2) = -1 mX(3) = 1 Dim currentYx As Collection Set currentYx = New Collection Set currentYx = q.dequeue Dim currentY As Long Dim currentX As Long currentY = currentYx("Y") currentX = currentYx("X") visited(currentY, currentX) = True 'Debug.Print currentY & " " & currentX Dim i As Long For i = 0 To UBound(mY) Dim ny As Long Dim nx As Long ny = currentY + mY(i) nx = currentX + mX(i) If ny < 0 Or lastRow < ny Or _ nx < 0 Or lastCol < nx Then '枠からはみ出る場合は次のセルを探索 GoTo NextFor End If If visited(ny, nx) Then '既に訪れている場所は次のセルを探索 GoTo NextFor End If If maze(ny, nx) = "#" Then '壁の場合は移動できないので次のセルを探索 GoTo NextFor End If 'どの座標から到達したか保存しておく。スタートからゴールまでの経路表示に使用。 Dim prevYx As Collection Set prevYx = New Collection prevYx.Add currentY, "Y" prevYx.Add currentX, "X" Set prevCoordinate(ny, nx) = prevYx '探索しているセルがゴールなら幅優先探索を終了 If maze(ny, nx) = "G" Then goalFlag = True Exit Function End If Dim nextYx As Collection Set nextYx = New Collection nextYx.Add ny, "Y" nextYx.Add nx, "X" Call q.enqueue(nextYx) NextFor: Next i Set currentYx = Nothing Set prevYx = Nothing Set nextYx = Nothing End Function Sub paintPath(mazeSht As Worksheet, y As Long, x As Long) '正解の経路のセルを緑色にする Do While prevCoordinate(y, x)("Y") <> -1 And _ prevCoordinate(y, x)("X") <> -1 mazeSht.Cells(y + 1, x + 1).Interior.ColorIndex = 50 Dim tmpY As Long Dim tmpX As Long tmpY = y tmpX = x y = prevCoordinate(tmpY, tmpX)("Y") x = prevCoordinate(tmpY, tmpX)("X") Loop mazeSht.Cells(y + 1, x + 1).Interior.ColorIndex = 50 End Sub Function getMaxRow(sht As Worksheet, targetCol As Long) As Long getMaxRow = sht.Cells(sht.Rows.count, targetCol).End(xlUp).Row End Function Function getMaxCol(sht As Worksheet, targetRow As Long) As Long getMaxCol = sht.Cells(targetRow, sht.Columns.count).End(xlToLeft).Column End Function |
キュークラスをクラスモジュールに貼り付けます。

最終行と最終列を取得するために
getMaxRowとgetMaxColを使用してます。

現在できること
- 長方形、正方形の迷路を解くことができる
- スタートからゴールまでの正解の経路を算出する
- ゴールできない場合は「ゴールできません」と表示する
コードを動かしてみる
下記のような9×9の迷路をシートに入力してみます。
「迷路を解く」ボタンを押すとsolveMazeサブプロシージャを実行します。
ボタンを押して迷路を解いてみます。
ゴールできる場合は、「ゴールできます」とメッセージボックスが表示されます。
そして、スタートからゴールまでの経路を緑色で表示します。
ゴールに到達できない迷路を用意します。
ボタンを押してプログラムを動かすとゴールに到達できないので
「ゴールできません」とメッセージボックスに表示されます。
迷路の自動生成
2018/8/9追記
迷路を自動で生成する記事を書きました。

コメント