【VBA】迷路を解く

2018年07月26日 (更新日: 2024年01月30日) · 7 分で読了 · VBA アルゴリズム

概要

今回はPythonで習ったアルゴリズムをVBAに使用して迷路を解いてみたいと思います。

迷路ってどうやって解くの？

数年前の話ですが、転職するときにプログラミングの試験がありました。
そのときに出題された問題の中で「平面上の迷路のスタートからゴールまでの経路を表示してください」
という問題がありました。

アルゴリズムを使用すれば解ける問題だったのですが、当時のわたしはアルゴリズムについて知らなかったので
問題に全く歯が立ちませんでした。

ここ1～2年でPythonでアルゴリズムを勉強する機会に恵まれ
とあるアルゴリズムを使用すると簡単に迷路を解けることが分かりました。

幅優先探索を使うと迷路を解ける

アルゴリズムの中で幅優先探索というものがあります。

幅優先探索（はばゆうせんたんさく、英: breadth first search）はグラフ理論(Graph theory)において木構造(tree structure)やグラフ(graph)の探索に用いられるアルゴリズム。
アルゴリズムは根ノードで始まり隣接した全てのノードを探索する。
それからこれらの最も近いノードのそれぞれに対して同様のことを繰り返して探索対象ノードをみつける。
「横型探索」とも言われる。
出典：Wikipedia 幅優先探索

スタート地点から、隣り合う地点をどんどん検索していき最終的にゴールを見つけるようなイメージです。

幅優先探索を迷路問題に適用すると、簡単に迷路を解くことができたのでそのスゴさにびっくりしました。

キュー(Queue)がない・・・

幅優先探索ではキュー(Queue)というデータ構造を使用します。
Pythonだとdequeがあるのですが、VBAにはキューがありません。

VBAのクラスモジュールの練習のため、以前キューをクラスとして実装しました。
こちらのキュークラスを使用して、迷路を解いてみます。

https://kazusa-pg.com/vba-queue/

迷路をVBAで解いてみる

Mazeという名前のシートを作成しセルに文字入力したものを迷路とみなします。

シート上の各文字の意味は以下になります。

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

幅優先探索で迷路を解くコードは以下になります。

  1Option Explicit
  2
  3Dim maze() As String
  4Dim visited() As Boolean
  5Dim goalFlag As Boolean
  6Dim prevCoordinate() As Collection
  7Sub solveMaze()
  8  
  9  Dim mazeSht As Worksheet
 10  Set mazeSht = ThisWorkbook.Worksheets("Maze")
 11  
 12  Dim lastRow As Long
 13  Dim lastCol As Long
 14  
 15  lastRow = getMaxRow(mazeSht, 1) - 1
 16  lastCol = getMaxCol(mazeSht, 1) - 1
 17  
 18  mazeSht.Range(mazeSht.Cells(1, 1), mazeSht.Cells(lastRow, lastCol)).Interior.ColorIndex = -4142
 19  
 20  ReDim maze(lastRow, lastCol)           '迷路全体を格納する2次元配列
 21  ReDim visited(lastRow, lastCol)        '迷路でそのセルを既に訪れたか確認するための2次元配列
 22  ReDim prevCoordinate(lastRow, lastCol) '迷路でどのセルから到達したかを保存しておくための2次元配列
 23                                         '正解の経路を割り出すために使用する
 24                                         
 25  '迷路のデータをmaze配列に格納し
 26  'visited配列とprevCoordinateを初期化する
 27  Dim i As Long
 28  Dim j As Long
 29  For i = 0 To lastRow
 30    For j = 0 To lastCol
 31      maze(i, j) = mazeSht.Cells(i + 1, j + 1)
 32      visited(i, j) = False
 33      'prevCoordinateにはY座標-1、X座標-1のCollection型を初期値として格納する
 34      Dim prevYx As Collection
 35      Set prevYx = New Collection
 36      prevYx.Add -1, "Y"
 37      prevYx.Add -1, "X"
 38      Set prevCoordinate(i, j) = prevYx
 39    Next j
 40  Next i
 41  
 42  'スタート位置のy座標とx座標を抽出
 43  Dim pos() As Long
 44  Dim startYx As Collection
 45  pos = findChar(maze, "S", lastRow, lastCol)
 46  If pos(0) = -1 And pos(1) = -1 Then
 47    MsgBox "迷路からスタート位置を見つけることができませんでした。" & vbNewLine & _
 48           "迷路に大文字のSが入力されているか確認してください。" & vbNewLine & _
 49           "処理を中止します。", vbCritical, "スタート位置が見つかりませんでした"
 50    GoTo Finally
 51  End If
 52  Set startYx = New Collection
 53  startYx.Add pos(0), "Y"
 54  startYx.Add pos(1), "X"
 55  
 56  'ゴール位置のy座標とx座標を抽出
 57  Erase pos
 58  Dim goalYx As Collection
 59  pos = findChar(maze, "G", lastRow, lastCol)
 60  If pos(0) = -1 And pos(1) = -1 Then
 61    MsgBox "迷路からゴール位置を見つけることができませんでした。" & vbNewLine & _
 62           "迷路に大文字のGが入力されているか確認してください。" & vbNewLine & _
 63           "処理を中止します。", vbCritical, "ゴール位置が見つかりませんでした"
 64    GoTo Finally
 65  End If
 66  Set goalYx = New Collection
 67  goalYx.Add pos(0), "Y"
 68  goalYx.Add pos(1), "X"
 69  
 70  goalFlag = False
 71  
 72  '幅優先探索のためキューを使用する
 73  Dim q As Queue
 74  Set q = New Queue
 75  q.enqueue startYx
 76  Do While q.count > 0 And goalFlag = False
 77    '幅優先探索で探索を開始
 78    Call bfs(q, lastRow, lastCol)
 79  Loop
 80  
 81  If goalFlag Then
 82    Call paintPath(mazeSht, goalYx("Y"), goalYx("X"))
 83    MsgBox "ゴールできます！", vbInformation, "探索完了"
 84  Else
 85    MsgBox "ゴールできません・・・", vbInformation, "探索完了"
 86  End If
 87
 88Finally:
 89
 90  Set mazeSht = Nothing
 91  Set prevYx = Nothing
 92  Set startYx = Nothing
 93  Set goalYx = Nothing
 94  Set q = Nothing
 95  
 96End Sub
 97Function findChar(maze() As String, c As String, lastRow As Long, lastCol As Long) As Long()
 98  'スタート位置とゴール位置を見つける
 99  '配列の0にy座標,配列の1にx座標を格納する
