迷路を自動で生成してみる

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

【VBA】迷路を解く

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

前回のプログラムでは迷路を手動で入力する必要がありました。
大きいサイズの迷路を作成するのは大変なので、自動で迷路を作成する方法を探してみました。

穴掘り法
迷路作成プログラムの作成
1. 実装内容
2. コード
穴掘り法で迷路を生成してみる
エラー
1. 実行時エラー’28’:スタック領域が不足しています

穴掘り法

迷路を作成するアルゴリズムで「穴掘り法」というものがあるので
今回は「穴掘り法」アルゴリズムを使用して、VBAで迷路を作成してみます。

穴掘り法アルゴリズムは下記のページの内容を参考にさせていただきました。

穴掘り法

迷路生成(穴掘り法) - Algoful

穴掘り法は迷路生成アルゴリズムの一種です...

迷路を解くアルゴリズムと組み合わせると、迷路の生成から迷路の解決まで一気にできます。

迷路作成プログラムの作成

実装内容

以下の内容で実装してみます。

mazeという名前のシートに迷路を作成する。
スタート位置とゴール位置の自動生成はしない。

S	スタート位置です。今回は生成しません。
G	ゴール位置です。今回は生成しません。
空白	通ることができます。
#	壁なので通ることができません。

正方形の迷路を生成する。長方形や矩形の迷路は生成しない。
迷路のサイズを入力できるインプットボックスを表示する。
入力する数値は5以上99以下の奇数とする。
- 数値のサイズが大きいとスタック領域不足エラーが発生するため99以下としました。

コード

VBAの穴掘り法のコードは以下になります。

Option Explicit
Sub createMaze()
  
  Dim sizeStr As String
  
  sizeStr = InputBox("5以上99以下の奇数を入力してください")
  If sizeStr = "" Then Exit Sub
  
  If checkInputNumber(sizeStr) = False Then Exit Sub
  
  Dim msgboxVal As Long
  Dim displayFlag As Boolean
  msgboxVal = MsgBox("迷路作成の途中経過を表示しますか？", vbYesNo + vbQuestion, "確認")
  If msgboxVal = vbYes Then
    displayFlag = True
  Else
    displayFlag = False
    Application.ScreenUpdating = False
  End If
  
  Dim size As Long
  size = CLng(sizeStr)
  
  size = size - 1 '配列数を奇数にする
  Dim maze() As String
  ReDim maze(size, size)
  
  Dim mazeSht As Worksheet
  Set mazeSht = ThisWorkbook.Worksheets("maze")
  mazeSht.UsedRange.Clear
  
  Dim i As Long
  Dim j As Long
    
  '外周以外を壁に設定
  For i = 1 To size - 1
    For j = 1 To size - 1
      maze(i, j) = "#"
    Next j
  Next i
  mazeSht.Activate
  If displayFlag Then Call displayMaze(maze, size)
  
  Dim y As Long
  Dim x As Long
  y = getOdd(size)
  x = getOdd(size)
  maze(y, x) = "" '探索スタート地点を通路に変更
  Call digMaze(maze, y, x, size, displayFlag)
  
  '外周を壁に設定する
  For i = 0 To size
    For j = 0 To size
      If i = 0 Or i = size Or j = 0 Or j = size Then
        maze(i, j) = "#"
      End If
    Next j
  Next i
  
  Call displayMaze(maze, size)
  mazeSht.UsedRange.Columns.AutoFit
  
  Application.ScreenUpdating = True
  MsgBox "迷路を作成しました", vbInformation, "迷路作成完了"
  
End Sub
Function checkInputNumber(sizeStr As String) As Boolean
  'インプットボックスに入力された数値のチェック
  
  If IsNumeric(sizeStr) = False Then
    MsgBox "数値を入力してください", vbCritical, "数値以外が入力されました"
    Exit Function
  End If
  Dim size As Long
  size = CLng(sizeStr)
  If size Mod 2 = 0 Then
    MsgBox "奇数を入力してください", vbCritical, "奇数が入力されました"
    Exit Function
  End If
  If size < 5 And 99 < size Then
    MsgBox "5以上99以下の数値を入力してください", vbCritical, "入力値を確認してください"
    Exit Function
  End If

  checkInputNumber = True

