Attribute VB_Name = "modMapEngine"
Option Explicit

' Excel RPG - World Map Foundation (Milestone 1, refactored)
' Static terrain definitions: GameData!tblTerrain
' Handcrafted map directory: Maps!tblMaps
' Each map's top-left terrain cell has a workbook-scoped defined name.
' All rendering uses an in-memory, two-dimensional terrain array.

Private Const SCREEN_FIRST_ROW As Long = 4
Private Const SCREEN_FIRST_COL As Long = 2
Private Const SCREEN_CAPACITY_WIDTH As Long = 32
Private Const SCREEN_CAPACITY_HEIGHT As Long = 16

Private mTerrain As Variant
Private mMapWidth As Long
Private mMapHeight As Long
Private mMapTitle As String
Private mTerrainDefs As Object

Public Sub ShowMap()

    Dim previousScreenUpdating As Boolean
    previousScreenUpdating = Application.ScreenUpdating

    On Error GoTo Failed
    Application.ScreenUpdating = False

    LoadTerrainDefinitions
    LoadMap "FORT01"
    DrawMap
    InitialisePlayer 10, 8
    ThisWorkbook.Worksheets("Screen").Activate

CleanExit:
    Application.ScreenUpdating = previousScreenUpdating
    Exit Sub

Failed:
    MsgBox "Map display failed:" & vbCrLf & Err.Description, _
           vbExclamation, "Excel RPG"
    Resume CleanExit
    
End Sub

Private Sub LoadTerrainDefinitions()

    Dim tbl As ListObject
    Dim data As Variant
    Dim idCol As Long, nameCol As Long, glyphCol As Long
    Dim bgCol As Long, fgCol As Long
    Dim moveCol As Long, sightCol As Long
    Dim blockedCol As Long, enterCol As Long
    Dim r As Long, terrainID As Long

    Set tbl = ThisWorkbook.Worksheets("GameData").ListObjects("tblTerrain")
    
    If tbl.DataBodyRange Is Nothing Then
        Err.Raise vbObjectError + 101, , "tblTerrain is empty."
    End If

    idCol = tbl.ListColumns("TileID").Index
    nameCol = tbl.ListColumns("Name").Index
    glyphCol = tbl.ListColumns("Glyph").Index
    bgCol = tbl.ListColumns("Background").Index
    fgCol = tbl.ListColumns("Foreground").Index
    moveCol = tbl.ListColumns("BlocksMovement").Index
    sightCol = tbl.ListColumns("BlocksVision").Index
    blockedCol = tbl.ListColumns("BlockedMessage").Index
    enterCol = tbl.ListColumns("Entermessage").Index

    data = tbl.DataBodyRange.Value2
    Set mTerrainDefs = CreateObject("Scripting.Dictionary")

    For r = 1 To UBound(data, 1)
    
        terrainID = CLng(data(r, idCol))
        
        If mTerrainDefs.Exists(terrainID) Then
            Err.Raise vbObjectError + 102, , _
                      "Duplicate terrain ID: " & terrainID
        End If

        mTerrainDefs.Add terrainID, Array( _
            CStr(data(r, glyphCol)), _
            ColorFromHex(CStr(data(r, bgCol))), _
            ColorFromHex(CStr(data(r, fgCol))), _
            CBool(data(r, moveCol)), _
            CBool(data(r, sightCol)), _
            CStr(data(r, nameCol)), _
            CStr(data(r, blockedCol)), _
            CStr(data(r, enterCol)))
            
    Next r
    
End Sub

