Attribute VB_Name = "Controler"
'This is a wall-crawler algorythm. It is always running along the walls, working its
'way towards the center. The idea is that this is a simple enough construct and it
'covers a lot of ground very quickly at the beginning, also cleans up nicely

Option Explicit

'Direction constants
Const North As Byte = 1
Const East As Byte = 2
Const South As Byte = 3
Const West As Byte = 4

Const Unknown As Long = 0
Const Blocked As Long = -1
Const Passable As Long = -2

Dim Map() As Long 'Holds data about the maze
Dim CurrentMove As Long
Dim Searching As Boolean
'Position within map
Dim CurX As Long
Dim CurY As Long

'========================================
'=============MAIN FUNCTIONS=============
'========================================
Public Sub StartGame()
Dim A As Byte 'Iterator
Dim Moved As Boolean 'Flag
Dim Direc As Byte 'Current direction
ReDim Map(0 To 301, 0 To 301) '0 and 301 for the walls around 300x300
'I know, I know, lots of memory
'But it makes for a very easy to use system
'Especially when backtracking, the grid only branches
'forwards so backing up always brings you to the start
    
    CurX = 0
    CurY = 0
    SetMap 0, 0, 2 '2 won't backtrack to a 0 so we start with it
    CurrentMove = 3 'The number after 2 :D
    Searching = True
    While Searching
        Moved = False
        'Check every direction, starting with the one to the left
        For A = Direc + 1 To Direc + 5
            'Don't backtrack or try to move on blocked areas
            If Explored((A Mod 4) + 1) = False And Look((A Mod 4) + 1) Then
                Direc = (A Mod 4) + 1
                MovePlayer Direc
                Moved = True
                A = 100 'Exit the for loop
            End If
        Next A
        If Moved = False Then
            'No new way forward, back up
            FloodBack
        End If
    Wend
End Sub
Private Function MovePlayer(ByVal Direc As Long, Optional ByVal Forward As Boolean = True)
    
    'Don't move into the unknown or a wall
    If IsPassable(GetMapInDir(Direc)) Then
        'Searching becomes false if the end is found
        Searching = Not frmMain.MovePlayer(Direc)
        
        'Move stored position
        Select Case Direc
        Case North
            CurY = CurY - 1
        Case South
            CurY = CurY + 1
        Case East
            CurX = CurX + 1
        Case West
            CurX = CurX - 1
        End Select
        
        'Update map data with path info
        If Forward Then
            SetMap CurX, CurY, CurrentMove
            CurrentMove = CurrentMove + 1
        Else
            CurrentMove = GetMap(CurX, CurY) + 1
        End If
    End If
End Function

'========================================
'===========MAP DATA FUNCTIONS===========
'========================================
Private Function Look(ByVal Direc As Long) As Boolean
'Get the map data in a certain direction
'Query the form iff it isn't available
'Returns if the block is blocked or not
Dim XDif As Long
Dim YDif As Long
    
    'Make sure data isn't already available before looking
    If GetMapInDir(Direc) = Unknown Then
        Look = frmMain.Look(Direc)
    Else
        Look = IsPassable(GetMapInDir(Direc))
    End If
    
    'Update map data
    Select Case Direc
    Case North
        YDif = -1
    Case South
        YDif = 1
    Case East
        XDif = 1
    Case West
        XDif = -1
    End Select
    If Look Then
        If GetMap(CurX + XDif, CurY + YDif) = Unknown Then 'Don't cover known data
            SetMap CurX + XDif, CurY + YDif, Passable
        End If
    Else
        SetMap CurX + XDif, CurY + YDif, Blocked
    End If
End Function
Private Function GetMapInDir(ByVal Direc As Long) As Long
'Returns the stored value for a block in a certain direction
    Select Case Direc
    Case North
        GetMapInDir = GetMap(CurX, CurY - 1)
    Case South
        GetMapInDir = GetMap(CurX, CurY + 1)
    Case East
        GetMapInDir = GetMap(CurX + 1, CurY)
    Case West
        GetMapInDir = GetMap(CurX - 1, CurY)
    End Select
End Function
Private Function Explored(ByVal Direc As Long) As Boolean
'Returns if a block is explored (not unknown)
    Select Case Direc
    Case North
        Explored = CBool(GetMap(CurX, CurY - 1))
    Case South
        Explored = CBool(GetMap(CurX, CurY + 1))
    Case East
        Explored = CBool(GetMap(CurX + 1, CurY))
    Case West
        Explored = CBool(GetMap(CurX - 1, CurY))
    End Select
End Function
Private Function IsPassable(ByVal N As Long) As Boolean
'Pass a map data and ...
    IsPassable = Not (N = Blocked Or N = Unknown)
End Function
'These two functions reduce memory requirements via modulus
Private Function GetMap(ByVal X As Long, ByVal Y As Long) As Long
    GetMap = Map((X + 301) Mod 301, (Y + 301) Mod 301)
End Function
Private Sub SetMap(ByVal X As Long, ByVal Y As Long, ByVal Value As Long)
    Map((X + 301) Mod 301, (Y + 301) Mod 301) = Value
End Sub

