Maze Escape VB competition!

[undifusion]

Well heres the problem.

Anyone fancy having a bash at it?

 

[gardnertoo]

We're not doing somebody's homework here, are we?

 

[undifusion]

Nope, as it says it was a challenge in summer and i wasnt around to enter then. Just wanted to see if anyone wanted to have a go :P

 

[undifusion]

Anyone?

 

[crimson_b1ade]

but where are the mazes? It says in the original post three mazes will be produced by Mr. Walker. I would assume we would be using those mazes.

 

[undifusion]

It's meant to be as in, no matter what maze is produced the coding finds it to the free spot. Hence making it a challenge, if you see what i mean?

 

[mikerickson]

Here's my effort.

On a spreadsheet, this will find the shortest path from the starting cell to the nearest Goal Cell that avoids passing through any Wall cells. (No diagonal moves.)

A Goal Cell is any cell with .Interior.ColorIndex = 34
A Wall cell is any cell with .Interior.ColorIndex = 44

The starting cell is the first cell on the worksheet that contains only "S". If there is no such cell, the user is prompted to select a starting cell. (ActiveCell is default.) I find the non-S format more fun.

The routine will show the path followed and will time itself and record that info.

Edit: Operating instructions. Construct a maze. Then run the sub Demo. You will be guided.

NOTE: When drawing the maze, it is important that interior color index's 34 and 44 be used.
The OP claims that these are Orange and Pale Blue.
My machine says ColorIndex 34= Pale Turquoise and colorIndex 44 = Gold.

Option Explicit
Option Base 0

Public playingField As Range
Public vPlayField() As Variant
Public DummyCell As Range

Public Const GoalColorIndex As Long = 34
Public Const WallColorIndex As Long = 44

Sub Demo()
    SolveMaze ActiveSheet
End Sub

Function SolveMaze(onSheet As Worksheet, Optional EraseFootprints As Boolean, Optional EraseHistory As Boolean) As String
    Dim StartCell As Range, startCellChr As Variant
    Dim GoalCell As Range
    Dim furthestCells As Range, nextStep As Range
    Dim stepCount As Long
    Dim ReversePath() As Range
    Dim i As Long
    Dim oneCell As Range, tempRange As Object
    Dim Begin As Single
    
    Rem get starting cell
        Set StartCell = GetStartCell(onSheet)
        If StartCell Is Nothing Then
            SolveMaze = "No starting cell": Rem error msg
            GoTo BypassAll
        End If
        
        Rem control erasure
        If Not (EraseFootprints Or EraseHistory) Then
            Select Case MsgBox(prompt:="Ignore " & vbTab & "- erase nothing" & vbCr _
                                                & "  Retry " & vbTab & "- erase only Footprints" & vbCr _
                                                & " Abort " & vbTab & "- erase History and Footprints", _
                                            Buttons:=vbAbortRetryIgnore + vbDefaultButton3)
                Case Is = vbAbort
                    EraseFootprints = True
                    EraseHistory = True
                Case Is = vbIgnore
                    EraseFootprints = False
                    EraseHistory = False
                Case Is = vbRetry
                    EraseFootprints = True
                    EraseHistory = False
                End Select
        End If
        
        Begin = Timer
        
        startCellChr = IIf(UCase(CStr(StartCell.Value)) = "S", Chr(34) & "S" & Chr(34), 0)
        If StartCell.Interior.ColorIndex = GoalColorIndex Then
            SolveMaze = "Notice that " & StartCell.Address(False, False) & " is a goal cell.": Rem error msg
            GoTo WriteResultInComment
        End If
        
    Rem initialize map of maze
        Set playingField = playingFieldRange(StartCell)
        
        With playingField
            Rem find a dummyCell outside of playingfield
            Set DummyCell = .Cells(.Rows.Count + 1, 1)
            Rem initialize step count array
            ReDim vPlayField(1 To .Rows.Count, 1 To .Columns.Count)
        End With
       
    Rem initialize stepping loop
        Set furthestCells = StartCell
        stepCount = 0
        LetVCellValue StartCell, stepCount
        
        Do
            Rem get cells after next step
            stepCount = stepCount + 1
            Set nextStep = DummyCell
            For Each oneCell In furthestCells
                Set tempRange = NeighborsOf(oneCell, GoalCell)
                If Not tempRange Is Nothing Then
                    Set nextStep = Application.Union(nextStep, tempRange)
                End If
            Next oneCell
            Set nextStep = Application.Intersect(nextStep, playingField)
            
            If nextStep Is Nothing Then
                Rem all paths double back on themselves
                Rem error message
                SolveMaze = "No path from " & StartCell.Address(False, False) & vbCr
                startCellChr = Chr(34) & "X" & Chr(34)
                ReDim ReversePath(0 To 0): Set ReversePath(0) = StartCell
                GoTo AddTimeToResult
            Else
                For Each oneCell In nextStep
                    LetVCellValue oneCell, stepCount
                Next oneCell
            End If
            Set furthestCells = nextStep
            
        Loop While GoalCell Is Nothing
        
        Rem a path has been found
    
        Rem pick one of the found paths
        ReDim ReversePath(1 To stepCount)
        Set ReversePath(stepCount) = GoalCell
        For i = stepCount - 1 To 1 Step -1
            Set ReversePath(i) = NextBackwardStep(ReversePath(i + 1))
        Next i
        
    Rem display the results
        SolveMaze = "Path from " & StartCell.Address(False, False) & " to " & GoalCell.Address(False, False) & vbCr
        SolveMaze = SolveMaze & "takes " & stepCount & " steps" & vbCr & "and "
        
