【VBA】迷路を解く

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