End Function
Function getOdd(size As Long) As Long
  
  '1以上size未満の奇数を取得する
  
  Dim v As Long
  Do While v Mod 2 = 0
    Randomize
    v = Int(size * Rnd + 1)
  Loop
  
  getOdd = v
  
End Function
Sub displayMaze(maze() As String, size As Long)
  '迷路をシートに表示
  
  Dim sht As Worksheet
  Set sht = ThisWorkbook.Worksheets("maze")
  
  Dim i As Long
  Dim j As Long
  
  For i = 0 To size
    For j = 0 To size
      sht.Cells(i + 1, j + 1) = maze(i, j)
    Next j
  Next i
  
  Set sht = Nothing
  DoEvents
  
End Sub
Sub digMaze(maze() As String, y As Long, x As Long, _
            size As Long, displayFlag As Boolean)
  '穴掘り法による迷路作成
  Dim directions(3) As String
  directions(0) = "N"
  directions(1) = "E"
  directions(2) = "S"
  directions(3) = "W"
  
  Dim v As Variant
  v = shuffleAry(directions)
  
  Dim i As Long
  Dim c As Collection
  For i = 0 To UBound(directions)
    Dim mY As Long
    Dim mX As Long
    If directions(i) = "N" Then
      mY = y - 2
      mX = x
      '座標を北に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から北の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y - 1, x) = ""
        maze(y - 2, x) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    ElseIf directions(i) = "E" Then
      mY = y
      mX = x + 2
      '座標を東に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から東の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y, x + 1) = ""
        maze(y, x + 2) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    ElseIf directions(i) = "S" Then
      mY = y + 2
      mX = x
      '座標を南に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から南の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y + 1, x) = ""
        maze(y + 2, x) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    Else
      mY = y
      mX = x - 2
      '座標を西に2つ移動してみる。
      '移動先の座標が外周内に収まり、かつ通路でなければ
      '現在の座標から西の座標2つ分を通路にする
      If checkMazeCell(maze, mY, mX, size) Then
        maze(y, x - 1) = ""
        maze(y, x - 2) = ""
        If displayFlag Then Call displayMaze(maze, size)
        '移動先の座標で再帰処理
        Call digMaze(maze, mY, mX, size, displayFlag)
      End If
    End If
  Next i
  
End Sub
Function checkMazeCell(maze() As String, mY As Long, mX As Long, _
                       size As Long) As Boolean
  '移動先の座標が配列のサイズに収まり、さらに通路でないことを確認する
  
  '移動先のyが配列内に収まるか確認
  If mY < 0 Or size < mY Then
    Exit Function
  End If
  
  '移動先のxが配列内に収まるか確認
  If mX < 0 Or size < mX Then
    Exit Function
  End If
  
  '移動先の座標が通路かどうか確認する
  If maze(mY, mX) = "" Then
    Exit Function
  End If
  
  checkMazeCell = True
  
End Function
' 配列をシャッフルする関数
'http://techoh.net/vba-shuffle-array/
Function shuffleAry(list() As String)
    
  Dim i As Long
  Dim rn As Long
  Dim tmp As String
    
  For i = 0 To UBound(list)
    Randomize
    rn = Int(UBound(list) * Rnd)
    tmp = list(i)
    list(i) = list(rn)
    list(rn) = tmp
  Next
    
  shuffleAry = list
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

221

222

223

224

225

226

227

228

229

230

231

232

Option Explicit

Sub createMaze()

Dim sizeStr As String

sizeStr = InputBox("5以上99以下の奇数を入力してください")

If sizeStr = "" Then Exit Sub

If checkInputNumber(sizeStr) = False Then Exit Sub

Dim msgboxVal As Long