Private Sub LoadMap(ByVal mapID As String)

    Dim tbl As ListObject
    Dim data As Variant
    Dim idCol As Long, titleCol As Long
    Dim widthCol As Long, heightCol As Long, anchorCol As Long
    Dim r As Long, anchorName As String
    Dim anchor As Range
    Dim singleTile(1 To 1, 1 To 1) As Variant

    Set tbl = ThisWorkbook.Worksheets("Maps").ListObjects("tblMaps")
    If tbl.DataBodyRange Is Nothing Then
        Err.Raise vbObjectError + 110, , "tblMaps is empty."
    End If

    idCol = tbl.ListColumns("MapID").Index
    titleCol = tbl.ListColumns("DisplayName").Index
    widthCol = tbl.ListColumns("Width").Index
    heightCol = tbl.ListColumns("Height").Index
    anchorCol = tbl.ListColumns("AnchorName").Index
    data = tbl.DataBodyRange.Value2

    For r = 1 To UBound(data, 1)
        If StrComp(CStr(data(r, idCol)), mapID, vbTextCompare) = 0 Then
            mMapTitle = CStr(data(r, titleCol))
            mMapWidth = CLng(data(r, widthCol))
            mMapHeight = CLng(data(r, heightCol))
            anchorName = CStr(data(r, anchorCol))

            If mMapWidth < 1 Or mMapHeight < 1 Or _
               mMapWidth > SCREEN_CAPACITY_WIDTH Or _
               mMapHeight > SCREEN_CAPACITY_HEIGHT Then
                Err.Raise vbObjectError + 111, , _
                   "Map dimensions exceed this prototype's screen capacity."
            End If

            Set anchor = ThisWorkbook.Names(anchorName).RefersToRange
            If anchor.Parent.Name <> "Maps" Then
                Err.Raise vbObjectError + 112, , _
                   "The anchor must point to the Maps worksheet."
            End If
            If anchor.Cells.CountLarge <> 1 Then
                Err.Raise vbObjectError + 113, , _
                   "The map anchor must refer to one cell."
            End If

            ' One transfer, not a loop over individual worksheet cells.
            mTerrain = anchor.Resize(mMapHeight, mMapWidth).Value2

            ' Range.Value2 returns a scalar for a 1 x 1 range.
            If mMapWidth = 1 And mMapHeight = 1 Then
                singleTile(1, 1) = mTerrain
                mTerrain = singleTile
            End If
            Exit Sub
        End If
    Next r

    Err.Raise vbObjectError + 114, , "Unknown MapID: " & mapID
    
End Sub

Private Sub DrawMap()

    Dim ws As Worksheet
    Dim symbols() As Variant, ids() As Long
    Dim x As Long, y As Long, firstX As Long, terrainID As Long
    Dim raw As Variant, props As Variant
    Dim run As Range

    Set ws = ThisWorkbook.Worksheets("Screen")
    ReDim symbols(1 To mMapHeight, 1 To mMapWidth)
    ReDim ids(1 To mMapHeight, 1 To mMapWidth)

    ' First validate every ID and prepare the glyph array.
    For y = 1 To mMapHeight
        For x = 1 To mMapWidth
            raw = mTerrain(y, x)
            If IsError(raw) Then
                Err.Raise vbObjectError + 120, , _
                    "Invalid tile at X=" & x & ", Y=" & y
            End If
            If Not IsNumeric(raw) Then
                Err.Raise vbObjectError + 121, , _
                    "Non-numeric tile at X=" & x & ", Y=" & y
            End If
            If CDbl(raw) <> Fix(CDbl(raw)) Then
                Err.Raise vbObjectError + 122, , _
                    "Non-integer tile at X=" & x & ", Y=" & y
            End If
            terrainID = CLng(raw)
            If Not mTerrainDefs.Exists(terrainID) Then
                Err.Raise vbObjectError + 123, , _
                    "Unknown terrain " & terrainID & _
                    " at X=" & x & ", Y=" & y
            End If

            ids(y, x) = terrainID
            props = mTerrainDefs(terrainID)
            symbols(y, x) = props(0)
        Next x
    Next y

    ' Clear the entire available terrain area before drawing a map.
    With ws.Cells(SCREEN_FIRST_ROW, SCREEN_FIRST_COL). _
            Resize(SCREEN_CAPACITY_HEIGHT, SCREEN_CAPACITY_WIDTH)
        .ClearContents
        .Interior.Color = RGB(23, 35, 43)
        .Font.Color = RGB(221, 230, 232)
    End With

    ' Bulk-write visible characters to Excel.
    ws.Cells(SCREEN_FIRST_ROW, SCREEN_FIRST_COL). _
       Resize(mMapHeight, mMapWidth).Value2 = symbols

    ' Format adjacent equal-terrain cells as horizontal runs.
    For y = 1 To mMapHeight
        x = 1
        Do While x <= mMapWidth
            terrainID = ids(y, x)
            firstX = x
            Do While x < mMapWidth
                If ids(y, x + 1) <> terrainID Then Exit Do
                x = x + 1
            Loop

            props = mTerrainDefs(terrainID)
            Set run = ws.Cells(SCREEN_FIRST_ROW + y - 1, _
                               SCREEN_FIRST_COL + firstX - 1). _
                         Resize(1, x - firstX + 1)
            run.Interior.Color = props(1)
            run.Font.Color = props(2)
            x = x + 1
        Loop
    Next y

    ws.Range("B2").Value2 = UCase$(mMapTitle)
    ws.Range("B23").Value2 = mMapWidth & " x " & mMapHeight & " tiles"
    ws.Range("K23").Value2 = "Map loaded from tblMaps."
    