'========================================
'=========BACKTRACKING FUNCTIONS=========
'========================================
Private Sub FloodBack()
'Use a flood fill pathing algo to find last unknown touching block
'Iterator
Dim A As Long
'Positions and parents
Dim ListX() As Long 'X position
Dim ListY() As Long 'Y position
Dim ListP() As Long 'Parent block direction
'Destination
Dim TX As Long
Dim TY As Long
'Don't cover blocks twice
Dim Flags(0 To 301, 0 To 301) As Long 'Long: 300x300 could go as high as 90 000
'Move list generated at end
Dim Moves() As Byte

    'Initialize arrays
    ReDim ListX(0 To 0)
    ReDim ListY(0 To 0)
    ReDim ListP(0 To 0)
    'Get destination
    TX = CurX
    TY = CurY
    FindJunction TX, TY
    'Initial values
    Flags((CurX + 301) Mod 301, (CurY + 301) Mod 301) = -1
    ListP(0) = 0
    ListX(0) = CurX
    ListY(0) = CurY
    
    'Let the floodfilling begin
    A = 0
    While A <= UBound(ListX) And A >= 0
        'Loop until no new blocks are available or the target is hit
        If ListX(A) = TX And TY = ListY(A) Then
            'exit loop when found
            A = -A 'negative means found
            If A = 0 Then
                A = 1 'positive means failed
            End If
        Else
            'Add all available blocks around a block
            'South
            If IsPassable(GetMap(ListX(A), ListY(A) + 1)) _
              And Flags((ListX(A) + 301) Mod 301, (ListY(A) + 1 + 301) Mod 301) = 0 Then
                ReDim Preserve ListX(0 To UBound(ListX) + 1)
                ReDim Preserve ListY(0 To UBound(ListY) + 1)
                ReDim Preserve ListP(0 To UBound(ListP) + 1)
                ListP(UBound(ListP)) = South
                ListX(UBound(ListX)) = ListX(A)
                ListY(UBound(ListY)) = ListY(A) + 1
                Flags((ListX(UBound(ListX)) + 301) Mod 301, (ListY(UBound(ListX)) + 301) Mod 301) = A + 1
            End If
            'North
            If IsPassable(GetMap(ListX(A), ListY(A) - 1)) _
              And Flags((ListX(A) + 301) Mod 301, (ListY(A) - 1 + 301) Mod 301) = 0 Then
                ReDim Preserve ListX(0 To UBound(ListX) + 1)
                ReDim Preserve ListY(0 To UBound(ListY) + 1)
                ReDim Preserve ListP(0 To UBound(ListP) + 1)
                ListP(UBound(ListP)) = North
                ListX(UBound(ListX)) = ListX(A)
                ListY(UBound(ListY)) = ListY(A) - 1
                Flags((ListX(UBound(ListX)) + 301) Mod 301, (ListY(UBound(ListX)) + 301) Mod 301) = A + 1
            End If
            'West
            If IsPassable(GetMap(ListX(A) - 1, ListY(A))) _
              And Flags((ListX(A) - 1 + 301) Mod 301, (ListY(A) + 301) Mod 301) = 0 Then
                ReDim Preserve ListX(0 To UBound(ListX) + 1)
                ReDim Preserve ListY(0 To UBound(ListY) + 1)
                ReDim Preserve ListP(0 To UBound(ListP) + 1)
                ListP(UBound(ListP)) = West
                ListX(UBound(ListX)) = ListX(A) - 1
                ListY(UBound(ListY)) = ListY(A)
                Flags((ListX(UBound(ListX)) + 301) Mod 301, (ListY(UBound(ListX)) + 301) Mod 301) = A + 1
            End If
            'East
            If IsPassable(GetMap(ListX(A) + 1, ListY(A))) _
              And Flags((ListX(A) + 1 + 301) Mod 301, (ListY(A) + 301) Mod 301) = 0 Then
                ReDim Preserve ListX(0 To UBound(ListX) + 1)
                ReDim Preserve ListY(0 To UBound(ListY) + 1)
                ReDim Preserve ListP(0 To UBound(ListP) + 1)
                ListP(UBound(ListP)) = East
                ListX(UBound(ListX)) = ListX(A) + 1
                ListY(UBound(ListY)) = ListY(A)
                Flags((ListX(UBound(ListX)) + 301) Mod 301, (ListY(UBound(ListX)) + 301) Mod 301) = A + 1
            End If
            A = A + 1
        End If
    Wend
    If A < 0 Then 'Path was found
        A = -A
        'Create move list
        ReDim Moves(0 To 0)
        While ListP(A)
            ReDim Preserve Moves(0 To UBound(Moves) + 1)
            Moves(UBound(Moves)) = ListP(A)
            A = Flags((ListX(A) + 301) Mod 301, (ListY(A) + 301) Mod 301) - 1
        Wend
        'Play out moves
        For A = UBound(Moves) To 1 Step -1
            MovePlayer Moves(A), False
        Next A
    Else
        'No path to the target was found, give up so you don't loop forever
        Searching = False
    End If
End Sub
Private Sub FindJunction(ByRef X As Long, ByRef Y As Long)
'Finds the first block back up the path that touches an unknown block
'Used to find the target block of floodback
Dim TX As Long
Dim TY As Long
    While GetMap(X + 1, Y) <> 0 _
      And GetMap(X - 1, Y) <> 0 _
      And GetMap(X, Y + 1) <> 0 _
      And GetMap(X, Y - 1) <> 0 _
      And PreviousStep(X, Y)
        TX = X
        TY = Y
    Wend
    Y = TY
    X = TX
End Sub
Private Function PreviousStep(ByRef X As Long, ByRef Y As Long) As Boolean
'Finds the previous pathing position from a certain x and y
    PreviousStep = True
    If GetMap(X, Y - 1) = GetMap(X, Y) - 1 Then
        Y = Y - 1
    ElseIf GetMap(X, Y + 1) = GetMap(X, Y) - 1 Then
        Y = Y + 1
    ElseIf GetMap(X - 1, Y) = GetMap(X, Y) - 1 Then
        X = X - 1
    ElseIf GetMap(X + 1, Y) = GetMap(X, Y) - 1 Then
        X = X + 1
    Else
        'Back at start
        PreviousStep = False
    End If
End Function