Dim displayFlag As Boolean

msgboxVal = MsgBox("迷路作成の途中経過を表示しますか？", vbYesNo + vbQuestion, "確認")

If msgboxVal = vbYes Then

displayFlag = True

Else

displayFlag = False

Application.ScreenUpdating = False

End If

Dim size As Long

size = CLng(sizeStr)

size = size - 1 '配列数を奇数にする

Dim maze() As String

ReDim maze(size, size)

Dim mazeSht As Worksheet

Set mazeSht = ThisWorkbook.Worksheets("maze")

mazeSht.UsedRange.Clear

Dim i As Long

Dim j As Long

'外周以外を壁に設定

For i = 1 To size - 1

For j = 1 To size - 1

maze(i, j) = "#"

Next j

Next i

mazeSht.Activate

If displayFlag Then Call displayMaze(maze, size)

Dim y As Long

Dim x As Long

y = getOdd(size)

x = getOdd(size)

maze(y, x) = "" '探索スタート地点を通路に変更

Call digMaze(maze, y, x, size, displayFlag)

'外周を壁に設定する

For i = 0 To size

For j = 0 To size

If i = 0 Or i = size Or j = 0 Or j = size Then

maze(i, j) = "#"

End If

Next j

Next i

Call displayMaze(maze, size)

mazeSht.UsedRange.Columns.AutoFit

Application.ScreenUpdating = True

MsgBox "迷路を作成しました", vbInformation, "迷路作成完了"

End Sub

Function checkInputNumber(sizeStr As String) As Boolean

'インプットボックスに入力された数値のチェック

If IsNumeric(sizeStr) = False Then

MsgBox "数値を入力してください", vbCritical, "数値以外が入力されました"

Exit Function

End If

Dim size As Long

size = CLng(sizeStr)

If size Mod 2 = 0 Then

MsgBox "奇数を入力してください", vbCritical, "奇数が入力されました"

Exit Function

End If

If size < 5 And 99 < size Then

MsgBox "5以上99以下の数値を入力してください", vbCritical, "入力値を確認してください"

Exit Function

End If

checkInputNumber = True

End Function

Function getOdd(size As Long) As Long

'1以上size未満の奇数を取得する

Dim v As Long

Do While v Mod 2 = 0

Randomize

v = Int(size * Rnd + 1)

Loop

getOdd = v

End Function

Sub displayMaze(maze() As String, size As Long)

'迷路をシートに表示

Dim sht As Worksheet

Set sht = ThisWorkbook.Worksheets("maze")

Dim i As Long

Dim j As Long

For i = 0 To size

For j = 0 To size

sht.Cells(i + 1, j + 1) = maze(i, j)

Next j

Next i

Set sht = Nothing

DoEvents

End Sub

Sub digMaze(maze() As String, y As Long, x As Long, _

size As Long, displayFlag As Boolean)

'穴掘り法による迷路作成

Dim directions(3) As String

directions(0) = "N"

directions(1) = "E"

directions(2) = "S"

directions(3) = "W"

Dim v As Variant

v = shuffleAry(directions)

Dim i As Long

Dim c As Collection

For i = 0 To UBound(directions)

Dim mY As Long

Dim mX As Long

If directions(i) = "N" Then

mY = y - 2

mX = x

'座標を北に2つ移動してみる。

'移動先の座標が外周内に収まり、かつ通路でなければ

'現在の座標から北の座標2つ分を通路にする

If checkMazeCell(maze, mY, mX, size) Then

maze(y - 1, x) = ""

maze(y - 2, x) = ""

If displayFlag Then Call displayMaze(maze, size)

'移動先の座標で再帰処理

Call digMaze(maze, mY, mX, size, displayFlag)

End If

ElseIf directions(i) = "E" Then

mY = y

mX = x + 2

'座標を東に2つ移動してみる。

'移動先の座標が外周内に収まり、かつ通路でなければ

'現在の座標から東の座標2つ分を通路にする

