cubical-transport-hott-lean4/CubicalTransport/Algebra/Methodology.lean

/-
  CubicalTransport.Algebra.Methodology — `@[methodology]` + `cubical_search`
  ==========================================================================
  Phase D' of `docs/ALGEBRA_PLAN.md`.  Provides the autodiscovery
  layer that crowns the metacoding stack:

  - `@[methodology]` attribute: registers a Lean theorem as a "proof
    fragment" indexed by a classifier shape.  When `cubical_search`
    encounters a question matching that shape, it tries the
    registered theorem.

  - `cubical_search` tactic: walks the methodology library by
    classifier dispatch and applies matches; on miss, attempts
    methodology-transport along declared structural Paths
    (`transp`-at-the-meta-level).

  Per ALGEBRA_PLAN §4.3:
  > Once a small library of base methodologies exists, every new
  > structural Path declared in the codebase **automatically generates
  > new methodology candidates** by transporting existing methodologies
  > across the path.

  This module ships the registry + the basic tactic; the
  methodology-transport clause is scaffolded as `deriveByTransport`
  (a stub returning `[]` until the structural-Path infrastructure
  arrives in REL2.6+).
-/

import Lean
import CubicalTransport.Algebra.MacroAlias
import CubicalTransport.Algebra.MetaPath

namespace CubicalTransport.Algebra

open Lean Lean.Elab Lean.Elab.Tactic

-- ── Methodology entries ─────────────────────────────────────────────────────

/-- A registered methodology.  Indexes a Lean theorem by the
    classifier shape it solves.

    `classifierName` is a `Name` referring to a `MetaClassifier`-
    valued `def` (or one of the syntactic classifier predicates from
    `Question.lean`).  `theoremName` is the `Name` of the theorem
    that `cubical_search` will try when the question matches.

    Priority is used for ordering: higher priority methodologies are
    tried first.  Default 100; specialised methodologies bump higher,
    catch-alls run lower. -/
structure MethodologyEntry where
  classifierName : Name
  theoremName    : Name
  priority       : Nat := 100
  description    : String := ""
  deriving Repr, Inhabited

-- ── The methodology registry ────────────────────────────────────────────────

/-- Global registry of methodologies, indexed by classifier name.
    Built up via `@[methodology]`-tagged declarations.

    Implementation: `EnvExtension` so adds are visible across
    modules.  Lookup is linear in the registry size (acceptable for
    REL2.5; a discrtree-indexed version is REL2.6 work per
    ALGEBRA_PLAN §10.4). -/