End Sub

Private Function ColorFromHex(ByVal code As String) As Long

    code = Trim$(code)
    If Len(code) <> 7 Or Left$(code, 1) <> "#" Then
        Err.Raise vbObjectError + 130, , _
            "Expected an HTML-style colour such as #335541."
    End If

    ColorFromHex = RGB( _
        CLng("&H" & Mid$(code, 2, 2)), _
        CLng("&H" & Mid$(code, 4, 2)), _
        CLng("&H" & Mid$(code, 6, 2)))
        
End Function

Public Function IsWithinMap(ByVal x As Long, ByVal y As Long) As Boolean

    IsWithinMap = (x >= 1 And x <= mMapWidth And y >= 1 And y <= mMapHeight)

End Function

Public Function IsTileWalkable(ByVal x As Long, ByVal y As Long) As Boolean

    Dim properties As Variant

    'no terrain has been loaded
    If mTerrainDefs Is Nothing Then Exit Function

    'coordinates outside map are impassable
    If Not IsWithinMap(x, y) Then Exit Function
    
    'retrieve the terrain definition at this coordinate
    properties = mTerrainDefs(CLng(mTerrain(y, x)))

    IsTileWalkable = Not CBool(properties(3))

End Function

Public Function GetTerrainMessage(ByVal x As Long, ByVal y As Long, ByVal blocked As Boolean) As String

    Dim properties As Variant
    
    If Not IsWithinMap(x, y) Then
        GetTerrainMessage = "You cannot leave map that way."
        Exit Function
    End If
    
    properties = mTerrainDefs(CLng(mTerrain(y, x)))
    
    If blocked Then
        GetTerrainMessage = CStr(properties(6))
    Else:
        GetTerrainMessage = CStr(properties(7))
    End If
    
    If Len(Trim$(GetTerrainMessage)) = 0 Then
    
        If blocked Then
            GetTerrainMessage = "You cannot go that way."
        Else:
            GetTerrainMessage = "You move."
        End If
        
    End If

End Function

Public Function GetScreenCell(ByVal x As Long, ByVal y As Long) As Range

    Set GetScreenCell = ThisWorkbook.Worksheets("Screen").Cells(SCREEN_FIRST_ROW + y - 1, SCREEN_FIRST_COL + x - 1)
    
End Function

Public Sub RedrawTerrainTile(ByVal x As Long, ByVal y As Long)

    Dim properties As Variant
    Dim target As Range
    
    properties = mTerrainDefs(CLng(mTerrain(y, x)))
    Set target = GetScreenCell(x, y)
    
    With target
        .Value2 = properties(0)
        .Interior.Color = properties(1)
        .Font.Color = properties(2)
        .Font.Bold = False
    End With
    
End Sub