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

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
  }

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.

    Currently a no-op stub: returns the empty array.  The full
    implementation depends on the structural-Path declaration system
    (`@[metaPath]`), planned for REL2.6+.  Until then, only the
    *direct* methodology library participates in `cubical_search`. -/
def deriveByTransport (_classifier : Name) : CoreM (Array MethodologyEntry) := do
  -- TODO REL2.6: walk @[metaPath] declarations, transport methodologies
  return #[]

-- ── 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
      -- Try each methodology in registered order (Phase D' priority
      -- ordering is REL2.6 work; for now: insertion order).  We use
      -- a two-stage attempt: first `exact` (no metavars), then
      -- `apply` (allow Lean to fill args from the goal).
      let mut tried := #[]
      for entry in methodologies do
        tried := tried.push entry.theoremName
        try
          let stx := mkIdent entry.theoremName
          evalTactic (← `(tactic| (first | exact $stx | apply $stx)))
          if (← getUnsolvedGoals).isEmpty then return
        catch _ => continue
      -- Fall back to methodology-transport candidates.
      let derived ← deriveByTransport .anonymous
      for entry in derived do
        tried := tried.push entry.theoremName
        try
          let stx := mkIdent entry.theoremName
          evalTactic (← `(tactic| (first | exact $stx | apply $stx)))
          if (← getUnsolvedGoals).isEmpty then return
        catch _ => continue
      -- Structured failure report.
      let triedStr := String.intercalate ", " (tried.toList.map (·.toString))
      throwError s!"cubical_search: no methodology applies for goal\n  {← Meta.ppExpr goalType}\ntried: {triedStr}\n\nconsider registering 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