【VBA】풍풍의 시렌의 플로어의 최단 경로를 요구한다

【개요】

2020/03/26에 Nintendo Switch에서 풍향의 시렌 5가 발매되기로 결정했습니다.
이 보고를 받고 기쁨의 너무, 플로어의 최단 경로를 요구하는 프로그램을 썼습니다.

【환경】

Windows8.1
Excel 2013

【주의점】

본 프로그램은 플로어 전체의 파악 및 골(계단 등 다음 플로어로 이동하는 장소)을 모르면 최단 경로를 구할 수 없습니다.
풍래의 시렌 5는 한 적이 없기 때문에, 플로어 전체나 골을 알 수 있는 아이템이 있는지는 불명합니다.
그 때문에 본 프로그램은 사용물이 되지 않을 가능성이 있습니다만, 게임을 즐길 수 있으면 됩니다.

【코드】

Option Explicit

Sub main()
    Dim start As Range
    Dim goal As Range

    ' Sを探す
    Set start = Cells.Find("S")
    ' Gを探す
    Set goal = Cells.Find("G")

    Call breadthFirstSearch(start)
    Call paintShortestPath(goal)
End Sub


' 幅優先探索
Sub breadthFirstSearch(start As Range)
    Dim i As Integer
    Dim j As Integer
    Dim nowRange As Range
    Dim q As mscorlib.Queue
    Set q = CreateObject("System.Collections.Queue")
    Call q.Enqueue(start)

    ' 最短距離計算のためスタート地点の値を一時的に数値に変更する
    start.Value = 0

    Do While q.Count <> 0
        Set nowRange = q.Dequeue
        ' 現在のセルの周り9セルに対して探索を行う
        For i = -1 To 1
            For j = -1 To 1
                If Cells(nowRange.row + i, nowRange.Column + j).Value = "" _
                    And Cells(nowRange.row + i, nowRange.Column + j).Interior.ColorIndex <> xlNone _
                    And canDiagonalMovement(nowRange, i, j) Then
                        Call q.Enqueue(Cells(nowRange.row + i, nowRange.Column + j))
                        Cells(nowRange.row + i, nowRange.Column + j).Value = nowRange.Value + 1
                End If
            Next
        Next
    Loop

    ' 数値に変更されたスタート地点の値を元に戻す
    start.Value = "S"
End Sub

' 斜め移動できるか判定
Function canDiagonalMovement(nowRange As Range, rowIndex As Integer, colIndex As Integer) As Boolean
    If (Cells(nowRange.row, nowRange.Column + colIndex).Interior.ColorIndex <> xlNone _
        And Cells(nowRange.row + rowIndex, nowRange.Column).Interior.ColorIndex <> xlNone) Then
        canDiagonalMovement = True
    Else
        canDiagonalMovement = False
    End If
End Function

' ゴール地点から距離の小さい座標を求め、スタート地点にたどり着くまでの最短経路を
' 黄色塗りつぶしにする
Sub paintShortestPath(goal As Range)
    Dim i As Integer
    Dim j As Integer
    Dim nowRange As Range
    Dim minDistance As Integer: minDistance = 10000
    Dim q As mscorlib.Queue
    Set q = CreateObject("System.Collections.Queue")
    Call q.Enqueue(goal)

    ' ゴール地点の周り9セルから距離の最小値を求める
    For i = -1 To 1
        For j = -1 To 1
            If Cells(goal.row + i, goal.Column + j).Value <> "" _
                And Cells(goal.row + i, goal.Column + j).Value < minDistance Then
                    minDistance = Cells(goal.row + i, goal.Column + j).Value
            End If
        Next
    Next

    ' 最短距離計算のためゴール地点の値を一時的に数値に変更する
    goal.Value = minDistance + 1

    Do While q.Count <> 0
        Set nowRange = q.Dequeue
        ' 現在のセルの周り9セルに対して探索を行う
        For i = -1 To 1
            For j = -1 To 1
                If Cells(nowRange.row + i, nowRange.Column + j).Value <> "" _
                    And canDiagonalMovement(nowRange, i, j) _
                    And Cells(nowRange.row + i, nowRange.Column + j).Value < nowRange.Value _
                    And Cells(nowRange.row + i, nowRange.Column + j).Interior.Color <> rgbYellow Then
                        Call q.Enqueue(Cells(nowRange.row + i, nowRange.Column + j))
                        Cells(nowRange.row + i, nowRange.Column + j).Interior.Color = rgbYellow
                End If
            Next
        Next
    Loop

    ' 数値に変更されたゴール地点の値を元に戻す
    goal.Value = "G"
End Sub

【실행 준비】

①황색 이외의 좋아하는 색으로 원하는 대로 플로어를 만듭니다.
플로어 이외는 채우지 않게 해 주세요.
A열과 1행째는 채우지 않게 해 주세요.
②스타트(S)와 골(G)을 결정합니다.

【실행 결과】

시작부터 각 지점의 최단 거리가 기록됩니다.
시작부터 목표까지의 최단 경로가 노란색으로 채워집니다.

【참고 서적·사이트】

프로그래밍 경연 공략을 위한 알고리즘과 데이터 구조
VBA에서 .NET Framework Queue 사용