AddTimeToResult:
        SolveMaze = SolveMaze & Format((Timer - Begin), "#.00") & " seconds."
        Rem clear playingfield
        With playingField
            If EraseFootprints Then .Parent.Cells.ClearContents
            If EraseHistory Then
                With .Parent.Cells
                    .Validation.Delete
                    .ClearComments
                End With
            End If
            On Error Resume Next
                .SpecialCells(xlCellTypeConstants).Font.ColorIndex = 50
                .SpecialCells(xlCellTypeConstants).Value = Chr(165)
                .SpecialCells(xlCellTypeFormulas, xlNumbers).Formula = "=" & Chr(34) & Chr(165) & Chr(34)
            On Error GoTo 0
        End With
        
        Rem display solution path
        For i = LBound(ReversePath) To UBound(ReversePath)
            'Call Delay
            With ReversePath(i)
                .Value = i
                .Font.ColorIndex = xlGuess
                '.Interior.ColorIndex = 3
            End With
        Next i
        
        With StartCell
            .Formula = "=" & startCellChr
            With .Font
                .Bold = True
                .ColorIndex = 3
            End With
        End With
        
        Rem printStatistics
        
WriteResultInComment:
        With StartCell
            On Error Resume Next
                .AddComment
                .Validation.Add xlValidateInputOnly
            On Error GoTo 0
            .Validation.InputMessage = SolveMaze
            With .Comment
                .Shape.TextFrame.Characters.Font.Size = 12
                .Text Text:=SolveMaze
                .Visible = False
            End With
            Application.Goto .Cells(1, 1)
            .Validation.Delete
        End With
BypassAll:
        
End Function

Function NeighborsOf(ByVal myCell As Range, Optional ByRef GoalCell As Range) As Range
    Dim oneNeighbor As Range
    If myCell Is Nothing Then
        Set NeighborsOf = Nothing
    Else
        Set NeighborsOf = DummyCell
        With myCell.Cells(1, 1)
            On Error Resume Next
            If IsGoodNeighbor(.Offset(-1, 0), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(-1, 0))
            If IsGoodNeighbor(.Offset(0, 1), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(0, 1))
            If IsGoodNeighbor(.Offset(0, -1), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(0, -1))
            If IsGoodNeighbor(.Offset(1, 0), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(1, 0))
            On Error GoTo 0
        End With
        Set NeighborsOf = Application.Intersect(NeighborsOf, playingField)
    End If
End Function

Function IsGoodNeighbor(testCell As Range, Optional ByRef GoalCell As Range) As Boolean
    Rem test cell is not already in path AND not a wall
    IsGoodNeighbor = IsEmpty(GetVCellValue(testCell)) And (testCell.Interior.ColorIndex <> WallColorIndex)
    
    Rem test cell is a goal cell
    If IsGoodNeighbor And testCell.Interior.ColorIndex = GoalColorIndex Then Set GoalCell = testCell
End Function

