はやりにのっかって(？)[^1]エクセルVBAで迷路を作って解くというのをやってみました。
……といっても、としじ@toshi81350036 さんが作成された迷路を作る方と、りゅうりゅう@blacklist_ryu さんが作成された迷路を解く方 をくっつけてちょっといじっただけで、オリジナリティとかはありません……（をい）。
[^1] なお、はやりは再帰だという説もありますが、本項では再帰は使用しておりません💦
サンプルのマクロ有効ワークシート（エクセルVBAで迷路.xlsm）はこちら（Google Drive）からダウンロードできます。
| Option Explicit | |
| #Const NO_WAIT = False | |
| Public Const MazeHeight = 16 * 2 + 1, MazeWidth = 20 * 2 + 1 | |
| Public Const LeftTopY = 2, LeftTopX = 2 | |
| Public Const StartY = LeftTopY + 1, StartX = LeftTopX | |
| Public Const GoalY = LeftTopY + MazeHeight - 2, GoalX = LeftTopX + MazeWidth - 1 | |
| Public Enum MapDirection | |
| MapRight = 0 | |
| MapDown = 1 | |
| MapLeft = 2 | |
| MapUp = 3 | |
| End Enum | |
| Public RotateRight, RotateLeft | |
| Public RightOffsetY, RightOffsetX, LeftOffsetY, LeftOffsetX | |
| Public ForwardOffsetY, ForwardOffsetX | |
| Public Sub InitDirection() | |
| If Not IsEmpty(RotateRight) Then Exit Sub | |
| RotateRight = VBA.Array(MapDown, MapLeft, MapUp, MapRight): RotateLeft = VBA.Array(MapUp, MapRight, MapDown, MapLeft) | |
| RightOffsetY = VBA.Array(1, 0, -1, 0): RightOffsetX = VBA.Array(0, -1, 0, 1) | |
| LeftOffsetY = VBA.Array(-1, 0, 1, 0): LeftOffsetX = VBA.Array(0, 1, 0, -1) | |
| ForwardOffsetY = VBA.Array(0, 1, 0, -1): ForwardOffsetX = VBA.Array(1, 0, -1, 0) | |
| End Sub | |
| Public Sub ActivateMazeSheet() | |
| ThisWorkbook.Worksheets("迷路").Activate | |
| End Sub | |
| Public Sub ResetMaze() | |
| Application.ScreenUpdating = False | |
| Dim WorkCell As Range | |
| For Each WorkCell In Cells(LeftTopY, LeftTopX).Resize(MazeHeight, MazeWidth).Cells | |
| Select Case WorkCell.Interior.Color | |
| Case vbWhite, vbBlack | |
| Case Else | |
| WorkCell.Interior.Color = xlNone | |
| End Select | |
| Next | |
| Application.ScreenUpdating = True | |
| End Sub | |
| Public Sub Wait() | |
| #If NO_WAIT Then | |
| Exit Sub | |
| #End If | |
| ' Application.Wait [NOW()+"0:00:00.01"] | |
| DoEvents | |
| End Sub |
| Option Explicit | |
| ' https://twitter.com/toshi81350036/status/1539847745321971717 | |
| ' [VBAで迷路を作る｜としじ｜note](https://note.com/toshi81350036/n/n3a395539474e) | |
| ' [5分で分かる棒倒し法（迷路生成アルゴリズム）【ゆっくり実況】 - YouTube](https://www.youtube.com/watch?v=MUlVTcMHLDo) | |
| Sub 迷路作成() | |
| Call InitDirection ' 方向定義 | |
| Call ActivateMazeSheet ' 迷路のシートをアクティブ化 | |
| Call Cells.Clear | |
| ' 外枠を描画 ' | |
| Cells(LeftTopY + 0, LeftTopX + 0).Resize(MazeHeight - 0, MazeWidth - 0).Interior.Color = vbBlack | |
| Cells(LeftTopY + 1, LeftTopX + 1).Resize(MazeHeight - 2, MazeWidth - 2).Interior.Color = xlNone | |
| ' スタートとゴールを描画 ' | |
| With Cells(LeftTopY + 1, LeftTopX + 0) | |
| .Interior.Color = xlNone: .Value = "S" | |
| .Select | |
| End With | |
| With Cells(LeftTopY + MazeHeight - 2, LeftTopX + MazeWidth - 1) | |
| .Interior.Color = xlNone: .Value = "G" | |
| End With | |
| Dim y, x, wy, wx | |
| Dim WallMapDir As MapDirection | |
| Dim LimitMapDir As MapDirection: LimitMapDir = MapUp ' 最上段については上向きに倒しても良い | |
| Call Randomize | |
| For y = LeftTopY + 2 To MazeHeight - LeftTopY + 1 Step 2 | |
| For x = LeftTopX + 2 To MazeWidth - LeftTopX + 1 Step 2 | |
| Cells(y, x).Interior.Color = vbBlack | |
| ' 棒を倒す向きをランダムに決定(ただし、すでに棒があるところには倒さない) | |
| Do | |
| WallMapDir = Int(Rnd * (LimitMapDir + 1)) | |
| wy = y + ForwardOffsetY(WallMapDir): wx = x + ForwardOffsetX(WallMapDir) | |
| Loop While Cells(wy, wx).Interior.Color = vbBlack | |
| ' 棒を倒す | |
| Cells(wy, wx).Interior.Color = vbBlack | |
| Call Wait | |
| Next | |
| LimitMapDir = MapLeft ' 最上段以外は上向きには倒さない | |
| Next | |
| End Sub |
| Option Explicit | |
| ' https://twitter.com/blacklist_ryu/status/1540162601618853888 | |
| ' https://twitter.com/blacklist_ryu/status/1540164153716789248 | |
| ' [Harigami](https://harigami.net/cd?hsh=9c8f2f6e-755c-430f-b02c-b669b9dd17d0) | |
| Sub 迷路脱出(Optional RightHandRule As Boolean = True) | |
| Call InitDirection ' 方向定義 | |
| Dim y, x, yy, xx, fy, fx, cc, MapDir As MapDirection: MapDir = MapRight: y = StartY: x = StartX ' 初期設定 | |
| Call ActivateMazeSheet ' 迷路のシートをアクティブ化 | |
| Call ResetMaze | |
| Do While Not (Cells(y, x).Value Like "G*") ' "G*"(GOAL)が入ったセルに来たら終了 | |
| ' 右/左側に壁の有無確認、壁がなければ右/左を向く | |
| If RightHandRule Then | |
| If Cells(y + RightOffsetY(MapDir), x + RightOffsetX(MapDir)).Interior.Color <> vbBlack Then MapDir = RotateRight(MapDir) | |
| Else | |
| If Cells(y + LeftOffsetY(MapDir), x + LeftOffsetX(MapDir)).Interior.Color <> vbBlack Then MapDir = RotateLeft(MapDir) | |
| End If | |
| yy = y: xx = x '元位置ストック | |
| fy = y + ForwardOffsetY(MapDir): fx = x + ForwardOffsetX(MapDir) ' 仮前進位置設定 | |
| ' 前に壁がなければ前進、壁があれば左/右を向く | |
| Select Case Cells(fy, fx).Interior.Color | |
| Case vbBlack: | |
| If RightHandRule Then | |
| MapDir = RotateLeft(MapDir) | |
| Else | |
| MapDir = RotateRight(MapDir) | |
| End If | |
| Case Else: y = fy: x = fx | |
| End Select | |
| ' 色を塗る（1度目は黄色、2度目はグレー） | |
| With Cells(y, x) | |
| cc = .Interior.Color | |
| If cc = vbWhite Then Cells(yy, xx).Interior.Color = vbYellow ' 分岐補正 | |
| .Interior.Color = IIf(cc = vbWhite, vbYellow, rgbGray) | |
| End With | |
| Call Wait | |
| Loop | |
| Cells(y, x).Select | |
| End Sub |