b9ca1d8875
Some checks are pending
Lean Action CI / build (push) Waiting to run
Per THEORY.md §3.1: cubical-native modal type formers as the engine
support layer for the cohesive modality triple (ʃ ⊣ ♭ ⊣ ♯).
CType (3 level-preserving formers):
· CType.flat / .sharp / .shape : {ℓ} → CType ℓ → CType ℓ
CTerm (6 — three intros + three elims, modelled on .glueIn / .unglue):
· CTerm.flatIntro / .sharpIntro / .shapeIntro : CTerm → CTerm
· CTerm.flatElim / .sharpElim / .shapeElim : CTerm → CTerm → CTerm
Cascade: Syntax (constructors + SkeletalCType + skeleton + substDim);
DecEq (beq arms); Subst (substDim / substDimExpr + 6 rfl theorems);
DimLine (cascade through 8 dim-absent / dim-substitution lemma families);
Value (3 vIntro CVal + 3 nElim CNeu); Eval (β-reduction axioms +
stuck-neutral propagation, "marker neutral" idiom from vFst/vSnd
preserved); Readback (3 vIntro + 3 nElim arms with axioms); Typing
(6 HasType cases — bare recursion-principle shape; modal cohesion
dependent-motive form deferred to Phase 3); Reflect (3 reflectCType + 6
reflectCTerm + 3 reifyCType with level-coherence discharge + 6
reifyCTerm); Question (6 modal arms + 6 IsModalLine classifier
predicates with their Decidable instances); FFITest (cval/cterm
summary arms).
No Rust changes (Phase 2). No Modal.lean module (Phase 3). No
Crisp / CContext.crispVar / cohesive_triple theorems (Phase 3).
Build: lake build (48 jobs) + lake build CubicalTransport (42 jobs) PASS.
+664 lines across 11 files, 0 removed, 0 new sorries.
Honest deferrals documented:
· Modal type-formers do not yet reduce under transport/comp; the
match A blocks have wildcards so transp i (flat A) φ t produces a
stuck ntransp neutral (correct under current axiom set; cohesion-
driven reductions land in Phase 3).
· HasType.flatElim et al carry the bare recursion-principle shape;
the cohesive-HoTT-correct dependent-motive form requires the modal
predicate lattice from Phase 3.
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
364 lines
15 KiB
Text
364 lines
15 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 ────────────────────────────────────────────────────────────
|
||
|
||
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 (.nflatElim _ _) => "vneu nflatElim"
|
||
| .vneu (.nsharpElim _ _) => "vneu nsharpElim"
|
||
| .vneu (.nshapeElim _ _) => "vneu nshapeElim"
|
||
| .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 ..."
|
||
| .vFlatIntro _ => "vFlatIntro ..."
|
||
| .vSharpIntro _ => "vSharpIntro ..."
|
||
| .vShapeIntro _ => "vShapeIntro ..."
|
||
|
||
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 ..."
|
||
| .flatIntro _ => "flatIntro ..."
|
||
| .sharpIntro _ => "sharpIntro ..."
|
||
| .shapeIntro _ => "shapeIntro ..."
|
||
| .flatElim _ _ => "flatElim ..."
|
||
| .sharpElim _ _ => "sharpElim ..."
|
||
| .shapeElim _ _ => "shapeElim ..."
|
||
| _ => "<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
|