これは前回の以下の記事の続きです。
tdyu.hatenablog.jp
Excelのセルと罫で作られた迷路を自動で解くというプログラムをVBAで作ってみたところ、意外と反響が大きかったので、ここではどういう仕組みでそれを実現したのかを解説してみます。
Excel迷路を自動で解くとはどういうこと？
まず、本記事を最初に見られた方は「Excelで作られた迷路を自動で解く」については、以下のTwitterの動画をご覧ください。
この迷路は一番オーソドックスな迷路であり、正解ルートが1つだけしか存在しないものです。迷路によっては、途中で道と道がつながり合い、複数の正解ルートがあるものもありますが、今回はそのようなものではありません。
迷路の正解ルートを自動で描画するアルゴリズム
上記のマクロをTwitterで投稿したところ、迷路の生成も解答もどんな仕組みなのか、どんなアルゴリズムなのかを気にされる方が多くいらっしゃいました。
ただ、私はアルゴリズムありきで作ったわけでもなく、そもそもアルゴリズムも詳しくありません。なので結局のところアルゴリズムの名前はわかりませんが、ゴールにたどり着くロジックは以下の画面の通りです。
おわかりの通り、仕組みだけなら一切難しいことはしていません。道が分かれていたらまず進んでみて、行き止まりがあったら分岐まで戻って…これを繰り返せばいずれゴールにたどり着きます。少し調べたところ、このアルゴリズムは「深さ優先探索」というものかもしれません。
とはいえ、プログラマーではない私がこれをExcel VBAで作るのには本当に苦労し、正直めちゃくちゃ時間がかかりました。プログラミングやアルゴリズムがわかる方ならその何十分の１の時間で終わったでしょう。
単に迷路を解く（＝ゴールの座標に到達する）ことはおそらく難しくはありませんが、やっかいだったのが今回作ったマクロの要件のもう1つ「正解のルートだけを色付けする」。これが本当に苦労しました。これは次の項で見ていきます。
正解のルートだけを色付けする方法
正解のルートに到達する方法を考える前に、まずはこのマクロでもっともやっかいな「正解のルートだけを色付けする」ロジックを考えてみましょう。
道を通るたびにInteriorプロパティでセルに色を付けて消してを繰り返していては、当然のごとく処理時間が遅くなるので、正解ルートの座標を1マスずつ配列にいれ、最後にまとめて色付けします。問題なのは途中の通路をどうやって配列にいれるかです。
分岐から分岐までの通路を複数の配列で管理する
迷路では、分岐してからの道がゴールに到達するかを探索しますが、もし間違った道に進めば行き止まりに達します。そのため、ある地点からは間違ったとしても、それ以前の正解だと確定しているルートを記憶しておく必要があります。それを実現するために私が考えたのは、例えば分岐Aから分岐Bまで、分岐Bから分岐Cまでなど、分岐間の通路の座標をすべて異なる配列変数に格納するという方法です。まず下記の画像を見てください。
分岐から分岐まで違う数字を記入した図です。上記の画像でいう通路0の3つのマスの座標をrouteArr(0)に入れておき、分岐してからの通路1の4つのマスの座標をRouteArr(1)に入れていくという方法です。
なお座標は、行をy、列をxとし、これをyyxxの文字列の形で上記配列に格納しています。セルオブジェクトの形で配列に入れられれば最後の描画で非常に楽だったのですが、VBAのArrayはオブジェクトをいれることができないための苦肉の策です。
よって上記の画像の迷路を例に取ると、通路履歴の配列には：
- routeArr(0) = (0101,0102,0202) ←0の通路
- routeArr(1) = (0203,0204,0205,0105) ←1の通路
- routeArr(2) = (0106,0206,0306,0406,0407,0408,0308) ←2の通路
という要素が入っていることになります。
こうすることで、例えば仮に最初の分岐から左に進んでrouteArr(1)に0201,0301,0302が入ったとします。もしその先が行き止まりになり、そこに入れた配列の要素をすべて消去し、最初の分岐を右に進んでrouteArr(1)を0203,0204,0205と入れ直したとしても、確定しているrouteArr(0)のルートは消されずに保たれる仕組みです。
なお、現在値を表すy、xについても、プログラム中では配列変数で管理しています。たとえば、上記画像の0の通路は、y(0)、x(0)、1の通路はy(0)、x(0)という具合です。
スタートからゴールまでの手順
それでは、ポイントをかいつまんでゴールにいくまでどのようなことをしているのかを紹介します。
現在地の周りの何方向に壁があるかを探索
まず、あるセル（座標）から、何方向に進めるかを検索します。後述のソースコードでは、getDirectionArrayという関数で求め、進める方向の数字をarr()という配列に格納しています。
ゴールに向かって進んでいく
上記の検索で、もし進める方向があれば、yまたはx座標を１つずらし、移動後の座標をrouteArr()に格納していきます。繰り返しになりますが、配列にいれるのは、最後の描画用に通路の履歴を残すためです。1方向しか進めない場合は、単純にその方向に座標を進め、そして再帰処理を行います。
もし分岐から2方向に進める場合は
この場合、進める方向の番号2つを配列のarr(0)、arr(1)に入れ、Forループでその2つの方向それぞれに再帰処理を行い進めていきます。その際に行っているのは、ループの2回目でその分岐からの座標の履歴の配列（＝routeArr）を初期化することです。
上記Forループで分岐先１本目を進んで道を配列に格納しても、行き止まりに達したらその進んだ通路はもう不要になるからです。VBAでは配列要素を削除するメソッドがないので、とりあえず空の文字列要素100個を入れるということで初期化にしています。（100マスしかないので通路履歴のrouteArr(x)が100を超えることはありえないからです）
For xx = 0 To 100
routeArr(nm)(xx) = ""
Next xx
もし3方向に分岐がある場合は
実を言うと、このマクロはまだここが欠陥です。迷路生成では３方向に分岐するものはできないと勝手に思っていたのですが、どうやらまれにできてしまうようで、その際はこの解答マクロは動きません・・・動くように修正はできると思いますが、そこまでできていません。これは余力があったらやります。
もし行き止まりになったら
現在値の座標の周りが全部壁でどこにも進めない場合の処理はどうでしょうか。この場合2パターン可能性があります。もう一度以下の画像を見てください。
上記画像内の行き止まり1に達した場合、これは分岐3からのForループの１回目が行き止まりになったことを意味します。ですから通路の番号の変数を１つ下げ、分岐3の下の道を試行すればOKです（Forループの2回目）。
しかし、行き止まり2、行き止まり3も行き終わってしまったら今度は分岐3よりもっと前の分岐2まで戻る必要があります。
上記画像の場合、戻る先はたまたま2つ前でしたが、どの分岐点まで戻るかは分岐の深さによって迷路によって異なります。そのためどの分岐まで戻れるかを調べる必要があるのです。
これを調べる方法としては、本当はもっとよいやり方があるかもしれませんが、このマクロでは、新しいものから各分岐のセルの四方を調べ、そこに通過済みのフラグや壁がない方向が見つかったらそこに戻るという無難な処理で対処しています。それを調べる関数がcheckAround関数です。
ちなみに、過去の分岐に戻るのは、分岐2回目も行き止まりだった場合（＝Forループ2回目）なので、Forループ2回目に入ったことを示すフラグ（backFlg）と、行き止まりに達した際に過去の分岐に戻るフラグ(stopFlg)を立てています。
ゴールしたら
この迷路では決め打ちで10マス×10マスの迷路で、ゴールも右下と決めているので、y()座標、x()座標がどちらも10になったら終了です。最後にrouteArr(0)～routeArr(5)に格納した配列要素をループにかけて該当セルを色付けしていきます。routeArrにはyyxxの形式で正解ルートの座標が１マスずつ入っていることを示すために、以下のGIF動画をご覧ください。正解ルートの色付けのほか、routeArr()の中身を書き出しています。
以上です。
以下ソースコードです。前回の記事で紹介した方法で迷路を作成したあと以下のコードを標準モジュールにコピペすればそのまま動くと思います。途中触れたように、3つに分かれる分岐がある迷路は動かない欠陥品です…何卒ご了承ください。
Dim mazeArea As Range
Dim y(100) As Integer, x(100) As Integer
Dim nm As Integer
Dim flgArr(11) As Variant
Dim routeArr(100) As Variant
Dim routeCounter As Integer
Dim stopFlg(100) As Boolean
Dim goalFlg As Boolean
Dim backFlg As Integer
Sub initializing02()
Dim prevDirecNum As Integer
Dim h As Integer, i As Integer, j As Integer, cnt As Integer
Dim yy As String, xx As String
Set mazeArea = Range(Cells(2, 2), Cells(11, 11))
For h = 0 To 100
stopFlg(100) = False
Next h
flgArr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
flgArr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
For i = 1 To 10
flgArr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
Next i
goalFlg = False
nm = 0
routeCounter = 0
For j = 0 To 100
Dim a As Variant
a = Array("")
b = ""
cnt = 0
Do Until cnt = 100
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = b
cnt = cnt + 1
Loop
routeArr(j) = a
Next j
y(nm) = 1
x(nm) = 1
flgArr(y(nm))(x(nm)) = 1
Call writeNumber
If y(nm) < 10 Then
yy = "0" + "" + CStr(y(nm))
Else
yy = CStr(y(nm))
End If
If x(nm) < 10 Then
xx = "0" + "" + CStr(x(nm))
Else
xx = CStr(x(nm))
End If
routeArr(nm)(routeCounter) = yy + "" + xx
routeCounter = routeCounter + 1
prevDirecNum = 1
Call solveMaze(prevDirecNum)
End Sub
Sub solveMaze(prevDirecNum_ As Integer)
Dim ii As Integer
Dim wallNum As Integer
Dim prevDirecNum_2 As Integer
If goalFlg = True Then Exit Sub
If y(nm) = 10 And x(nm) = 10 Then
Call drawRoute
goalFlg = True
Exit Sub
End If
arr = getDirectionArray(prevDirecNum_)
If arr(0) = "" Then
wallNum = 0
ElseIf arr(1) = "" Then
wallNum = 1
Else
wallNum = 2
End If
If wallNum = 0 Then
routeCounter = 0
If backFlg = 0 Then
y(nm) = y(nm - 1)
x(nm) = x(nm - 1)
ElseIf backFlg = 1 Then
If stopFlg(nm) = True Then
newNm = checkAround(nm)
nm = newNm + 1
y(nm) = y(newNm)
x(nm) = x(newNm)
End If
End If
ElseIf wallNum = 1 Then
Select Case arr(0)
Case 1
y(nm) = y(nm) - 1
prevDirecNum_2 = 3
Case 2
x(nm) = x(nm) + 1
prevDirecNum_2 = 4
Case 3
y(nm) = y(nm) + 1
prevDirecNum_2 = 1
Case 4
x(nm) = x(nm) - 1
prevDirecNum_2 = 2
End Select
flgArr(y(nm))(x(nm)) = 1
Call writeNumber
If y(nm) < 10 Then
yy = "0" + "" + CStr(y(nm))
Else
yy = CStr(y(nm))
End If
If x(nm) < 10 Then
xx = "0" + "" + CStr(x(nm))
Else
xx = CStr(x(nm))
End If
routeArr(nm)(routeCounter) = yy + "" + xx
routeCounter = routeCounter + 1
Call solveMaze(prevDirecNum_2)
ElseIf wallNum = 2 Then
nm = nm + 1
routeCounter = 0
y(nm) = y(nm - 1)
x(nm) = x(nm - 1)
For ii = 0 To 1
If goalFlg = True Then Exit For
For xx = 0 To 100
routeArr(nm)(xx) = ""
Next xx
If ii = 1 Then
backFlg = 1
stopFlg(nm) = True
Else
backFlg = 0
End If
Select Case arr(ii)
Case 1
y(nm) = y(nm) - 1
prevDirecNum_2 = 3
Case 2
x(nm) = x(nm) + 1
prevDirecNum_2 = 4
Case 3
y(nm) = y(nm) + 1
prevDirecNum_2 = 1
Case 4
x(nm) = x(nm) - 1
prevDirecNum_2 = 2
End Select
flgArr(y(nm))(x(nm)) = 1
Call writeNumber
If y(nm) < 10 Then
yy = "0" + "" + CStr(y(nm))
Else
yy = CStr(y(nm))
End If
If x(nm) < 10 Then
xx = "0" + "" + CStr(x(nm))
Else
xx = CStr(x(nm))
End If
routeArr(nm)(routeCounter) = yy + "" + xx
routeCounter = routeCounter + 1
Call solveMaze(prevDirecNum_2)
Next ii
End If
End Sub
Function getDirectionArray(n As Integer) As Variant
Dim i As Integer
Dim direction As Variant
i = 0
direction = Array("", "", "", "")
With mazeArea
If .Cells(y(nm), x(nm)).Borders(xlEdgeTop).LineStyle = xlNone Then
If n <> 1 Then
direction(i) = 1
i = i + 1
End If
End If
If .Cells(y(nm), x(nm)).Borders(xlEdgeRight).LineStyle = xlNone Then
If n <> 2 Then
direction(i) = 2
i = i + 1
End If
End If
If .Cells(y(nm), x(nm)).Borders(xlEdgeBottom).LineStyle = xlNone Then
If n <> 3 Then
direction(i) = 3
i = i + 1
End If
End If
If .Cells(y(nm), x(nm)).Borders(xlEdgeLeft).LineStyle = xlNone Then
If n <> 4 Then
direction(i) = 4
i = i + 1
End If
End If
getDirectionArray = direction
End With
End Function
Function checkAround(nm_ As Integer) As Integer
Dim i As Integer
Dim mySum As Integer
For i = nm_ - 1 To 0 Step -1
mySum = 0
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeTop).LineStyle <> xlNone Or _
flgArr(y(i) - 1)(x(i)) = 1 Then
mySum = mySum + 1
End If
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeRight).LineStyle <> xlNone Or _
flgArr(y(i))(x(i) + 1) = 1 Then
mySum = mySum + 1
End If
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeBottom).LineStyle <> xlNone Or _
flgArr(y(i) + 1)(x(i)) = 1 Then
mySum = mySum + 1
End If
If mazeArea.Cells(y(i), x(i)).Borders(xlEdgeLeft).LineStyle <> xlNone Or _
flgArr(y(i))(x(i) - 1) = 1 Then
mySum = mySum + 1
End If
If mySum < 4 Then
checkAround = i
Exit For
End If
Next i
End Function
Sub drawRoute()
Dim i As Integer, j As Integer, yy As Integer, xx As Integer
Dim rowEnd As Integer
For i = 0 To nm
For j = 0 To 100
If routeArr(i)(j) = "" Then Exit For
yy = Val(Left(routeArr(i)(j), 2))
xx = Val(Right(routeArr(i)(j), 2))
mazeArea.Cells(yy, xx).Interior.Color = RGB(255, 255, 0)
Next j
Next i
End Sub
Sub writeNumber()
End Sub
