Attribute VB_Name = "TOA_Local"
' Main macro: RunTOA_Local (scans brief, marks TA fields)
' Also: InsertTOAAtCursor, MarkCitationDialog, InsertEmptyTOAShell, InsertTOAFromTSV
' Install: Alt+F11 → Import this file once → Macros → RunTOA_Local
' Word for Windows (VBScript.RegExp).

Option Explicit

' --- Licensing (HTTPS check; documents never uploaded) ---
Private Const LICENSE_URL As String = "https://adams-mac-mini.tail9ec240.ts.net/api/license/check"
Private Const LICENSE_GRACE_DAYS As Long = 14
Private Const REG_PATH As String = "HKCU\Software\TableOfAuthorities\"

Private Const BUY_URL As String = "https://adams-mac-mini.tail9ec240.ts.net/pricing"

Private Function EnsureLicensed() As Boolean
    Dim key As String
    Dim lastOk As String
    Dim expiresAt As String
    Dim machineId As String
    Dim result As String

    key = RegRead("LicenseKey")
    lastOk = RegRead("LastCheckOk")
    expiresAt = RegRead("ExpiresAt")
    machineId = GetMachineId()

    If Len(key) = 0 Then
        key = Trim$(InputBox("Enter your Table of Authorities license key (TOA-XXXX-...):", "Activate license"))
        If Len(key) = 0 Then
            MsgBox "A license key is required. Start a free trial at " & BUY_URL, vbExclamation
            EnsureLicensed = False
            Exit Function
        End If
        RegWrite "LicenseKey", key
    End If

    result = LicenseCheckHttp(key, machineId)
    If result = "OK" Then
        RegWrite "LastCheckOk", Format$(Now, "yyyy-mm-dd")
        EnsureLicensed = True
        Exit Function
    End If

    ' Hard stop: server said expired / invalid / inactive / seats full — never apply offline grace
    If IsHardLicenseDeny(result) Then
        MsgBox LicenseDenyMessage(result), vbExclamation, "License"
        If result = "invalid_key" Then
            key = Trim$(InputBox("Re-enter license key:", "Activate license", key))
            If Len(key) = 0 Then
                EnsureLicensed = False
                Exit Function
            End If
            RegWrite "LicenseKey", key
            result = LicenseCheckHttp(key, machineId)
            If result = "OK" Then
                RegWrite "LastCheckOk", Format$(Now, "yyyy-mm-dd")
                EnsureLicensed = True
                Exit Function
            End If
            MsgBox LicenseDenyMessage(result), vbExclamation, "License"
        End If
        EnsureLicensed = False
        Exit Function
    End If

    ' Offline / network failure only: honor stored ExpiresAt, then LastCheckOk grace
    expiresAt = RegRead("ExpiresAt")
    If Len(expiresAt) >= 10 Then
        On Error Resume Next
        If Date > CDate(Left$(expiresAt, 10)) Then
            On Error GoTo 0
            MsgBox "Trial/license expired. Buy at " & BUY_URL, vbExclamation, "License"
            EnsureLicensed = False
            Exit Function
        End If
        On Error GoTo 0
    End If

    If Len(lastOk) > 0 Then
        On Error Resume Next
        If DateDiff("d", CDate(lastOk), Date) <= LICENSE_GRACE_DAYS Then
            On Error GoTo 0
            EnsureLicensed = True
            Exit Function
        End If
        On Error GoTo 0
    End If

    MsgBox "Could not reach the license server (" & result & ") and offline grace has ended." & vbCrLf & _
           "Check your connection or buy at " & BUY_URL, vbExclamation, "License"
    EnsureLicensed = False
End Function

Private Function IsHardLicenseDeny(ByVal result As String) As Boolean
    Select Case LCase$(result)
        Case "expired", "invalid_key", "inactive", "seats_full", "missing_key_or_machine"
            IsHardLicenseDeny = True
        Case Else
            IsHardLicenseDeny = False
    End Select
End Function