100  '位置が見つからない場合はpos(0)とpos(1)に
101  '-1を格納した配列を戻す
102  
103  Dim i As Long
104  Dim j As Long
105  Dim pos(1) As Long
106      
107  For i = 0 To lastRow
108    For j = 0 To lastCol
109      If maze(i, j) = c Then
110        pos(0) = i
111        pos(1) = j
112        findChar = pos
113        Exit Function
114      End If
115    Next j
116  Next i
117  
118  pos(0) = -1
119  pos(1) = -1
120  findChar = pos
121  
122End Function
123Function bfs(q As Queue, lastRow As Long, lastCol As Long) As Variant
124  '幅優先探索を行う
125  
126  Dim mY(3) As Long
127  Dim mX(3) As Long
128  
129  'mYとmXの配列を組み合わせて、現在のセルの位置から上、下、左、右の
130  'セルを探索する
131  mY(0) = -1
132  mY(1) = 1
133  mY(2) = 0
134  mY(3) = 0
135  
136  mX(0) = 0
137  mX(1) = 0
138  mX(2) = -1
139  mX(3) = 1
140  
141  Dim currentYx As Collection
142  Set currentYx = New Collection
143  Set currentYx = q.dequeue
144  
145  Dim currentY As Long
146  Dim currentX As Long
147  currentY = currentYx("Y")
148  currentX = currentYx("X")
149  
150  visited(currentY, currentX) = True
151  'Debug.Print currentY & " " & currentX
152  
153  Dim i As Long
154  For i = 0 To UBound(mY)
155    Dim ny As Long
156    Dim nx As Long
157    ny = currentY + mY(i)
158    nx = currentX + mX(i)
159    If ny < 0 Or lastRow < ny Or _
160       nx < 0 Or lastCol < nx Then '枠からはみ出る場合は次のセルを探索
161      GoTo NextFor
162    End If
163    If visited(ny, nx) Then '既に訪れている場所は次のセルを探索
164      GoTo NextFor
165    End If
166    If maze(ny, nx) = "#" Then '壁の場合は移動できないので次のセルを探索
167      GoTo NextFor
168    End If
169    'どの座標から到達したか保存しておく。スタートからゴールまでの経路表示に使用。
170    Dim prevYx As Collection
171    Set prevYx = New Collection
172    prevYx.Add currentY, "Y"
173    prevYx.Add currentX, "X"
174    Set prevCoordinate(ny, nx) = prevYx
175    
176    '探索しているセルがゴールなら幅優先探索を終了
177    If maze(ny, nx) = "G" Then
178      goalFlag = True
179      Exit Function
180    End If
181    
182    Dim nextYx As Collection
183    Set nextYx = New Collection
184    nextYx.Add ny, "Y"
185    nextYx.Add nx, "X"
186    Call q.enqueue(nextYx)
187
188NextFor:
189  Next i
190  
191  Set currentYx = Nothing
192  Set prevYx = Nothing
193  Set nextYx = Nothing
194  
195End Function
196Sub paintPath(mazeSht As Worksheet, y As Long, x As Long)
197  '正解の経路のセルを緑色にする
198  
199  Do While prevCoordinate(y, x)("Y") <> -1 And _
200           prevCoordinate(y, x)("X") <> -1
201    mazeSht.Cells(y + 1, x + 1).Interior.ColorIndex = 50
202    Dim tmpY As Long
203    Dim tmpX As Long
204    tmpY = y
205    tmpX = x
206    y = prevCoordinate(tmpY, tmpX)("Y")
207    x = prevCoordinate(tmpY, tmpX)("X")
208  Loop
209  mazeSht.Cells(y + 1, x + 1).Interior.ColorIndex = 50
210  
211End Sub
212Function getMaxRow(sht As Worksheet, targetCol As Long) As Long
213  
214  getMaxRow = sht.Cells(sht.Rows.count, targetCol).End(xlUp).Row
215
216End Function
217Function getMaxCol(sht As Worksheet, targetRow As Long) As Long
218
219  getMaxCol = sht.Cells(targetRow, sht.Columns.count).End(xlToLeft).Column
220
221End Function