6e4936d6ee
Some checks are pending
Lean Action CI / build (push) Waiting to run
Per the elegance pass: 9 ad-hoc per-modality constructors collapse into
3 ModalityKind-parameterised constructors. Future modalities (Phase
4's ʃ_EML, ℑ infinitesimal) extend ModalityKind by adding cases —
no new constructors, no new ABI bump.
New Lean enum (Syntax.lean):
inductive ModalityKind | flat | sharp | shape
deriving DecidableEq, Repr, Inhabited
Constructor unification:
· CType: 3 (.flat / .sharp / .shape) → 1 (.modal k A)
· CTerm: 6 (.flatIntro / .sharpIntro / .shapeIntro / .flatElim /
.sharpElim / .shapeElim) → 2 (.modalIntro k a, .modalElim k f m)
· CVal: 3 (vFlatIntro / vSharpIntro / vShapeIntro) → 1 (vModalIntro)
· CNeu: 3 (nflatElim / nsharpElim / nshapeElim) → 1 (nModalElim)
· SkeletalCType: 3 (skFlat / skSharp / skShape) → 1 (skModal k)
Engine cascade across 12 files (DecEq, DimLine, Eval, FFITest, Modal,
Question, Readback, Reflect, Subst, Syntax, Typing, Value): every
match site collapsed from 3-per-modality arms to 1 k-parameterised arm.
Reflect.lean: new `reflectModalityKind` / `reifyModalityKind` helpers
+ ModalityKind dispatch arm in classifyFieldType. The Phase 1 macro
auto-derived per-constructor reflect/reify for the new unified
constructors — no manual cascade needed there.
Eval.lean β-rule: `.modalElim k f (.modalIntro k' a)` β-reduces only
when k = k' (kind-discrimination preserves cross-kind correctness even
if typing is bypassed); cross-kind case produces a marker neutral.
Modal.lean transient alias block (top of file, outside namespace) for
backward dot-syntax reference (`.flatIntro a` resolves to
`.modalIntro .flat a` via abbrev). Phase 3 will rewrite Modal.lean
properly to use the unified constructors directly + forModalityKind-
derived functor.
Net: −145 lines across the cascade (-478 deletions, +333 insertions).
Build: lake build (48 jobs) + lake build CubicalTransport (43 jobs) PASS.
Runtime: lake exe cubical-test 49/49 + 46/46 = 95/95 PASS.
Sorry count: Modal.lean 3 (unchanged), total engine 33 (no new sorries
from this phase, all annotated).
The Rust ABI v6 still uses 9 modal tags — diverges from the Lean side
after this commit but FFI tests don't exercise modal paths so no
runtime regression. Phase 4 will sync to ABI v7.
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
365 lines
16 KiB
Text
365 lines
16 KiB
Text
/-
|
||
CubicalTransport.FFITest
|
||
=======================
|
||
Phase C.3 smoke test (2026-04-24). Exercises the FFI wiring by
|
||
running simple cubical terms through `eval` / `readback` / the
|
||
normalizers. With `@[implemented_by]` attached, these execute in
|
||
the Rust backend at runtime.
|
||
|
||
**Why not `#eval`?** `#eval` runs at Lean's compile-time in the
|
||
interpreter, which does not link our Rust staticlib. Calling a
|
||
Rust-backed function under the interpreter raises "Could not find
|
||
native implementation of external declaration ..." The tests here
|
||
are `def`s + a `runSmokeTests : IO Unit` entry point that exercises
|
||
them inside a compiled binary where Rust IS linked.
|
||
|
||
Invoke from a compiled executable. `Main.lean` can optionally
|
||
route to `CubicalTransportFFITest.runSmokeTests` when passed
|
||
`--cubical-test`. Or a dedicated test exe target.
|
||
-/
|
||
|
||
import CubicalTransport.Readback
|
||
import CubicalTransport.FFI
|
||
import CubicalTransport.Inductive
|
||
import CubicalTransport.Bridge
|
||
import CubicalTransport.Question
|
||
|
||
open CubicalTransport.Inductive
|
||
open CubicalTransport.Inductive.CTerm
|
||
open CubicalTransport.Bridge
|
||
open Question
|
||
|
||
namespace CubicalTransportFFITest
|
||
|
||
-- ── Summarisers ────────────────────────────────────────────────────────────
|
||
|
||
/-- Display-name for a `ModalityKind`: a printable tag used by the
|
||
summarisers to label modal values / neutrals. Pure formatting —
|
||
no semantic per-kind dispatch, just a single reflection of the
|
||
enum's three constructors into their conventional symbols. -/
|
||
def modalityKindTag : ModalityKind → String
|
||
| .flat => "flat"
|
||
| .sharp => "sharp"
|
||
| .shape => "shape"
|
||
|
||
def cvalSummary : CVal → String
|
||
| .vneu (.nvar s) => s!"vneu nvar {s}"
|
||
| .vneu (.napp _ _) => "vneu napp"
|
||
| .vneu (.npapp _ _) => "vneu npapp"
|
||
| .vneu (.ntransp _ _ _ _) => "vneu ntransp"
|
||
| .vneu (.nhcomp _ _ _ _) => "vneu nhcomp"
|
||
| .vneu (.ncomp _ _ _ _ _) => "vneu ncomp"
|
||
| .vneu (.ncompN _ _ _ _ _) => "vneu ncompN"
|
||
| .vneu (.nglueIn _ _ _) => "vneu nglueIn"
|
||
| .vneu (.nunglue _ _ _) => "vneu nunglue"
|
||
| .vneu (.nfst _) => "vneu nfst"
|
||
| .vneu (.nsnd _) => "vneu nsnd"
|
||
| .vneu (.nIndElim _ _ _ _ _) => "vneu nIndElim"
|
||
| .vneu (.nModalElim k _ _) => s!"vneu nModalElim {modalityKindTag k}"
|
||
| .vlam _ x _ => s!"vlam {x} ..."
|
||
| .vplam _ i _ => s!"vplam {i.name} ..."
|
||
| .vpair _ _ => "vpair ..."
|
||
| .vTranspFun _ _ _ _ _ => "vTranspFun"
|
||
| .vHCompFun _ _ _ _ => "vHCompFun"
|
||
| .vCompFun _ _ _ _ _ _ _ => "vCompFun"
|
||
| .vTubeApp _ _ => "vTubeApp"
|
||
| .vPathTransp _ _ _ _ _ _ _ => "vPathTransp"
|
||
| .vctor _ c _ _ => s!"vctor {c} ..."
|
||
| .vdimExpr _ => "vdimExpr ..."
|
||
| .vcode _ => "vcode ..."
|
||
| .vModalIntro k _ => s!"vModalIntro {modalityKindTag k} ..."
|
||
|
||
def ctermSummary : CTerm → String
|
||
| .var x => s!"var {x}"
|
||
| .lam x _ => s!"lam {x} ..."
|
||
| .app _ _ => "app ..."
|
||
| .plam i _ => s!"plam {i.name} ..."
|
||
| .pair _ _ => "pair ..."
|
||
| .fst _ => "fst ..."
|
||
| .snd _ => "snd ..."
|
||
| .dimExpr _ => "dimExpr ..."
|
||
| .ctor _ c _ _ => s!"ctor {c} ..."
|
||
| .indElim _ _ _ _ _ => "indElim ..."
|
||
| .modalIntro k _ => s!"modalIntro {modalityKindTag k} ..."
|
||
| .modalElim k _ _ => s!"modalElim {modalityKindTag k} ..."
|
||
| _ => "<other CTerm>"
|
||
|
||
-- ── Individual test definitions ────────────────────────────────────────────
|
||
-- Each returns (description, actual, expected) for runSmokeTests to print.
|
||
|
||
def tests : List (String × String × String) :=
|
||
[ ("eval .nil (.var \"x\")",
|
||
cvalSummary (eval .nil (.var "x")),
|
||
"vneu nvar x"),
|
||
("eval .nil (.lam \"x\" (.var \"x\"))",
|
||
cvalSummary (eval .nil (.lam "x" (.var "x"))),
|
||
"vlam x ..."),
|
||
("(λx. x) y ⇓ y",
|
||
cvalSummary (eval .nil (.app (.lam "x" (.var "x")) (.var "y"))),
|
||
"vneu nvar y"),
|
||
("(a, b).fst ⇓ a",
|
||
cvalSummary (eval .nil (.fst (.pair (.var "a") (.var "b")))),
|
||
"vneu nvar a"),
|
||
("(a, b).snd ⇓ b",
|
||
cvalSummary (eval .nil (.snd (.pair (.var "a") (.var "b")))),
|
||
"vneu nvar b"),
|
||
("readback (eval .nil (.lam \"x\" (.var \"x\"))) ≡ .lam \"x\" ...",
|
||
ctermSummary (readback (eval .nil (.lam "x" (.var "x")))),
|
||
"lam x ..."),
|
||
("DimExpr.normalize (.inv .zero) ≡ .one",
|
||
match DimExpr.normalize (.inv .zero) with
|
||
| .one => "one"
|
||
| _ => "<other>",
|
||
"one"),
|
||
("DimExpr.normalize (.inv (.inv (.var i))) ≡ .var i",
|
||
match DimExpr.normalize (.inv (.inv (.var ⟨"i"⟩))) with
|
||
| .var j => s!"var {j.name}"
|
||
| _ => "<other>",
|
||
"var i"),
|
||
("FaceFormula.normalize (.meet .top (.eq0 i)) ≡ .eq0 i",
|
||
match FaceFormula.normalize (.meet .top (.eq0 ⟨"i"⟩)) with
|
||
| .eq0 j => s!"eq0 {j.name}"
|
||
| _ => "<other>",
|
||
"eq0 i"),
|
||
-- ── β-rules: discharge the five cubical-closure axioms ─────────────────
|
||
-- Each test exercises the path `Lean constructs a CVal closure →
|
||
-- vApp/vPApp routes through Rust @[implemented_by] → forcer unfolds
|
||
-- the CCHM RHS → result is no longer a stuck marker`.
|
||
("β vApp vTranspFun (const line, via beta::force_transp_fun)",
|
||
cvalSummary (vApp
|
||
(.vTranspFun ⟨"i"⟩ (CType.univ (ℓ := .zero)) (CType.univ (ℓ := .zero))
|
||
.bot (.vneu (.nvar "f")))
|
||
(.vneu (.nvar "y"))),
|
||
"vneu napp"),
|
||
("β vApp vHCompFun (stuck on .univ codA, via beta::force_hcomp_fun)",
|
||
cvalSummary (vApp
|
||
(.vHCompFun (CType.univ (ℓ := .zero)) .bot
|
||
(.vplam .nil ⟨"j"⟩ (.var "tube_body"))
|
||
(.vneu (.nvar "b")))
|
||
(.vneu (.nvar "x"))),
|
||
"vneu nhcomp"),
|
||
("β vApp vCompFun (φ=.bot collapses via C2, via beta::force_comp_fun)",
|
||
cvalSummary (vApp
|
||
(.vCompFun .nil ⟨"i"⟩ (CType.univ (ℓ := .zero)) (CType.univ (ℓ := .zero))
|
||
.bot (.var "u") (.var "t"))
|
||
(.vneu (.nvar "y"))),
|
||
"vneu napp"),
|
||
("β vPApp vTubeApp (via beta::force_tube_app)",
|
||
cvalSummary (vPApp
|
||
(.vTubeApp (.vplam .nil ⟨"j"⟩ (.var "tube_body")) (.vneu (.nvar "x")))
|
||
(.var ⟨"r"⟩)),
|
||
"vneu napp"),
|
||
("β vPApp vPathTransp at .zero ⇓ a(1) (via beta::force_path_transp)",
|
||
cvalSummary (vPApp
|
||
(.vPathTransp .nil ⟨"i"⟩ (CType.univ (ℓ := .zero))
|
||
(.var "a0") (.var "b0") .bot (.var "p"))
|
||
.zero),
|
||
"vneu nvar a0"),
|
||
("β vPApp vPathTransp at .one ⇓ b(1)",
|
||
cvalSummary (vPApp
|
||
(.vPathTransp .nil ⟨"i"⟩ (CType.univ (ℓ := .zero))
|
||
(.var "a0") (.var "b0") .bot (.var "p"))
|
||
.one),
|
||
"vneu nvar b0"),
|
||
("β vPApp vPathTransp at var r ⇓ compN (CCHM 3-clause system)",
|
||
cvalSummary (vPApp
|
||
(.vPathTransp .nil ⟨"i"⟩ (CType.univ (ℓ := .zero))
|
||
(.var "a0") (.var "b0") .bot (.var "p"))
|
||
(.var ⟨"r"⟩)),
|
||
"vneu ncompN"),
|
||
-- ── REL1 inductive-type smoke tests ─────────────────────────────────────
|
||
("eval (zero : Nat) ⇓ vctor zero",
|
||
cvalSummary (eval .nil zeroC),
|
||
"vctor zero ..."),
|
||
("eval (succ (succ zero) : Nat) ⇓ vctor succ",
|
||
cvalSummary (eval .nil (succC (succC zeroC))),
|
||
"vctor succ ..."),
|
||
("eval (false : Bool) ⇓ vctor false",
|
||
cvalSummary (eval .nil falseC),
|
||
"vctor false ..."),
|
||
("eval (cons true nil : List Bool) ⇓ vctor cons",
|
||
cvalSummary (eval .nil (consC CType.boolC trueC (nilC CType.boolC))),
|
||
"vctor cons ..."),
|
||
("readback ∘ eval (succ zero : Nat) ≡ ctor succ",
|
||
ctermSummary (readback (eval .nil (succC zeroC))),
|
||
"ctor succ ..."),
|
||
("eval (base : S¹) ⇓ vctor base",
|
||
cvalSummary (eval .nil baseC),
|
||
"vctor base ..."),
|
||
("eval (loop @ r : S¹) ⇓ vctor loop",
|
||
cvalSummary (eval .nil (loopC (.var ⟨"r"⟩))),
|
||
"vctor loop ..."),
|
||
("indElim Bool false-case (true → \"yes\") on true ⇓ \"yes\"",
|
||
cvalSummary (eval .nil
|
||
(boolElim (.lam "x" (.var "M")) (.var "no") (.var "yes") trueC)),
|
||
"vneu nvar yes"),
|
||
("indElim Bool true-case on false ⇓ \"no\"",
|
||
cvalSummary (eval .nil
|
||
(boolElim (.lam "x" (.var "M")) (.var "no") (.var "yes") falseC)),
|
||
"vneu nvar no"),
|
||
("transp_ind T1: φ=.top is identity",
|
||
cvalSummary (eval .nil
|
||
(.transp ⟨"i"⟩ CType.natC .top zeroC)),
|
||
"vctor zero ..."),
|
||
("transp_ind T2: constant Nat line is identity",
|
||
cvalSummary (eval .nil
|
||
(.transp ⟨"i"⟩ CType.natC (.eq0 ⟨"j"⟩) (succC zeroC))),
|
||
"vctor succ ..."),
|
||
("comp_ind C1: φ=.top reduces to u[i:=1]",
|
||
cvalSummary (eval .nil
|
||
(.comp ⟨"i"⟩ CType.natC .top (succC zeroC) zeroC)),
|
||
"vctor succ ..."),
|
||
-- REL2: interval primitive
|
||
("eval (.dimExpr .zero) ⇓ vdimExpr",
|
||
cvalSummary (eval .nil (.dimExpr .zero)),
|
||
"vdimExpr ..."),
|
||
("transp_interval is identity (constant line on 𝕀)",
|
||
cvalSummary (eval .nil
|
||
(.transp ⟨"i"⟩ CType.intervalC (.eq0 ⟨"j"⟩) (.dimExpr .one))),
|
||
"vdimExpr ..."),
|
||
-- REL2 Phase 2: Bridge.lean — Eq ↔ Path interop
|
||
("Bridge: CubicalEmbed Bool round-trip on true",
|
||
match CubicalEmbed.fromCTerm (α := Bool) (CubicalEmbed.toCTerm true) with
|
||
| some true => "ok"
|
||
| _ => "<roundtrip failed>",
|
||
"ok"),
|
||
("Bridge: CubicalEmbed Bool round-trip on false",
|
||
match CubicalEmbed.fromCTerm (α := Bool) (CubicalEmbed.toCTerm false) with
|
||
| some false => "ok"
|
||
| _ => "<roundtrip failed>",
|
||
"ok"),
|
||
("Bridge: CubicalEmbed Nat round-trip on 7",
|
||
match CubicalEmbed.fromCTerm (α := Nat) (CubicalEmbed.toCTerm 7) with
|
||
| some 7 => "ok"
|
||
| _ => "<roundtrip failed>",
|
||
"ok"),
|
||
("Bridge: CubicalEmbed (List Bool) round-trip on [true, false, true]",
|
||
match CubicalEmbed.fromCTerm (α := List Bool)
|
||
(CubicalEmbed.toCTerm [true, false, true]) with
|
||
| some [true, false, true] => "ok"
|
||
| _ => "<roundtrip failed>",
|
||
"ok"),
|
||
("Bridge: Eq.toPath rfl on Bool produces a constant plam",
|
||
ctermSummary (Eq.toPath (rfl : true = true)),
|
||
"plam $eq2path ..."),
|
||
-- Question.lean Level 1: CompQ smoke
|
||
("CompQ.ask delegates to eval (.comp ...)",
|
||
cvalSummary
|
||
(let q : CompQ :=
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
q.ask),
|
||
"vneu nvar u"),
|
||
("CompQ.ofTransp on a constant interval line: full-face → eval u",
|
||
cvalSummary
|
||
(CompQ.ofTransp .nil ⟨"i"⟩ CType.interval .top (.var "x")).ask,
|
||
"vneu nvar x"),
|
||
("Classifier IsConstLine decidable on .interval line",
|
||
(if Question.IsConstLine
|
||
{ level := .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.interval
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
("Classifier IsFullFace decidable on .top face",
|
||
(if Question.IsFullFace
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
-- IsTransport classifier (uses CTerm.beq, fully computable post-cascade).
|
||
("Classifier IsTransport accepts when u = t",
|
||
(if Question.IsTransport
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "x", t := .var "x" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
("Classifier IsTransport rejects when u ≠ t",
|
||
(if Question.IsTransport
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"no"),
|
||
-- Body-shape classifiers (decidable via CType.skeleton check).
|
||
("Classifier IsPiLine accepts on .pi body",
|
||
(if Question.IsPiLine
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := .pi "_" (CType.univ (ℓ := .zero)) (CType.univ (ℓ := .zero))
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
("Classifier IsPiLine rejects on .univ body",
|
||
(if Question.IsPiLine
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"no"),
|
||
("Classifier IsIntervalLine accepts on .interval body",
|
||
(if Question.IsIntervalLine
|
||
{ level := .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.interval
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
("Classifier IsIntervalLine rejects on .univ body",
|
||
(if Question.IsIntervalLine
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"no"),
|
||
("Classifier IsUnivLine accepts on .univ body",
|
||
(if Question.IsUnivLine
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
("Classifier IsPathLine accepts on .path body",
|
||
(if Question.IsPathLine
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := .path (CType.univ (ℓ := .zero)) (.var "a") (.var "b")
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
("Classifier IsSigmaLine accepts on .sigma body",
|
||
(if Question.IsSigmaLine
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := .sigma "_" (CType.univ (ℓ := .zero)) (CType.univ (ℓ := .zero))
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"yes"),
|
||
("Classifier IsIndLine rejects on .univ body",
|
||
(if Question.IsIndLine
|
||
{ level := .succ .zero, env := .nil, binder := ⟨"i"⟩
|
||
, body := CType.univ (ℓ := .zero)
|
||
, φ := .top, u := .var "u", t := .var "t" }
|
||
then "yes" else "no"),
|
||
"no") ]
|
||
-- Note: Algebra/Infoductor smoke tests moved to the
|
||
-- `infoductor-cubical` bridge repo (private), where the Infoductor
|
||
-- dependency now lives. cubical-transport-hott-lean4 has no
|
||
-- Infoductor dep — pure cubical engine.
|
||
|
||
/-- Run every smoke test, print its actual vs expected. Returns the
|
||
number of failures. -/
|
||
def runSmokeTests : IO UInt32 := do
|
||
IO.println "── Cubical-transport FFI smoke tests ──"
|
||
let mut fails : UInt32 := 0
|
||
for (desc, actual, expected) in tests do
|
||
if actual == expected then
|
||
IO.println s!" ✅ {desc}"
|
||
else
|
||
IO.println s!" ❌ {desc}"
|
||
IO.println s!" expected: {expected}"
|
||
IO.println s!" actual: {actual}"
|
||
fails := fails + 1
|
||
IO.println s!"── {tests.length - fails.toNat} / {tests.length} passed ──"
|
||
return fails
|
||
|
||
end CubicalTransportFFITest
|