Attribute VB_Name = "Controler" '******************************************************************************************** '* * '* Controler.bas * '* * '******************************************************************************************** '* Written By: StevenHickerson * '* Date: October 10th, 2004 * '* Purpose: Navigate a maze and find the exit while gaining as few points as possible * '* written for contest on VBForums.com * '******************************************************************************************** '* Comments: * '* Would just like to say I really enjoyed this project and learned a few things from * '* it. Definately a great idea and thanks to those hosting it! * '******************************************************************************************** Option Explicit Enum BlockType 'Used in MemCell, sets what kind of block the location is Wall = 1 OpenArea = 2 UnKnown = 9 UnSet = 0 End Enum Enum Direction 'Just makes some of the Select Cases and such easier to read NoDir = 0 North = 1 East = 2 South = 3 West = 4 End Enum Enum PathStat 'Use in the PathType, sets the pathfinding location type InActive = 0 Active = 1 Dead = 2 Tested = 3 End Enum Private Type Location 'Simple Loc type to prevent needing two variables all the time X As Integer Y As Integer End Type Private Type MemCell 'The primary Type for Memory Value As String 'Movements that have occured in the block Type As BlockType 'Explained above Explored As Boolean 'Wethere the location has been explored or not End Type Private Type MemType 'Not really necessary I just liked this approach better than a two dimensional array for the Memory Cell(-300 To 300) As MemCell End Type Private Type PathType 'Primary PathFinding Type Status As PathStat 'Explained Above Path As String 'The path to get to the location from the start point End Type Dim CurrLoc As Location Dim Finished As Boolean Dim MemoryMatrix() As MemType Dim ChosenDir As Direction Dim PathFinding As Boolean Dim PathFResult As String Dim MinL As Byte, MaxL As Byte, StepL As Integer Public Sub StartGame() Dim LookA As String Dim XLoc As Integer, YLoc As Integer Dim SMem As MemCell 'Initialize Variables CurrLoc.X = 0 CurrLoc.Y = 0 MaxL = 0 MinL = 0 Finished = False PathFinding = False PathFResult = "" 'Be sure the Memory Matrix is clear ReDim MemoryMatrix(-300 To 300) 'I like to get different results so I randomize base on the timer Randomize Timer ChosenDir = NoDir Do 'Primary Loop, exits when Finished is True LookAround OppositeDir(ChosenDir) ChosenDir = ChooseDirection MovePlayer ChosenDir DoEvents Loop While Not Finished End Sub 'Function used to determine when to use Look() and LookAbout and use them. It then records in memory what it sees. 'Does not look at a place where memory already exists to save points. Private Function LookAround(ComingFrom As Direction) As String Dim NorthO As Boolean, EastO As Boolean, SouthO As Boolean, WestO As Boolean Dim WMem As MemCell Dim LLoop As Direction Dim LLoc As Location Dim DirOpen As Boolean LookAround = "" If ComingFrom = NoDir Then 'Should only be possible in the very first square so you want to get info about everything around you so uses LookAbout() frmMain.LookAbout NorthO, EastO, SouthO, WestO Memory CurrLoc.X, CurrLoc.Y - 1, WMem If Not NorthO Then WMem.Type = Wall Else LookAround = LookAround & "1" WMem.Type = OpenArea End If Memory CurrLoc.X, CurrLoc.Y - 1, WMem, True Memory CurrLoc.X + 1, CurrLoc.Y, WMem If Not EastO Then WMem.Type = Wall Else LookAround = LookAround & "2" WMem.Type = OpenArea End If Memory CurrLoc.X + 1, CurrLoc.Y, WMem, True Memory CurrLoc.X, CurrLoc.Y + 1, WMem If Not SouthO Then WMem.Type = Wall Else LookAround = LookAround & "3" WMem.Type = OpenArea End If Memory CurrLoc.X, CurrLoc.Y + 1, WMem, True Memory CurrLoc.X - 1, CurrLoc.Y, WMem If Not WestO Then WMem.Type = Wall Else LookAround = LookAround & "4" WMem.Type = OpenArea End If Memory CurrLoc.X - 1, CurrLoc.Y, WMem, True Else For LLoop = 1 To 4 'Checks the memory in all four possible directions and uses Look() if memory dosn't exist in one. LLoc.X = CurrLoc.X LLoc.Y = CurrLoc.Y Select Case LLoop Case North LLoc.Y = LLoc.Y - 1 Case East LLoc.X = LLoc.X + 1 Case South LLoc.Y = LLoc.Y + 1 Case West LLoc.X = LLoc.X - 1 End Select Memory LLoc.X, LLoc.Y, WMem If WMem.Type = UnSet Or WMem.Type = UnKnown Then DirOpen = frmMain.Look(LLoop) If DirOpen Then WMem.Type = OpenArea LookAround = LookAround & LLoop Else WMem.Type = Wall End If Memory LLoc.X, LLoc.Y, WMem, True Else LookAround = LookAround & LLoop End If Next End If End Function 'This function serves as the decision making algo. It will return a direction for the player to move. 'It ensure via memory that this direction is not a wall, or unknown area (dont want to try to move to an unknown area it may be a wall) Private Function ChooseDirection() As Direction Dim DirChosen As Boolean Dim RMem As MemCell Dim CLoc As Location Dim CLoop As Direction Dim rndNum As Byte If PathFinding Then 'If in pathfinding mode the follow the directions from the path finding results If Len(PathFResult) > 0 Then ChooseDirection = CByte(Left(PathFResult, 1)) PathFResult = Right(PathFResult, Len(PathFResult) - 1) Exit Function Else PathFinding = False End If End If DirChosen = False Memory CurrLoc.X, CurrLoc.Y, RMem If RMem.Value <> "" Or MaxL = 0 Then 'If on a square that the player has been in before it redoes the random (better chance of not ending up back here again) rndNum = CByte(50 * Rnd + 1) If rndNum <= 25 Then MinL = 1 MaxL = 4 StepL = 1 Else MinL = 4 MaxL = 1 StepL = -1 End If End If For CLoop = MinL To MaxL Step StepL 'Primary choice loop, runs from North to West or West to North depending on the random. CLoc.X = CurrLoc.X 'So essentially it moves Up then Right or Down then Left in general CLoc.Y = CurrLoc.Y Select Case CLoop Case North CLoc.Y = CLoc.Y - 1 Case East CLoc.X = CLoc.X + 1 Case South CLoc.Y = CLoc.Y + 1 Case West CLoc.X = CLoc.X - 1 End Select Memory CLoc.X, CLoc.Y, RMem If RMem.Explored = False Then 'Make sure the chosen direction hasn't been explored yet, dont want to keep running over the same stuff If RMem.Type <> Wall Then 'Make sure the chosen direction isn't a wall ChooseDirection = CLoop DirChosen = True Exit For End If End If Next If Not DirChosen Then 'If the direction wasn't chosen above it means we are at a dead end or surrounded by explored squares so we use pathfinding to find the nearest unexplored square PathFResult = PathFind(CurrLoc) If PathFResult <> "" Then PathFinding = True ChooseDirection = CByte(Left(PathFResult, 1)) PathFResult = Right(PathFResult, Len(PathFResult) - 1) DirChosen = True Else MsgBox "My Algo seems to have failed.. sorry :(", vbOKOnly, "Bah!" 'If pathfinding fails to find an unexplored square (should only happen if the finish is unreachable, it reports it and stops all Controler Loops Finished = True End If End If End Function 'Basic Memory Wrapper, Nothing to fancy just sets the array or fetches the value of the array. Private Function Memory(X As Integer, Y As Integer, MemC As MemCell, Optional Setting As Boolean = False) As String If Not Setting Then MemC = MemoryMatrix(X).Cell(Y) Else MemoryMatrix(X).Cell(Y) = MemC End If End Function 'After the direction has been chosen we have to actually move the player. 'Records movements and makes one last assurance that you arn't trying to move into a wall or unknown area. Private Sub MovePlayer(MoveDir As Direction) Dim OldLoc As Location Dim WMem As MemCell If MoveDir = NoDir Then Exit Sub 'If direction is not given exit OldLoc.X = CurrLoc.X OldLoc.Y = CurrLoc.Y Select Case MoveDir Case North OldLoc.Y = OldLoc.Y - 1 Case East OldLoc.X = OldLoc.X + 1 Case South OldLoc.Y = OldLoc.Y + 1 Case West OldLoc.X = OldLoc.X - 1 End Select Memory OldLoc.X, OldLoc.Y, WMem If WMem.Type = Wall Or WMem.Type = UnSet Then Exit Sub 'Make sure your move choice isn't into a wall or unknown location. OldLoc.X = CurrLoc.X OldLoc.Y = CurrLoc.Y Select Case MoveDir 'Update the CurrLoc location for player tracking. Case North CurrLoc.Y = CurrLoc.Y - 1 Case East CurrLoc.X = CurrLoc.X + 1 Case South CurrLoc.Y = CurrLoc.Y + 1 Case West CurrLoc.X = CurrLoc.X - 1 End Select Finished = frmMain.MovePlayer(CByte(MoveDir)) 'Call the move and check if we are at the End point Memory OldLoc.X, OldLoc.Y, WMem 'Save move data to the sqaure we just moved out of If WMem.Type = UnKnown Or WMem.Type = UnSet Then WMem.Type = OpenArea WMem.Explored = True If WMem.Value <> "" Then WMem.Value = WMem.Value & CStr(MoveDir) Else WMem.Value = CStr(MoveDir) End If Memory OldLoc.X, OldLoc.Y, WMem, True Memory CurrLoc.X, CurrLoc.Y, WMem If WMem.Type = UnSet Or WMem.Type = UnKnown Then WMem.Type = OpenArea WMem.Explored = True Memory CurrLoc.X, CurrLoc.Y, WMem, True End Sub 'Just a wrapper function to get the opposite direction of the given Dir (Ex North given returns South) Private Function OppositeDir(Dir As Direction) As Direction Select Case Dir Case North OppositeDir = South Case East OppositeDir = West Case South OppositeDir = North Case West OppositeDir = East Case NoDir OppositeDir = NoDir End Select End Function 'My own pathfinding creation. I'm proud of this function and must say it is the best thing I learned during 'this contest. I've never worked with any type of pathfinding so took me a little bit to come up with the idea behind it. 'Basically it sets the LocFrom block (should just be the location of the player) to Active then it spreads out from there 'in all 8 directions. If it hits a wall then it marks it as Dead. Marks old areas as Tested so that it only expands the edges 'which are set as Active. As its expanding it keeps up with the path it has taken to get to the expansion point. Each new 'expansion inherits the path of the parent block to make a complete path. If it finds an unexplored area but not 'UnSet (Unset has no info so could be a wall) then it marks that as the destination. 'Finishes checking the current set of Active blocks and if no more in the current set (essentially should be the same distance away) 'is unexplored it moves to the one found. But if it finds another unexplored it tests to see which one has more 'UnSet areas around it, then moves to that one. If they have the same amount of unset it moves to the first one. 'I know its a bit slow but now that I know the basis of pathfinding I can apply it in more places and get better at it :) Private Function PathFind(LocFrom As Location) As String Dim PathArray(-300 To 300, -300 To 300) As PathType Dim MLoc As Location, MLocP As Location Dim LowLoc As Location, HighLoc As Location Dim PLoop As Integer, PloopA As Integer Dim PathAdd As String Dim PMem As MemCell Dim MatchFound As Boolean Dim ForceDead As Boolean Dim OneActive As Boolean Dim MatchLoc As Location Dim MatchOpens As Byte Dim TestOpens As Byte PathArray(LocFrom.X, LocFrom.Y).Status = Active 'Set the LocFrom block Active LowLoc.X = LocFrom.X 'This makes the loop run faster not having to check all LowLoc.Y = LocFrom.Y '3600 possible locations in the array every loop HighLoc.X = LocFrom.X HighLoc.Y = LocFrom.Y MatchFound = False Do 'Primary pathfinding loop OneActive = False For MLoc.X = LowLoc.X To HighLoc.X For MLoc.Y = LowLoc.Y To HighLoc.Y If PathArray(MLoc.X, MLoc.Y).Status = Active Then 'Checks to see if the current location is Active if it is the expand it. OneActive = True For PLoop = 1 To 8 'Cycles through all expansion directions checking to be sure there is not already an Active MLocP.X = MLoc.X 'or tested block in that direction, if not it marks it active and makes it inherit the parents path MLocP.Y = MLoc.Y ForceDead = False Select Case PLoop Case 1 MLocP.Y = MLocP.Y - 1 PathAdd = "1" Case 2 MLocP.Y = MLocP.Y - 1 MLocP.X = MLocP.X + 1 Memory MLocP.X, MLoc.Y, PMem If PMem.Type <> Wall Then PathAdd = "21" Else Memory MLoc.X, MLocP.Y, PMem If PMem.Type <> Wall Then PathAdd = "12" Else ForceDead = True End If End If Case 3 MLocP.X = MLocP.X + 1 PathAdd = "2" Case 4 MLocP.X = MLocP.X + 1 MLocP.Y = MLocP.Y + 1 Memory MLocP.X, MLoc.Y, PMem If PMem.Type <> Wall Then PathAdd = "23" Else Memory MLoc.X, MLocP.Y, PMem If PMem.Type <> Wall Then PathAdd = "32" Else ForceDead = True End If End If Case 5 MLocP.Y = MLocP.Y + 1 PathAdd = "3" Case 6 MLocP.Y = MLocP.Y + 1 MLocP.X = MLocP.X - 1 Memory MLocP.X, MLoc.Y, PMem If PMem.Type <> Wall Then PathAdd = "43" Else Memory MLoc.X, MLocP.Y, PMem If PMem.Type <> Wall Then PathAdd = "34" Else ForceDead = True End If End If Case 7 MLocP.X = MLocP.X - 1 PathAdd = "4" Case 8 MLocP.X = MLocP.X - 1 MLocP.Y = MLocP.Y - 1 Memory MLocP.X, MLoc.Y, PMem If PMem.Type <> Wall Then PathAdd = "41" Else Memory MLoc.X, MLocP.Y, PMem If PMem.Type <> Wall Then PathAdd = "14" Else ForceDead = True End If End If End Select If PathArray(MLocP.X, MLocP.Y).Status = InActive And Not ForceDead Then 'Force dead is for situations where you might have a diagnol that is open but since the player can't Memory MLocP.X, MLocP.Y, PMem 'travel diagnolly it checks to be sure it can actually get to it if it can't it forces itself to set it to Dead If PMem.Type = Wall Or PMem.Type = UnSet Then PathArray(MLocP.X, MLocP.Y).Status = Dead Else PathArray(MLocP.X, MLocP.Y).Status = Active 'Set the expansion to Active PathArray(MLocP.X, MLocP.Y).Path = PathArray(MLoc.X, MLoc.Y).Path & PathAdd 'Inherit Path from the parent If Not PMem.Explored And Not MatchFound Then 'First non Explored match MatchFound = True PathFind = PathArray(MLocP.X, MLocP.Y).Path 'Returns the path in a string form for ChooseDirection to parse it and follow it MatchLoc.X = MLocP.X MatchLoc.Y = MLocP.Y MatchOpens = OpenAround(MatchLoc) ElseIf Not PMem.Explored And MatchFound Then 'This only fires if other matches are found in the same primary loop. So it can choose the one with the MatchLoc.X = MLocP.X 'most area to explore around it to go to. MatchLoc.Y = MLocP.Y TestOpens = OpenAround(MatchLoc) If TestOpens < MatchOpens Then PathFind = PathArray(MLocP.X, MLocP.Y).Path MatchOpens = TestOpens End If End If End If ElseIf ForceDead Then PathArray(MLocP.X, MLocP.Y).Status = Dead End If If MLocP.X > HighLoc.X Then HighLoc.X = MLocP.X If MLocP.X < LowLoc.X Then LowLoc.X = MLocP.X If MLocP.Y > HighLoc.Y Then HighLoc.Y = MLocP.Y If MLocP.Y < LowLoc.Y Then LowLoc.Y = MLocP.Y Next PathArray(MLoc.X, MLoc.Y).Status = Tested 'Marks the loc as tested End If Next Next DoEvents If Not OneActive Then Exit Do 'If everything has be expanded and killed then it has failed and exits Loop Until MatchFound End Function 'This is a wrapper function for testing the Unset or Unknown areas around a location. 'Used in the pathfinder function to decide (if two unexplored areas are found in the same expansion loop) which 'location is better to go to. Private Function OpenAround(TestLoc As Location) As Byte Dim OLoop As Integer Dim OMem As MemCell Dim OLoc As Location OpenAround = 0 For OLoop = 1 To 8 OLoc.X = TestLoc.X OLoc.Y = TestLoc.Y Select Case OLoop Case 1 OLoc.Y = OLoc.Y - 1 Case 2 OLoc.Y = OLoc.Y - 1 OLoc.X = OLoc.X + 1 Case 3 OLoc.X = OLoc.X + 1 Case 4 OLoc.X = OLoc.X + 1 OLoc.Y = OLoc.Y + 1 Case 5 OLoc.Y = OLoc.Y + 1 Case 6 OLoc.Y = OLoc.Y + 1 OLoc.X = OLoc.X - 1 Case 7 OLoc.X = OLoc.X - 1 Case 8 OLoc.X = OLoc.X - 1 OLoc.Y = OLoc.Y - 1 End Select Memory OLoc.X, OLoc.Y, OMem If OMem.Type = UnSet Or OMem.Type = UnKnown Then OpenAround = OpenAround + 1 End If Next End Function