Recursive Sub Calls and Stack Overflow

dreid1011

Well-known Member
Joined
Jun 4, 2015
Messages
3,604
Office Version
  1. 365
Platform
  1. Windows
I've been playing around with some maze generating VBA and I run out of space about 3/4 of the way through the maze at 10x20 size. It will finish 10x10 maze just fine.

Then after some searching I came across a test to see what my limits might be for recursive calls:

VBA Code:
Dim count As Integer

Sub Rec()
    count = count + 1
    Cells(1, 1) = count
    Call Rec
End Sub

With this I was able to get about 37k loops before the overflow. I then tested it without the variable and wrote directly to the cell and I had to stop it over 2B loops because I had other work to do.

VBA Code:
Cells(1, 1) = 0
Sub Rec()
    Repeat:
    Cells(1, 1) = Cells(1, 1) + 1
    GoTo Repeat
End Sub

So now I tried to eliminate all the variables in the code from the youtube link above in favor of writing directly to the sheet, but that didn't seem to help much. (code below before eliminating all variables)

VBA Code:
Option Explicit
Dim r As Integer, c As Integer
Sub InitMaze()
With Range("B2:U11")
    .Borders.Weight = xlThick
    .Interior.Color = vbBlack
End With
r = 2: c = 2
Call CaveMaze
End Sub

Sub CaveMaze()
Repeat:
Dim direc As Integer, LoopCount As Integer

If Cells(r, c).Interior.Color = vbBlack Then
    Cells(r, c).Interior.Color = vbBlue
End If

LoopCount = 0

DoEvents

Do
    Randomize
    direc = Int((Rnd * 4) + 1)
    If direc = 1 And Cells(r + 1, c).Interior.Color = vbBlack Then
        Cells(r, c).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
        r = r + 1
        Exit Do
    ElseIf direc = 2 And Cells(r, c + 1).Interior.Color = vbBlack Then
        Cells(r, c).Borders(xlEdgeRight).LineStyle = xlLineStyleNone
        c = c + 1
        Exit Do
    ElseIf direc = 3 And Cells(r - 1, c).Interior.Color = vbBlack Then
        Cells(r, c).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
        r = r - 1
        Exit Do
    ElseIf direc = 4 And Cells(r, c - 1).Interior.Color = vbBlack Then
        Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
        c = c - 1
        Exit Do
    End If

    LoopCount = LoopCount + 1

    If LoopCount > 9 Then
        Call BackTrack
        Exit Sub
    End If

Loop

GoTo Repeat

End Sub

Sub BackTrack()
Cells(r, c).Interior.Color = vbWhite

If Cells(r + 1, c).Interior.Color <> vbWhite And Cells(r, c).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone Then
    r = r + 1
ElseIf Cells(r, c + 1).Interior.Color <> vbWhite And Cells(r, c).Borders(xlEdgeRight).LineStyle = xlLineStyleNone Then
    c = c + 1
ElseIf Cells(r - 1, c).Interior.Color <> vbWhite And Cells(r, c).Borders(xlEdgeTop).LineStyle = xlLineStyleNone Then
    r = r - 1
ElseIf Cells(r, c - 1).Interior.Color <> vbWhite And Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone Then
    c = c - 1
Else
    Exit Sub
End If

Call CaveMaze

End Sub

Anyway, I am curious if there is something I am missing to help make this more efficient before it overflows.
 
In that case the guy is typing in something different from the sample code he linked to. I didn't try to read the code in the video.

I wrote an iterative solution that doesn't have any overflow issues, but I'm not sure where you are supposed to enter the maze. If I can sort that out I'll post it.
 
Upvote 0

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Here is the downloaded code. I added one line to clear out any existing formatting/data
VBA Code:
Option Explicit

Dim r As Integer, c As Integer

Sub InitMaze()

'Apply borders to all cells in the range
With Range("B2:U21")
   .Clear ' added
  .Borders.Weight = xlThick
  .Interior.Color = vbBlack
End With

'B2 as starting cell
r = 2: c = 2

Call CaveMaze
End Sub