initialize methodologyRegistryExt :
    SimplePersistentEnvExtension MethodologyEntry (Array MethodologyEntry) ←
  registerSimplePersistentEnvExtension {
    name          := `Algebra.methodologyRegistry
    addEntryFn    := fun arr e => arr.push e
    addImportedFn := fun arrs => arrs.foldl (init := #[]) Array.append
    asyncMode     := .sync
  }

def getMethodologies : CoreM (Array MethodologyEntry) := do
  let env ← getEnv
  return methodologyRegistryExt.getState env

def registerMethodology (entry : MethodologyEntry) : CoreM Unit := do
  modifyEnv (methodologyRegistryExt.addEntry · entry)

/-- Find every methodology indexed against a given classifier name. -/
def findMethodologies (classifier : Name) : CoreM (Array MethodologyEntry) := do
  let all ← getMethodologies
  return all.filter (·.classifierName == classifier)

-- ── The `@[methodology]` attribute ──────────────────────────────────────────
-- Attached to a theorem.  Attribute parser parses the classifier
-- name and optional priority.  Registration adds an entry to the
-- methodology registry pointing back to the tagged theorem.

/-- Parser-level data for the `@[methodology]` attribute.  We accept
    a plain identifier naming the classifier.  Priority configuration
    via `priority := n` is Phase D'.1 work; the v0 attribute uses a
    fixed default of 100.

    The syntax `name :=` matches the attribute name registered below;
    Lean's attribute system looks up attributes by syntax kind, not
    by leading keyword. -/
syntax (name := methodology) "methodology" ident : attr

/-- The `@[methodology]` attribute itself.  Records the tagged
    theorem under the named classifier (priority defaults to 100). -/
initialize methodologyAttr : Unit ←
  registerBuiltinAttribute {
    name := `methodology
    descr := "Register this theorem as a proof methodology indexed \
              by a classifier (Phase D' of ALGEBRA_PLAN.md).  Usage: \
              `@[methodology IsFullFace]`."
    add := fun declName stx _kind => do
      -- Parse classifier name from the attribute syntax.
      let classifierName? : Option Name :=
        match stx with
        | `(attr| methodology $cls:ident) => some cls.getId
        | _ => none
      let some classifierName := classifierName?
        | throwError "@[methodology] requires a classifier name"
      let env ← getEnv
      let docstring? := (← findDocString? env declName).getD ""
      registerMethodology
        { classifierName := classifierName
        , theoremName    := declName
        , priority       := 100
        , description    := docstring? }
  }

-- ── The methodology-transport clause (scaffold) ─────────────────────────────
-- ALGEBRA_PLAN §4.3: when a structural Path connects classifierA to
-- classifierB and the methodology library has an entry for
-- classifierA, transport derives a candidate for classifierB.
--
-- Full implementation requires (a) declared structural Paths in the
-- codebase, (b) reification of methodology bodies as CTerms, (c)
-- application of `transp` at the methodology level.  REL2.6+ work.
--
-- The scaffold below returns `[]` so the surrounding tactic remains
-- well-typed; uses are guarded by feature flags.

/-- Derive new methodology candidates by transporting existing ones
    along declared structural Paths.

    Per ALGEBRA_PLAN §4.3:
    > Twenty starting methodologies + a hundred declared paths →
    > potentially thousands of derived methodologies, each formally
    > certified-by-construction.

    Implementation: for every methodology M registered against a
    classifier C₁, and every MetaPath C₁ ↦ C₂ in the registry,
    derive a candidate methodology against C₂ whose witness is M's
    body composed with the path witness.

    For the v0 dispatch tactic, the "composed witness" is just M's
    theorem name — `cubical_search` will try both M and the path
    witness directly via apply/exact.  A future Phase D'.6 will use
    actual Lean term composition to produce a single derived
    theorem.  See `Algebra/MetaPath.lean` for the path attribute. -/
def deriveByTransport (targetClassifier : Name) : CoreM (Array MethodologyEntry) := do
  let paths ← findPathsToTarget targetClassifier
  let mut out := #[]
  for path in paths do
    -- For every methodology M against the source classifier of this
    -- path, produce a derived candidate against the target classifier.
    let sourceMethodologies ← findMethodologies path.sourceClassifier
    for M in sourceMethodologies do
      out := out.push
        { classifierName := targetClassifier
        , theoremName    := M.theoremName  -- v0: try the source method directly
        , priority       := M.priority - 10  -- derived; lower priority
        , description    := s!"derived via metaPath {path.sourceClassifier} ↦ {path.targetClassifier} from {M.theoremName}" }
      -- Also add the path witness itself as a candidate; cubical_search
      -- can apply it to convert the goal to the source classifier form.
      out := out.push
        { classifierName := targetClassifier
        , theoremName    := path.witnessName
        , priority       := M.priority - 20
        , description    := s!"path witness {path.witnessName} for transport" }
  return out

-- ── The `cubical_search` tactic ─────────────────────────────────────────────

/-- The `cubical_search` autodiscovery tactic.

    Walks the methodology library and applies any registered theorem
    whose classifier matches the goal.  On match, the corresponding
    theorem is applied (via `exact`); on miss, falls back to
    methodology-transport candidates.

    Failure produces a structured report listing the attempted
    methodologies and their guards (per ALGEBRA_PLAN §4.4 "Failure
    as a feature"). -/
syntax (name := cubicalSearch) "cubical_search" : tactic

elab_rules : tactic
  | `(tactic| cubical_search) => do
      let goal ← getMainGoal
      let goalType ← goal.getType
      let methodologies ← getMethodologies
      -- Per ALGEBRA_PLAN §4.4 ("Failure as a feature") we track
      -- per-candidate failure reasons so a structured diagnostic
      -- can be emitted on full miss.
      let mut tried : Array (Name × String) := #[]
      -- Stage 1: direct methodology dispatch.
      for entry in methodologies do
        try
          let stx := mkIdent entry.theoremName
          evalTactic (← `(tactic| (first | exact $stx | apply $stx)))
          if (← getUnsolvedGoals).isEmpty then return
          tried := tried.push (entry.theoremName, "applied but left subgoals")
        catch e =>
          tried := tried.push (entry.theoremName, ← e.toMessageData.toString)
          continue
      -- Stage 2: methodology-transport candidates from every
      -- declared `@[metaPath]` (post-direct fallback).  See
      -- `deriveByTransport` for the construction.
      let allPaths ← getMetaPaths
      for path in allPaths do
        -- Try both the path witness and every methodology for its source.
        let sourceMethods ← findMethodologies path.sourceClassifier
        for M in sourceMethods do
          try
            let stx := mkIdent M.theoremName
            evalTactic (← `(tactic| (first | exact $stx | apply $stx)))
            if (← getUnsolvedGoals).isEmpty then return
          catch _ => continue
        try
          let stx := mkIdent path.witnessName
          evalTactic (← `(tactic| (first | exact $stx | apply $stx)))
          if (← getUnsolvedGoals).isEmpty then return
          tried := tried.push (path.witnessName,
            s!"path witness {path.sourceClassifier} ↦ {path.targetClassifier} applied but left subgoals")
        catch e =>
          tried := tried.push (path.witnessName, ← e.toMessageData.toString)
          continue
      -- Structured failure report — list every candidate considered
      -- and the reason it didn't fire.  Per ALGEBRA_PLAN §4.4 the
      -- final line is an actionable suggestion to register a new
      -- methodology.
      let lines := tried.map (fun (n, r) => s!"  ✗ {n} — {r}")
      let report := String.intercalate "\n" lines.toList
      let pathCount := allPaths.size
      let methCount := methodologies.size
      throwError s!"cubical_search: no methodology applies for goal\n  {← Meta.ppExpr goalType}\n\ncandidates considered ({methCount} direct + {pathCount} paths):\n{report}\n\nwould you like to register a new @[methodology] declaration?"

-- ── Diagnostics ─────────────────────────────────────────────────────────────

/-- Print the methodology registry — what's currently available to
    `cubical_search`. -/
def printMethodologies : CoreM Unit := do
  let entries ← getMethodologies
  IO.println s!"── Methodology registry ({entries.size}) ──"
  for entry in entries do
    let p := if entry.priority == 100 then "" else s!" (prio {entry.priority})"
    let d := if entry.description.isEmpty then "" else s!" — {entry.description}"
    IO.println s!"  {entry.classifierName} → {entry.theoremName}{p}{d}"

end CubicalTransport.Algebra