If checkMazeCell(maze, mY, mX, size) Then

maze(y, x + 1) = ""

maze(y, x + 2) = ""

If displayFlag Then Call displayMaze(maze, size)

'移動先の座標で再帰処理

Call digMaze(maze, mY, mX, size, displayFlag)

End If

ElseIf directions(i) = "S" Then

mY = y + 2

mX = x

'座標を南に2つ移動してみる。

'移動先の座標が外周内に収まり、かつ通路でなければ

'現在の座標から南の座標2つ分を通路にする

If checkMazeCell(maze, mY, mX, size) Then

maze(y + 1, x) = ""

maze(y + 2, x) = ""

If displayFlag Then Call displayMaze(maze, size)

'移動先の座標で再帰処理

Call digMaze(maze, mY, mX, size, displayFlag)

End If

Else

mY = y

mX = x - 2

'座標を西に2つ移動してみる。

'移動先の座標が外周内に収まり、かつ通路でなければ

'現在の座標から西の座標2つ分を通路にする

If checkMazeCell(maze, mY, mX, size) Then

maze(y, x - 1) = ""

maze(y, x - 2) = ""

If displayFlag Then Call displayMaze(maze, size)

'移動先の座標で再帰処理

Call digMaze(maze, mY, mX, size, displayFlag)

End If

Next i

End Sub

Function checkMazeCell(maze() As String, mY As Long, mX As Long, _

size As Long) As Boolean

'移動先の座標が配列のサイズに収まり、さらに通路でないことを確認する

'移動先のyが配列内に収まるか確認

If mY < 0 Or size < mY Then

Exit Function

End If

'移動先のxが配列内に収まるか確認

If mX < 0 Or size < mX Then

Exit Function

End If

'移動先の座標が通路かどうか確認する

If maze(mY, mX) = "" Then

Exit Function

End If

checkMazeCell = True

End Function

' 配列をシャッフルする関数

'http://techoh.net/vba-shuffle-array/

Function shuffleAry(list() As String)

Dim i As Long

Dim rn As Long

Dim tmp As String

For i = 0 To UBound(list)

Randomize

rn = Int(UBound(list) * Rnd)

tmp = list(i)

list(i) = list(rn)

list(rn) = tmp

shuffleAry = list

End Function

穴掘り法で壁を壊す方向をランダムに決める必要があったので
東西南北の方角を配列に格納し、配列をシャッフルして破壊方向をランダムに出してます。

配列をシャッフルする関数は以下のサイトを参考にさせていただきました。

VBAで配列をシャッフルする（要素をランダムに並べ替える）

VBAでも配列の要素をランダムに並べ替えたいときがあります。そんなときはランダム関数を使って配列の中をシャッフルする関数を作ってしまいましょう。スポンサーリンク AdSense Responsiv

穴掘り法で迷路を生成してみる

createMazeを実行するとインプットボックスが表示されます。
5～99以外の数値や文字を入力するとエラーになります。

15を入力してOKを押してみます。

「迷路作成の途中経過を表示しますか？」とメッセージボックスが表示されます。

「はい」を押すと迷路の作成経過をmazeシートに表示します。
迷路のサイズが大きいと表示処理に時間がかかるので注意してください！

「いいえ」を押すと、作成経過を表示せず迷路を表示します。

迷路の作成が完了すると完了メッセージが表示されます。

迷路作成後、SとGの文字をシートに書き込みます。
以前作成した迷路を探索するアルゴリズムを使用すると
スタートからゴールまでの経路を表示します。

エラー

実行時エラー’28’:スタック領域が不足しています

迷路作成時に再帰処理を行っているため、スタックの容量を超えてしまうとエラーが発生します。
この場合はインプットボックスに入力する迷路のサイズを小さくしてみてください。

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

迷路を自動で生成してみる

穴掘り法

迷路作成プログラムの作成

実装内容

コード

穴掘り法で迷路を生成してみる

エラー

実行時エラー’28’:スタック領域が不足しています

コメント