Sub CaveMaze()

  Dim LoopCount As Integer, direc As Integer
 
  'Mark current cell as visited
  If Cells(r, c).Interior.Color = vbBlack Then
    Cells(r, c).Interior.Color = vbBlue
  End If
 
  LoopCount = 0
  DoEvents
 
  'Start loop to check available directions to cave through
  Do
    Randomize
    direc = Int((Rnd * 4) + 1) 'random direction to cave through the maze
    If direc = 1 And Cells(r + 1, c).Interior.Color = vbBlack Then
      Cells(r, c).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
      r = r + 1
      Exit Do
    ElseIf direc = 2 And Cells(r, c + 1).Interior.Color = vbBlack Then
      Cells(r, c).Borders(xlEdgeRight).LineStyle = xlLineStyleNone
      c = c + 1
      Exit Do
    ElseIf direc = 3 And Cells(r - 1, c).Interior.Color = vbBlack Then
      Cells(r, c).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
      r = r - 1
      Exit Do
    ElseIf direc = 4 And Cells(r, c - 1).Interior.Color = vbBlack Then
      Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
      c = c - 1
      Exit Do
    End If
   
    'Exit loop and call BackTrack procedure when cannot move in any direction
    '(all neightbour cells have already been visited)
    LoopCount = LoopCount + 1
    If LoopCount > 9 Then
      Call BackTrack
      Exit Sub
    End If
  Loop
 
  Call CaveMaze


End Sub

Sub BackTrack()
 
  Cells(r, c).Interior.Color = vbWhite 'cell was visited and searched all around
 
  'Check in which direction can go back (recursive backtracker algorithm)
  If Cells(r + 1, c).Interior.Color <> vbWhite And _
  Cells(r, c).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone Then
    r = r + 1
  ElseIf Cells(r, c + 1).Interior.Color <> vbWhite And _
  Cells(r, c).Borders(xlEdgeRight).LineStyle = xlLineStyleNone Then
    c = c + 1
  ElseIf Cells(r - 1, c).Interior.Color <> vbWhite And _
  Cells(r, c).Borders(xlEdgeTop).LineStyle = xlLineStyleNone Then
    r = r - 1
  ElseIf Cells(r, c - 1).Interior.Color <> vbWhite And _
  Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone Then
    c = c - 1
  Else
    Exit Sub
  End If

  Call CaveMaze
 
End Sub
 
Upvote 0
In that case the guy is typing in something different from the sample code he linked to. I didn't try to read the code in the video.

I wrote an iterative solution that doesn't have any overflow issues, but I'm not sure where you are supposed to enter the maze. If I can sort that out I'll post it.
Well, in the video we wrote it VBA, but I have a feeling he was writing it like he would in a different language. Either way, I combined all the subs into 1 and just loop/GoTo to iterate through. I would be interested in seeing what you have though. The entrance is B2 with the code I am using now.
 
Upvote 0
Also you should use Randomize once only at the beginning of execution, instead of repeating it.

Also, it assumes that if you try and fail 9 times to find an adjacent unvisited cell, there is not one. But this is not correct. Trying 9 times does not guarantee that you've checked all four cells.
 
Upvote 0
Here is my iterative solution. And instead of looping 9 times, it randomly tries all four surrounding cells.

VBA Code:
Option Explicit

Dim CellStack() As Range
Dim CellStackTop As Long

' based on description at https://en.wikipedia.org/wiki/Maze_generation_algorithm#Iterative_implementation_(with_stack)

Sub InitMaze()

   'Apply borders to all cells in the range
   Dim MazeRange As Range
  
   ActiveSheet.Cells.Clear ' added
  
   Set MazeRange = Range("B2:U21")
   With MazeRange
     .Borders.Weight = xlThick
     .Interior.Color = vbBlack
   End With
  
   Randomize
  
   CaveMaze MazeRange:=MazeRange

End Sub