Private Function LicenseDenyMessage(ByVal result As String) As String
    Select Case LCase$(result)
        Case "expired"
            LicenseDenyMessage = "Trial/license expired. Buy at " & BUY_URL
        Case "invalid_key"
            LicenseDenyMessage = "License key not found. Start a trial or buy at " & BUY_URL
        Case "inactive"
            LicenseDenyMessage = "License is inactive. Contact support or buy at " & BUY_URL
        Case "seats_full"
            LicenseDenyMessage = "All seats for this license are in use."
        Case Else
            LicenseDenyMessage = "License not valid (" & result & "). See " & BUY_URL
    End Select
End Function

' Returns "OK", a hard-deny error code, or "offline" / "HTTP nnn" for connectivity issues.
Private Function LicenseCheckHttp(ByVal key As String, ByVal machineId As String) As String
    Dim http As Object
    Dim body As String
    Dim status As Long
    Dim resp As String
    Dim errCode As String
    Dim expIso As String

    On Error GoTo Fail
    body = "{""key"":""" & JsonEscape(key) & """,""machine_id"":""" & JsonEscape(machineId) & """,""machine_label"":""" & JsonEscape(Environ$("COMPUTERNAME")) & """}"
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    http.Open "POST", LICENSE_URL, False
    http.SetRequestHeader "Content-Type", "application/json"
    http.SetTimeouts 5000, 5000, 8000, 8000
    http.Send body
    status = http.Status
    resp = http.ResponseText

    If JsonBoolTrue(resp, "ok") Then
        expIso = JsonStringField(resp, "expires_at")
        If Len(expIso) >= 10 Then RegWrite "ExpiresAt", Left$(expIso, 10)
        LicenseCheckHttp = "OK"
        Exit Function
    End If

    errCode = JsonStringField(resp, "error")
    If Len(errCode) > 0 Then
        LicenseCheckHttp = errCode
    Else
        LicenseCheckHttp = "HTTP " & CStr(status)
    End If
    Exit Function
Fail:
    LicenseCheckHttp = "offline"
End Function

Private Function JsonBoolTrue(ByVal json As String, ByVal field As String) As Boolean
    ' Accept both compact and spaced JSON: "ok":true / "ok": true
    If InStr(1, json, """" & field & """:true", vbTextCompare) > 0 Then
        JsonBoolTrue = True
    ElseIf InStr(1, json, """" & field & """: true", vbTextCompare) > 0 Then
        JsonBoolTrue = True
    Else
        JsonBoolTrue = False
    End If
End Function

Private Function JsonStringField(ByVal json As String, ByVal field As String) As String
    Dim p As Long, q As Long, startPos As Long
    Dim patterns As Variant
    Dim i As Long
    patterns = Array("""" & field & """:""", """" & field & """: """)
    For i = LBound(patterns) To UBound(patterns)
        p = InStr(1, json, CStr(patterns(i)), vbTextCompare)
        If p > 0 Then
            startPos = p + Len(CStr(patterns(i)))
            q = InStr(startPos, json, """")
            If q > startPos Then
                JsonStringField = Mid$(json, startPos, q - startPos)
                Exit Function
            End If
        End If
    Next i
    JsonStringField = ""
End Function

Private Function JsonEscape(ByVal s As String) As String
    s = Replace(s, "\", "\\")
    s = Replace(s, """", "\""")
    JsonEscape = s
End Function

Private Function GetMachineId() As String
    Dim id As String
    id = RegRead("MachineId")
    If Len(id) = 0 Then
        id = Environ$("COMPUTERNAME") & "-" & Environ$("USERNAME")
        If Len(id) < 3 Then id = "word-" & Format$(Now, "yyyymmddhhnnss")
        RegWrite "MachineId", id
    End If
    GetMachineId = id
End Function

Private Function RegRead(ByVal name As String) As String
    On Error Resume Next
    RegRead = CStr(CreateObject("WScript.Shell").RegRead(REG_PATH & name))
    On Error GoTo 0
End Function

Private Sub RegWrite(ByVal name As String, ByVal value As String)
    On Error Resume Next
    CreateObject("WScript.Shell").RegWrite REG_PATH & name, value, "REG_SZ"
    On Error GoTo 0
End Sub


Private Const CAT_CASES As Long = 1
Private Const CAT_STATUTES As Long = 2
Private Const CAT_OTHER As Long = 3
Private Const CAT_CONST As Long = 7

Public Sub RunTOA_Local()
    Dim n As Long
    If Not EnsureLicensed() Then Exit Sub
    If MsgBox( _
        "Scan the active document and insert TA (Table of Authorities) marks?", _
        vbYesNo + vbQuestion, "Table of Authorities") <> vbYes Then Exit Sub

    n = MarkAuthoritiesInActiveDocument()
    If n = 0 Then
        MsgBox "No citations matched. Review patterns or mark manually (MarkCitationDialog).", vbExclamation
        Exit Sub
    End If

    If MsgBox( _
        "Marked " & n & " citation(s) with TA fields." & vbCrLf & vbCrLf & _
        "Insert a Table of Authorities at the current cursor position now?", _
        vbYesNo + vbQuestion, "Table of Authorities") = vbYes Then
        InsertTOAAtCursor
    Else
        MsgBox "Done. When ready: place cursor → run InsertTOAAtCursor, " & _
               "or References → Insert Table of Authorities.", vbInformation
    End If
End Sub

Public Sub MarkCitationDialog()
    On Error Resume Next
    Dialogs(wdDialogMarkCitation).Show
    If Err.Number <> 0 Then
        Err.Clear
        Dialogs(16388).Show
    End If
    On Error GoTo 0
End Sub

Public Sub InsertTOAAtCursor()
    On Error GoTo Fail
    Selection.Collapse Direction:=wdCollapseStart
    Dialogs(wdDialogInsertTableOfAuthorities).Show
    Exit Sub
Fail:
    MsgBox "Could not insert TOA. Use References → Insert Table of Authorities.", vbExclamation
End Sub

Public Function MarkAuthoritiesInActiveDocument() As Long
    Dim re As Object
    Dim matches As Object
    Dim m As Object
    Dim doc As Document
    Dim txt As String
    Dim marked As Long
    Dim already As Object
    Dim key As String
    Dim longCite As String
    Dim rawMatch As String
    Dim bodyStart As Long

    Set doc = ActiveDocument
    Set already = CreateObject("Scripting.Dictionary")
    marked = 0
    bodyStart = EstimateBodyStart(doc)

    On Error GoTo NoRegex
    Set re = CreateObject("VBScript.RegExp")
    On Error GoTo 0

    txt = doc.Range.Text
    txt = Replace(txt, ChrW(&HAD), "")
    txt = Replace(txt, ChrW(160), " ")

    re.Global = True
    re.IgnoreCase = False
    re.MultiLine = False

    ' Cases — start at party name / Ex parte / In re (not earlier prose)
    re.Pattern = _
        "(?:Ex\s+parte|In\s+re)\s+[A-Z][\w'’\.\-]+(?:\s+[A-Z][\w'’\.\-]+){0,6}" & _
        "|[A-Z][\w'’\.\-&]+(?:\s+[A-Z][\w'’\.\-&|,]+){0,10}\s+v\.?\s+[A-Z][\w'’\.\-&]+(?:\s+[A-Z][\w'’\.\-&|,]+){0,10}" & _
        ",?\s+\d+\s+(?:U\.?\s*S\.?|S\.?\s*Ct\.?|F\.(?:2d|3d|4th)|F\.\s*Supp\.(?:\s*3d)?)" & _
        "\s+\d+(?:\s*,\s*\d+(?:\s*[\-\u2013\u2014]\s*\d+)?)?\s*\(\d{4}\)"

    Set matches = re.Execute(txt)
    For Each m In matches
        rawMatch = m.Value
        longCite = CanonicalCaseCite(rawMatch)
        If Len(longCite) = 0 Then GoTo NextCase
        key = "c:" & LCase$(longCite)
        If Not already.Exists(key) Then
            If InsertTAAtBestHit(doc, rawMatch, longCite, CAT_CASES, bodyStart) Then
                already.Add key, True
                marked = marked + 1
            End If
        End If
NextCase:
    Next m

    ' Constitution
    re.IgnoreCase = True
    re.Pattern = "U\.?\s*S\.?\s*Const\.?\s*(?:art\.?\s*[IVXLC]+(?:\s*,?\s*§\s*\d+(?:\s*,?\s*cl\.?\s*\d+)?)?|amend\.?\s*[IVXLC\d]+)"
    Set matches = re.Execute(txt)
    For Each m In matches
        longCite = CleanCite(m.Value)
        key = "k:" & LCase$(longCite)
        If Not already.Exists(key) Then
            If InsertTAAtBestHit(doc, m.Value, longCite, CAT_CONST, bodyStart) Then
                already.Add key, True
                marked = marked + 1
            End If
        End If
    Next m

    ' Statutes / rules
    re.Pattern = _
        "\d+\s+U\.?\s*S\.?\s*C\.?\s*§+\s*[\dA-Za-z\-]+(?:\([a-z0-9]+\))*" & _
        "|Fed\.?\s*R\.?\s*Civ\.?\s*P\.?\s*\d+(?:\.\d+)?(?:\([a-z0-9]+\))*" & _
        "|Fed\.?\s*R\.?\s*Evid\.?\s*\d+(?:\.\d+)?" & _
        "|F\.?\s*R\.?\s*C\.?\s*P\.?\s*\d+(?:\.\d+)?"
    Set matches = re.Execute(txt)
    For Each m In matches
        longCite = CleanCite(m.Value)
        key = "s:" & LCase$(longCite)
        If Not already.Exists(key) Then
            If InsertTAAtBestHit(doc, m.Value, longCite, CAT_STATUTES, bodyStart) Then
                already.Add key, True
                marked = marked + 1
            End If
        End If
    Next m

    MarkAuthoritiesInActiveDocument = marked
    Exit Function

NoRegex:
    MsgBox "VBScript.RegExp is not available in this Word. Use MarkCitationDialog, or Word for Windows.", _
           vbExclamation, "Table of Authorities"
    MarkAuthoritiesInActiveDocument = 0
End Function

' Prefer a hit in the body (after TOC/TOA), else the last hit in the doc.
Private Function InsertTAAtBestHit(ByVal doc As Document, ByVal findText As String, _
                                   ByVal longCite As String, ByVal cat As Long, _
                                   ByVal bodyStart As Long) As Boolean
    Dim rng As Range
    Dim best As Range
    Dim bestPos As Long
    Dim bodyBest As Range
    Dim bodyPos As Long
    Dim needle As String

    needle = Left$(findText, 255)
    bestPos = -1
    bodyPos = -1
    Set best = Nothing
    Set bodyBest = Nothing

    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Text = needle
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
    End With

    Do While rng.Find.Execute
        If Not RangeHasTA(rng) Then
            If rng.Start >= bestPos Then
                bestPos = rng.Start
                Set best = rng.Duplicate
            End If
            If rng.Start >= bodyStart Then
                If rng.Start >= bodyPos Then
                    bodyPos = rng.Start
                    Set bodyBest = rng.Duplicate
                End If
            End If
        End If
        rng.Collapse Direction:=wdCollapseEnd
    Loop

    If Not bodyBest Is Nothing Then
        InsertTAAtBestHit = InsertTAField(bodyBest, longCite, cat)
    ElseIf Not best Is Nothing Then
        InsertTAAtBestHit = InsertTAField(best, longCite, cat)
    Else
        InsertTAAtBestHit = False
    End If
End Function

Private Function InsertTAField(ByVal rng As Range, ByVal longCite As String, ByVal cat As Long) As Boolean
    Dim safe As String
    Dim code As String
    Dim at As Range

    safe = Replace(longCite, """", "'")
    safe = Trim$(safe)
    If Len(safe) = 0 Then
        InsertTAField = False
        Exit Function
    End If

    Set at = rng.Duplicate
    at.Collapse Direction:=wdCollapseEnd
    ' wdFieldTOAEntry = 57 — use typed field so \l text is authoritative
    code = "TA \l """ & safe & """ \c " & CStr(cat)
    On Error Resume Next
    ActiveDocument.Fields.Add Range:=at, Type:=57, Text:=code, PreserveFormatting:=False
    If Err.Number <> 0 Then
        Err.Clear
        ActiveDocument.Fields.Add Range:=at, Type:=wdFieldEmpty, Text:=" " & code & " ", PreserveFormatting:=False
    End If
    On Error GoTo 0
    InsertTAField = True
End Function

Private Function EstimateBodyStart(ByVal doc As Document) As Long
    ' Skip caption / TOC / existing TOA when choosing which hit to mark.
    Dim rng As Range
    Dim markers As Variant
    Dim i As Long
    Dim pos As Long

    markers = Array("TABLE OF AUTHORITIES", "Table of Authorities", _
                    "ARGUMENT", "Argument", "INTRODUCTION", "Introduction", _
                    "BACKGROUND", "Background", "STATEMENT OF")
    pos = 0
    For i = LBound(markers) To UBound(markers)
        Set rng = doc.Content
        With rng.Find
            .ClearFormatting
            .Text = CStr(markers(i))
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = False
            .Execute
        End With
        If rng.Find.Found Then
            If rng.End > pos Then pos = rng.End
        End If
    Next i
    ' If we found TOA/TOC-ish headings, body is after the latest; else ~first 8% of doc
    If pos > 0 Then
        EstimateBodyStart = pos
    Else
        EstimateBodyStart = CLng(doc.Content.End * 0.08)
    End If
End Function

Private Function CanonicalCaseCite(ByVal raw As String) As String
    Dim s As String
    Dim re As Object
    Dim m As Object
    Dim vPos As Long
    Dim dotPos As Long
    Dim ep As Long

    s = CleanCite(raw)
    Set re = CreateObject("VBScript.RegExp")
    re.IgnoreCase = True
    re.Global = False
    re.Pattern = "^(?:See(?:\s+also)?|But\s+see|Cf\.?|Compare|e\.g\.?|accord|contra)\s+"
    s = re.Replace(s, "")

    vPos = InStr(1, s, " v.", vbTextCompare)
    If vPos = 0 Then vPos = InStr(1, s, " v ", vbTextCompare)
    If vPos > 0 Then
        dotPos = InStrRev(Left$(s, vPos), ". ")
        If dotPos > 0 Then s = Mid$(s, dotPos + 2)
    End If

    ep = InStr(1, s, "Ex parte ", vbTextCompare)
    If ep = 0 Then ep = InStr(1, s, "In re ", vbTextCompare)
    If ep > 1 Then s = Mid$(s, ep)

    re.Pattern = "((?:Ex\s+parte|In\s+re)\s+.+|[A-Z][\w'’\.\-&].+?\sv\.?\s.+)$"
    Set m = re.Execute(s)
    If m.Count > 0 Then
        s = m(0).SubMatches(0)
    End If

    s = StripPincite(CleanCite(s))
    CanonicalCaseCite = s
End Function

Private Function RangeHasTA(ByVal rng As Range) As Boolean
    Dim f As Field
    Dim probe As Range
    Set probe = rng.Duplicate
    On Error Resume Next
    probe.MoveStart Unit:=wdCharacter, Count:=-30
    probe.MoveEnd Unit:=wdCharacter, Count:=60
    On Error GoTo 0
    For Each f In probe.Fields
        If InStr(1, f.Code.Text, "TA ", vbTextCompare) > 0 Then
            RangeHasTA = True
            Exit Function
        End If
    Next f
    RangeHasTA = False
End Function

Private Function CleanCite(ByVal s As String) As String
    s = Replace(s, vbCr, " ")
    s = Replace(s, vbLf, " ")
    s = Replace(s, ChrW(160), " ")
    Do While InStr(s, "  ") > 0
        s = Replace(s, "  ", " ")
    Loop
    CleanCite = Trim$(s)
End Function

Private Function StripPincite(ByVal cite As String) As String
    Dim re As Object
    On Error GoTo Done
    Set re = CreateObject("VBScript.RegExp")
    re.IgnoreCase = True
    re.Global = False
    re.Pattern = "(\d+\s+(?:U\.?\s*S\.?|S\.?\s*Ct\.?|F\.(?:2d|3d|4th)|F\.\s*Supp\.(?:\s*3d)?)\s+\d+)\s*,\s*\d+(?:\s*[\-\u2013\u2014]\s*\d+)?(?=\s*\()"
    cite = re.Replace(cite, "$1")
Done:
    StripPincite = CleanCite(cite)
End Function

Public Sub InsertEmptyTOAShell()
    Dim rng As Range
    Set rng = Selection.Range
    rng.Collapse Direction:=wdCollapseStart
    rng.InsertAfter "TABLE OF AUTHORITIES" & vbCr
    rng.Paragraphs(1).Range.Font.Bold = True
    rng.Paragraphs(1).Alignment = wdAlignParagraphCenter
    rng.Collapse Direction:=wdCollapseEnd
    Call AddHeading(rng, "Cases")
    Call AddHeading(rng, "Constitutional Provisions")
    Call AddHeading(rng, "Statutes and Rules")
    Call AddHeading(rng, "Other Authorities")
    MsgBox "Empty TOA headings inserted.", vbInformation
End Sub

Private Sub AddHeading(ByRef rng As Range, ByVal title As String)
    rng.InsertAfter vbCr & title & vbCr
    rng.Paragraphs(rng.Paragraphs.Count - 1).Range.Font.Bold = True
    rng.Collapse Direction:=wdCollapseEnd
End Sub

Public Sub InsertTOAFromTSV()
    Dim fd As FileDialog
    Dim path As String
    Dim f As Integer
    Dim line As String
    Dim parts() As String
    Dim cat As String, cite As String, pages As String
    Dim lastCat As String
    Dim rng As Range
    Dim p As Paragraph

    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "Select TOA TSV"
        .Filters.Clear
        .Filters.Add "TOA TSV", "*.tsv"
        .Filters.Add "Text", "*.txt;*.csv"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        path = .SelectedItems(1)
    End With

    Set rng = Selection.Range
    rng.Collapse Direction:=wdCollapseStart
    rng.InsertAfter "TABLE OF AUTHORITIES" & vbCr
    With rng.Paragraphs(1)
        .Range.Font.Name = "Times New Roman"
        .Range.Font.Size = 14
        .Range.Font.Bold = True
        .Alignment = wdAlignParagraphCenter
    End With
    rng.Collapse Direction:=wdCollapseEnd
    lastCat = ""

    f = FreeFile
    Open path For Input As #f
    Do While Not EOF(f)
        Line Input #f, line
        line = Replace(line, Chr$(9), vbTab)
        If Len(Trim$(line)) = 0 Then GoTo Cont
        If InStr(line, vbTab) = 0 Then GoTo Cont
        parts = Split(line, vbTab)
        If UBound(parts) < 1 Then GoTo Cont
        cat = Trim$(parts(0))
        cite = ""
        pages = ""
        If UBound(parts) >= 1 Then cite = Trim$(parts(1))
        If UBound(parts) >= 2 Then pages = Trim$(parts(2))
        If LCase$(cat) = "category" And LCase$(cite) = "cite" Then GoTo Cont
        If Len(cite) = 0 Then GoTo Cont

        If StrComp(cat, lastCat, vbTextCompare) <> 0 Then
            rng.InsertAfter vbCr & cat & vbCr
            Set p = rng.Paragraphs(rng.Paragraphs.Count - 1)
            p.Range.Font.Name = "Times New Roman"
            p.Range.Font.Size = 12
            p.Range.Font.Bold = True
            lastCat = cat
            rng.Collapse Direction:=wdCollapseEnd
        End If

        rng.InsertAfter cite & vbTab & pages & vbCr
        Set p = rng.Paragraphs(rng.Paragraphs.Count - 1)
        p.Range.Font.Name = "Times New Roman"
        p.Range.Font.Size = 12
        p.Range.Font.Bold = False
        p.Format.TabStops.ClearAll
        p.Format.TabStops.Add Position:=InchesToPoints(6.5), _
            Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
        rng.Collapse Direction:=wdCollapseEnd
Cont:
    Loop
    Close #f
    MsgBox "TOA inserted from:" & vbCr & path, vbInformation
End Sub