VBAで迷路を解いてみよう！

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

迷路ってどうやって解くの？
幅優先探索を使うと迷路を解ける
キュー(Queue)がない・・・
迷路をVBAで解いてみる
1. 現在できること
コードを動かしてみる
迷路の自動生成

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

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

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

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

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

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

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

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

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

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

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

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

【VBA】キューを実装する

VBAにデータ構造のキューがないのでクラスモジュールを使用してキューを実装してみます。

迷路をVBAで解いてみる

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

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

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

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

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

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

キュークラスをクラスモジュールに貼り付けます。

【VBA】キューを実装する

VBAにデータ構造のキューがないのでクラスモジュールを使用してキューを実装してみます。

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

【VBA】最終行と最終列を取得する

for文などで1行目から最終行、または1列目から最終列まで連続して処理を行いたいときがあります。この記事では最終行と最終列を取得するVBAのサンプルコードをご紹介します。 A列に5行目までデータが入力されています。 1行目にF列...

現在できること

長方形、正方形の迷路を解くことができる
スタートからゴールまでの正解の経路を算出する
ゴールできない場合は「ゴールできません」と表示する

コードを動かしてみる

下記のような9×9の迷路をシートに入力してみます。
「迷路を解く」ボタンを押すとsolveMazeサブプロシージャを実行します。

ボタンを押して迷路を解いてみます。
ゴールできる場合は、「ゴールできます」とメッセージボックスが表示されます。

そして、スタートからゴールまでの経路を緑色で表示します。

ゴールに到達できない迷路を用意します。

ボタンを押してプログラムを動かすとゴールに到達できないので
「ゴールできません」とメッセージボックスに表示されます。

迷路の自動生成

2018/8/9追記

迷路を自動で生成する記事を書きました。

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

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

【VBA】迷路を解く

VBAで迷路を解いてみよう！

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

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

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

迷路をVBAで解いてみる

現在できること

コードを動かしてみる

迷路の自動生成

コメント