Sub CaveMaze(MazeRange As Range)

   Dim direc As Integer
   Dim P(1 To 4) As Double ' Randomized array to check four surrounding cells in random order
   Dim i As Integer
   Dim Found As Boolean
   Dim CurrentCell As Range
   Dim NextCell As Range
   Dim r As Integer, c As Integer
  
   ReDim CellStack(1 To 2 * MazeRange.Count)
   CellStackTop = 0
  
   ' start in upper left corner
   With MazeRange
   r = .Row
   c = .Column
   End With
  
   ' Initialize the stack with the first cell
   Push Cells(r, c)
  
   Do Until CellStackTop = 0
  
      DoEvents ' not required for this to run, but allows a break for debugging
     
      ' Pop cell off the top of the stack, make it the current cell
      Set CurrentCell = Pop
     
      'Mark current cell as visited
      If CurrentCell.Interior.Color = vbBlack Then
      CurrentCell.Interior.Color = vbBlue
      Push CurrentCell
      End If
     
      ' Assign random numbers, then try each one based on the random order
      ' to find a surrounding cell that has not been visited
      For i = 1 To 4
         P(i) = Rnd
      Next i
     
      For i = 1 To 4 ' check each of 4 surrounding cells to find one that has not yet been visited
     
         ' Determine direction to look based on order of random numbers in P array
         direc = Application.WorksheetFunction.Match(Application.WorksheetFunction.Large(P, i), P, 0)
        
         ' values for direc:
         '  1 = one row down
         '  2 = one column to the right
         '  3 = one row up
         '  4 = one column to the left
        
         ' If the cell in the chosen direction is black (not visited), then remove the border between current cell
         ' and the cell in the chosen direction,
         ' then move the current cell to the cell in the chosen direction
        
         Set NextCell = Nothing
         Found = False
         Select Case direc
            Case 1:
               Set NextCell = CurrentCell.Offset(1, 0)
               If NextCell.Interior.Color = vbBlack Then
               CurrentCell.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
               Found = True
               Exit For
               End If
            Case 2
               Set NextCell = CurrentCell.Offset(0, 1)
               If NextCell.Interior.Color = vbBlack Then
               CurrentCell.Borders(xlEdgeRight).LineStyle = xlLineStyleNone
               Found = True
               Exit For
               End If
            Case 3
               Set NextCell = CurrentCell.Offset(-1, 0)
               If NextCell.Interior.Color = vbBlack Then
               CurrentCell.Borders(xlEdgeTop).LineStyle = xlLineStyleNone
               Found = True
               Exit For
               End If
            Case 4
               Set NextCell = CurrentCell.Offset(0, -1)
               If NextCell.Interior.Color = vbBlack Then
               CurrentCell.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
               Found = True
               Exit For
               End If
         End Select
     
      Next i
     
      If Found Then
         Push CurrentCell
         Push NextCell
     
      Else 'backtrack
         CurrentCell.Interior.Color = vbWhite 'cell was visited and searched all around
        
         Set NextCell = Nothing
         'Check in which direction we can go back; just look in order, doesn't matter which one
         ' (This conforms to the original code but you might get better results if you
         '  randomize this as well)
         If CurrentCell.Offset(1, 0).Interior.Color <> vbWhite And _
            CurrentCell.Borders(xlEdgeBottom).LineStyle = xlLineStyleNone Then
            Set NextCell = CurrentCell.Offset(1, 0)
         ElseIf CurrentCell.Offset(0, 1).Interior.Color <> vbWhite And _
            CurrentCell.Borders(xlEdgeRight).LineStyle = xlLineStyleNone Then
            Set NextCell = CurrentCell.Offset(0, 1)
         ElseIf CurrentCell.Offset(-1, 0).Interior.Color <> vbWhite And _
            CurrentCell.Borders(xlEdgeTop).LineStyle = xlLineStyleNone Then
            Set NextCell = CurrentCell.Offset(-1, 0)
         ElseIf CurrentCell.Offset(0, -1).Interior.Color <> vbWhite And _
            CurrentCell.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone Then
            Set NextCell = CurrentCell.Offset(0, -1)
         End If
        
         If Not NextCell Is Nothing Then ' go back to this cell as current
            Push NextCell
         End If
     
      End If
  
   Loop
  
End Sub

Private Sub Push(Cell As Range)

   CellStackTop = CellStackTop + 1
  
   Set CellStack(CellStackTop) = Cell

End Sub

Private Function Pop() As Range

   Set Pop = CellStack(CellStackTop)
   CellStackTop = CellStackTop - 1

End Function
 
Upvote 0
PS it will run a lot faster if you disable ScreenUpdating but it's kind of fun to watch.
 
Upvote 0
Add this at the end of InitMaze to create entrance and exit

VBA Code:
   MazeRange(1).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
   MazeRange(MazeRange.Count).Borders(xlEdgeRight).LineStyle = xlLineStyleNone
 
Upvote 0
What is "Highwater" here?
VBA Code:
Private Sub Push(Cell As Range)

   CellStackTop = CellStackTop + 1
  
   Set CellStack(CellStackTop) = Cell
   If CellStackTop > Highwater Then Highwater = CellStackTop

End Sub
 
Upvote 0
It was a debug line, should be removed. I removed it from my post but you were too fast for me.

I was using it to track the stack depth in the original. It builds up then winds down and I wanted to track the maximum depth (highwater mark).
 
Upvote 0

Forum statistics

Threads
1,223,101
Messages
6,170,116
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top