Function NextBackwardStep(inputCell As Range) As Range
    Dim oneCell As Range
    With inputCell
        On Error Resume Next
        If (GetVCellValue(.Offset(1, 0)) = (GetVCellValue(inputCell) - 1)) And (.Offset(1, 0).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(1, 0)
        If (GetVCellValue(.Offset(0, 1)) = (GetVCellValue(inputCell) - 1)) And (.Offset(0, 1).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(0, 1)
        If (GetVCellValue(.Offset(-1, 0)) = (GetVCellValue(inputCell) - 1)) And (.Offset(-1, 0).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(-1, 0)
        If (GetVCellValue(.Offset(0, -1)) = (GetVCellValue(inputCell) - 1)) And (.Offset(0, -1).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(0, -1)
        On Error GoTo 0
    End With
End Function

Function GetStartCell(MazeSheet As Worksheet) As Range
    Rem look for "S"
    With MazeSheet
        On Error Resume Next
        Set GetStartCell = .Cells.Find(What:="S", After:=.Range("A1"), LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
        On Error GoTo 0
    End With
    Rem if not there, ask user
    If GetStartCell Is Nothing Then
        MazeSheet.Activate
        On Error Resume Next
            Set GetStartCell = Application.InputBox("Click on the Starting cell.", Default:=ActiveCell.Address, Type:=8).Cells(1, 1)
        On Error GoTo 0
    End If
    Rem validate: single cell ; cell is not a wall
    If Not GetStartCell Is Nothing Then
        Set GetStartCell = GetStartCell.Cells(1, 1)
        If (GetStartCell.Interior.ColorIndex = WallColorIndex) Then Set GetStartCell = Nothing
    End If
End Function

Function playingFieldRange(startingCell As Range) As Range
    With startingCell.Parent
        Set playingFieldRange = .Cells(1, 1).Resize(.Rows.Count / 2 - 1, .Columns.Count)
        Exit Function
        Rem this code is faster but not as stable
        Set playingFieldRange = startingCell.Cells(1, 1).Offset(1, 1)
        Set playingFieldRange = Range(playingFieldRange, .UsedRange.Offset(1, 1))
        Set playingFieldRange = Range(playingFieldRange, .Range("A1"))
    End With
End Function

Function GetVCellValue(aCell As Range) As Variant
    If aCell Is Nothing Then
        GetVCellValue = CVErr(xlErrRef)
    Else
        With aCell
            GetVCellValue = vPlayField(.Row, .Column)
        End With
    End If
End Function

Sub LetVCellValue(aCell As Range, Value As Variant)
    With aCell
        vPlayField(.Row, .Column) = Value
    End With
End Sub

Mac's Timer doesn't split time by 1/10's of a second, so the Delay routine is not there.

NOTE: When drawing the maze, it is important that interior color index's 34 and 44 be used.
The OP claims that these are Orange and Pale Blue.
My machine says ColorIndex 34= Pale Turquoise and colorIndex 44 = Gold.

Since my routine leaves tracks of previous paths and records of the previous efforts (from different starting points in the maze), here are the subs EraseFootprints and EraseHistory.
I also think that Pale Turquoise is a poor choice of color for a goal cell. The routine colorCorrection will alter the workbook so that
ColorIndex 34 = paleBlue and ColorIndex 44 = Orange. This involves customizing Excel's color pallet, the customization only one workbook and does not effect (infect) others.

Sub ClearHistory()
    With ActiveSheet.Cells
        .ClearComments
        .ClearContents
        .Validation.Delete
    End With
End Sub

Sub ClearFootprints()
    ActiveSheet.Cells.ClearContents
    MsgBox "cleared"
End Sub

Sub colorCorrection()
    Dim orangeColor As Long, pBlueColor As Long
    Rem 41-LtBlue, 33-skyBlue, 37-paleBlue
    Rem 46-orange
    With ThisWorkbook
        .ResetColors
        orangeColor = .Colors(WallColorIndex)
        .Colors(WallColorIndex) = .Colors(46)
        .Colors(46) = orangeColor
        
        pBlueColor = .Colors(GoalColorIndex)
        .Colors(GoalColorIndex) = .Colors(37)
        .Colors(37) = pBlueColor
    End With
End Sub

 

[undifusion]

thanks alot Mike! I dont know if im doing something wrong but im getting a compile error off, ' Public Const GoalColorIndex As Long = 34
Public Const WallColorIndex As Long = 44'. Any idea why? =O

 

[xenou]

Make sure you don't have the code in another module too...only one public constant with each of these names is allowed in the project. If nothing else, start with a brand new project and a new module and it should compile. Not sure how this actually looks in your code but it should be on separate lines exactly as in Mike's post.

 

[mikerickson]

I think you can download it from this

http://www.geocities.com/wefnut/out/MazeDemo.xls