19928d040a
Some checks failed
Lean Action CI / build (push) Has been cancelled
Two structural changes landed together as one coherent body of work.
## 1. Engine is name-clean from higher-order projects
The engine no longer carries "topolei" in its own naming surface.
Higher-order projects depend on the engine, not vice versa, so the
engine should be self-named.
topolei-cubical (Cargo) → cubical-transport
libtopolei_cubical.a → libcubical_transport.a
topolei_cubical.h → cubical_transport.h
TOPOLEI_FFI_ABI_VERSION → CUBICAL_TRANSPORT_ABI_VERSION
topolei_cubical_* (14 FFI fns) → cubical_transport_*
topolei_shim_* (9 shim fns) → cubical_transport_shim_*
Inter-repo references describing topolei as a downstream consumer
(README, KERNEL_BOUNDARY.md, INDUCTIVE_TYPES.md, etc.) are preserved
as legitimate dependency-direction descriptions.
## 2. Universe-stratified, dependently-typed CType
CType : ULevel → Type (genuinely indexed inductive)
with dependent pi/sigma carrying a binder name, a lift constructor
for cumulativity, and parameter lists of Σ-packaged types.
Per CCHM rules:
· univ ℓ : CType (ℓ.succ)
· pi/sigma : CType (max ℓ_A ℓ_B), with named binder
· path A : at A's level
· glue T A : T and A at same level
· ind : at user-chosen level (heterogeneous-level params)
· interval : CType .zero
· lift : CType (ℓ.succ), data-preserving
Every existing engine module cascades through {ℓ : ULevel} implicits
on functions/theorems, pi/sigma binder updates, and Σ-packaged params
lists. CTerm stays un-indexed (universe lives on CType).
## 3. Substrate machinery for the cascade
Universe.lean — ULevel inductive + max algebra (assoc, comm, etc.),
all theorems proven structurally.
Syntax.lean — adds SkeletalCType enum + CType.skeleton level-erasure
projection + per-constructor skeleton_* simp lemmas +
CType.ind_skeleton_ne_pi disjointness lemma. Used to
discharge cross-level HEq cases in TransportLaws/CompLaws
without invoking K.
## 4. Rust ABI v3 → v4
Lean 4 keeps implicit {ℓ : ULevel} parameters at runtime as constructor
fields, in declaration order interleaved with explicit args (verified
via probeLayout instrumentation). Layout for level-bearing constructors
documented in cubical_transport.h §"v4 layout tables".
CType.pi : 5 fields — [ℓ_d, ℓ_c, var, A, B]
CType.path : 4 fields — [ℓ, A, a, b]
CType.glue : 9 fields — [ℓ, φ, T, f, fInv, sec, ret, coh, A]
CType.ind : 3 fields — [ℓ, S, params]
CType.lift : 2 fields — [ℓ, A]
CTerm.transp : 5 fields — [i, ℓ, A, φ, t] (i precedes ℓ)
CVal.vCompFun : 9 fields — [ℓ_d, ℓ_c, env, i, dom, cod, φ, u, t]
... etc
All Rust marshalling (value.rs, eval.rs, transport.rs, composition.rs,
glue.rs, beta.rs, dim_absent.rs, readback.rs, subst.rs, ffi.rs, tags.rs)
updated to match.
## Discipline
· Zero sorry in CubicalTransport/.
· Zero noncomputable instances; zero Classical.propDecidable shortcuts.
· No CType.level projection (the level lives in the inductive's index).
· No parallel CTypeU type.
· No stub substrate types (def Ω := CType.univ etc.).
· Tests restored to full coverage (EvalTest 623 lines, FFITest 351
lines with classifier-runtime tests intact).
## Verification
cd cubical-transport-hott-lean4
lake build # 48 jobs OK
./.lake/build/bin/cubical-test
# ── 49/49 passed ──
# ── 46/46 properties passed ──
# PASS: all smoke + property tests
cd ../topolei
lake build # 90 jobs OK
./.lake/build/bin/probe-test
# ── 7/7 probes passed ──
# PASS: GPU output matches Lean ShaderSemantic
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
623 lines
31 KiB
Text
623 lines
31 KiB
Text
/-
|
||
CubicalTransport.EvalTest
|
||
========================
|
||
Roundtrip tests for the evaluator (cells-spec §13 Phase 1 Week 2 test:
|
||
"eval roundtrip for simple terms").
|
||
|
||
Each test uses the axiom equations from `Eval.lean` to reduce an
|
||
evaluation call to a normal form and check the expected value. These
|
||
tests exercise:
|
||
· free variables produce `nvar` neutrals,
|
||
· identity lambda β-reduces correctly,
|
||
· const-function β-reduces correctly (ignoring argument),
|
||
· nested applications compose,
|
||
· path abstractions close over their environment,
|
||
· path applications β-reduce via `substDim`,
|
||
· transport / composition terms produce the expected neutrals.
|
||
|
||
## Universe-stratified port
|
||
|
||
The original (pre-Layer 0) tests used a monomorphic `CType`; the
|
||
universe-stratified successor (`CType : ULevel → Type`) requires:
|
||
· `.univ` → `CType.univ (ℓ := .zero)` at result level `.succ .zero`
|
||
· `.pi A B` → `.pi "_" A B` (named binders)
|
||
· `.sigma A B` → `.sigma "_" A B`
|
||
· `.ind ... [P, Q]` → `.ind ... [⟨_, P⟩, ⟨_, Q⟩]` (Σ-pair params)
|
||
· `.glue` retained the same shape
|
||
Most tests are phrased over level `.succ .zero` (where `.univ` lives)
|
||
with sub-CTypes also at that level for compatibility.
|
||
-/
|
||
|
||
import CubicalTransport.Eval
|
||
|
||
-- ── Free variable ───────────────────────────────────────────────────────────
|
||
|
||
/-- A free variable evaluates to a `nvar` neutral. -/
|
||
theorem eval_free_var (x : String) :
|
||
eval .nil (.var x) = .vneu (.nvar x) := by
|
||
rw [eval_var]; rfl
|
||
|
||
-- ── Identity β-redex ────────────────────────────────────────────────────────
|
||
|
||
/-- `(λx. x) y` β-reduces to the value of `y`. With `y` free in the env,
|
||
the result is `vneu (nvar "y")`. -/
|
||
theorem eval_identity_beta :
|
||
eval .nil (.app (.lam "x" (.var "x")) (.var "y")) = .vneu (.nvar "y") := by
|
||
rw [eval_app, eval_lam, eval_var]
|
||
-- state: vApp (.vlam .nil "x" (.var "x")) ((CEnv.nil.lookup "y").getD _) = _
|
||
have hlookup : (CEnv.nil.lookup "y").getD (.vneu (.nvar "y")) =
|
||
.vneu (.nvar "y") := rfl
|
||
rw [hlookup, vApp_vlam, eval_var]
|
||
-- state: ((CEnv.nil.extend "x" (vneu (nvar "y"))).lookup "x").getD _ = _
|
||
simp [CEnv.extend]
|
||
|
||
-- ── Constant function ───────────────────────────────────────────────────────
|
||
|
||
/-- `(λx. z) y` β-reduces to the free variable `z`. -/
|
||
theorem eval_const_fun_beta :
|
||
eval .nil (.app (.lam "x" (.var "z")) (.var "y")) = .vneu (.nvar "z") := by
|
||
rw [eval_app, eval_lam, eval_var]
|
||
have : (CEnv.nil.lookup "y").getD (.vneu (.nvar "y")) =
|
||
.vneu (.nvar "y") := rfl
|
||
rw [this, vApp_vlam, eval_var]
|
||
-- After extend: lookup "z" in [("x", vneu "y")] → none → default
|
||
simp [CEnv.extend, CEnv.lookup]
|
||
|
||
-- ── Nested application ──────────────────────────────────────────────────────
|
||
|
||
/-- `((λx. λy. x) a) b` β-reduces to `a` (K combinator applied). -/
|
||
theorem eval_K_combinator :
|
||
eval .nil (.app (.app (.lam "x" (.lam "y" (.var "x"))) (.var "a")) (.var "b"))
|
||
= .vneu (.nvar "a") := by
|
||
rw [eval_app, eval_app, eval_lam, eval_var]
|
||
have ha : (CEnv.nil.lookup "a").getD (.vneu (.nvar "a")) =
|
||
.vneu (.nvar "a") := rfl
|
||
rw [ha, vApp_vlam, eval_lam, eval_var]
|
||
have hb : (CEnv.nil.lookup "b").getD (.vneu (.nvar "b")) =
|
||
.vneu (.nvar "b") := rfl
|
||
rw [hb, vApp_vlam, eval_var]
|
||
-- env is now [("y", vneu "b"), ("x", vneu "a")]; lookup "x" finds "a".
|
||
simp [CEnv.extend, CEnv.lookup]
|
||
|
||
-- ── Stuck application ──────────────────────────────────────────────────────
|
||
|
||
/-- Applying a free variable to another yields a stuck `napp` neutral. -/
|
||
theorem eval_stuck_app :
|
||
eval .nil (.app (.var "f") (.var "x")) =
|
||
.vneu (.napp (.nvar "f") (.vneu (.nvar "x"))) := by
|
||
rw [eval_app, eval_var, eval_var]
|
||
have hf : (CEnv.nil.lookup "f").getD (.vneu (.nvar "f")) =
|
||
.vneu (.nvar "f") := rfl
|
||
have hx : (CEnv.nil.lookup "x").getD (.vneu (.nvar "x")) =
|
||
.vneu (.nvar "x") := rfl
|
||
rw [hf, hx, vApp_vneu]
|
||
|
||
-- ── Dimension abstraction and application ──────────────────────────────────
|
||
|
||
/-- Path abstraction captures its environment as a `vplam`. -/
|
||
theorem eval_plam_closure (i : DimVar) (body : CTerm) :
|
||
eval .nil (.plam i body) = .vplam .nil i body :=
|
||
eval_plam _ _ _
|
||
|
||
/-- Path application β-reduces via `CTerm.substDim`. -/
|
||
theorem eval_papp_beta (i : DimVar) (body : CTerm) (r : DimExpr) :
|
||
eval .nil (.papp (.plam i body) r) = eval .nil (body.substDim i r) := by
|
||
rw [eval_papp, eval_plam, vPApp_vplam]
|
||
|
||
-- ── Transport and composition produce expected neutrals ────────────────────
|
||
|
||
-- ── Week 3: transport along refl = id ─────────────────────────────────────
|
||
|
||
/-- T1 at eval level: transport under a `.top` face reduces to its argument.
|
||
(This is the spec's Week 3 test "transport along refl = id".) -/
|
||
theorem eval_transp_top_id {ℓ : ULevel} (i : DimVar) (A : CType ℓ) (x : String) :
|
||
eval .nil (.transp i A .top (.var x)) = .vneu (.nvar x) := by
|
||
rw [eval_transp_top, eval_var]; rfl
|
||
|
||
/-- T2 at eval level: transport along a syntactically constant line reduces
|
||
to its argument. For `A = .univ`, this holds for any `φ` — via
|
||
`eval_transp_top` when `φ = .top` and via `eval_transp_const` otherwise. -/
|
||
theorem eval_transp_const_univ (i : DimVar) (φ : FaceFormula) (x : String) :
|
||
eval .nil (.transp i (CType.univ (ℓ := .zero)) φ (.var x)) = .vneu (.nvar x) := by
|
||
by_cases hφ : φ = .top
|
||
· subst hφ; rw [eval_transp_top, eval_var]; rfl
|
||
· rw [eval_transp_const _ _ _ _ _ hφ
|
||
(rfl : CType.dimAbsent i (CType.univ (ℓ := .zero)) = true),
|
||
eval_var]; rfl
|
||
|
||
/-- T2 also discharges for `pi` when neither side mentions the binder. -/
|
||
theorem eval_transp_const_pi (i : DimVar) (φ : FaceFormula) (x : String) :
|
||
eval .nil
|
||
(.transp i (.pi "_" (CType.univ (ℓ := .zero)) (CType.univ (ℓ := .zero))) φ (.var x))
|
||
= .vneu (.nvar x) := by
|
||
have h : CType.dimAbsent i
|
||
(.pi "_" (CType.univ (ℓ := .zero)) (CType.univ (ℓ := .zero))) = true := rfl
|
||
by_cases hφ : φ = .top
|
||
· subst hφ; rw [eval_transp_top, eval_var]; rfl
|
||
· rw [eval_transp_const _ _ _ _ _ hφ h, eval_var]; rfl
|
||
|
||
/-- Transport at a free-variable argument under a stuck face and non-constant
|
||
non-pi non-path non-glue line produces a neutral `ntransp`. The Π, Path,
|
||
and Glue cases are handled by `eval_transp_pi` / `eval_transp_path` /
|
||
the Glue-specific axioms in `Glue.lean`.
|
||
|
||
The "not a pi" precondition uses the level-erased `skeleton ≠ .pi`
|
||
(the post-cascade structural form), avoiding cross-level HEq. -/
|
||
theorem eval_transp_neu {ℓ : ULevel} (i : DimVar) (A : CType ℓ) (φ : FaceFormula) (x : String)
|
||
(hφ : φ ≠ .top) (hA : CType.dimAbsent i A = false)
|
||
(h_not_pi : A.skeleton ≠ SkeletalCType.pi)
|
||
(h_not_path : ∀ (A₀ : CType ℓ) (a b : CTerm), A ≠ .path A₀ a b)
|
||
(h_not_glue : ∀ (φG : FaceFormula) (T : CType ℓ)
|
||
(f fInv sec ret coh : CTerm) (Ai : CType ℓ),
|
||
A ≠ .glue φG T f fInv sec ret coh Ai) :
|
||
eval .nil (.transp i A φ (.var x)) =
|
||
.vneu (.ntransp i A φ (.vneu (.nvar x))) := by
|
||
rw [eval_transp_stuck _ _ _ _ _ hφ hA h_not_pi h_not_path h_not_glue, eval_var]
|
||
rfl
|
||
|
||
-- ── Π-case with constant domain, varying codomain ────────────────────────────
|
||
--
|
||
-- Concrete setup: codomain varies in dimension `i` but domain is `.univ`
|
||
-- (constant).
|
||
-- Body: `pi "_" univ (path univ (var "a") (papp (var "p") (dim-var i)))`.
|
||
|
||
private def i_dim : DimVar := ⟨"i"⟩
|
||
|
||
private def codAtype : CType (.succ .zero) :=
|
||
.path (CType.univ (ℓ := .zero)) (.var "a") (.papp (.var "p") (DimExpr.var i_dim))
|
||
|
||
private theorem codAtype_varies : CType.dimAbsent i_dim codAtype = false := by decide
|
||
|
||
private theorem pi_univ_codA_varies :
|
||
CType.dimAbsent i_dim (.pi "_" (CType.univ (ℓ := .zero)) codAtype) = false := by decide
|
||
|
||
/-- vTransp along `pi .univ codAtype` produces a `vTranspFun` closure
|
||
carrying both the (constant) domain and the (varying) codomain. -/
|
||
theorem eval_transp_pi_const_dom_example
|
||
(φ : FaceFormula) (hφ : φ ≠ .top) (f : String) :
|
||
eval .nil
|
||
(.transp i_dim (.pi "_" (CType.univ (ℓ := .zero)) codAtype) φ (.var f))
|
||
= .vTranspFun i_dim (CType.univ (ℓ := .zero)) codAtype φ (.vneu (.nvar f)) := by
|
||
rw [eval_transp_pi _ _ _ _ _ _ _ hφ pi_univ_codA_varies, eval_var]
|
||
rfl
|
||
|
||
/-- The CCHM Π β-rule at the value level, const-domain subcase. The inner
|
||
`vTranspInv` reduces to identity by `vTranspInv_const` (since `.univ`
|
||
is absent from `i_dim`), and the outer `vTransp` on the varying
|
||
codomain stalls into a neutral. -/
|
||
theorem vApp_vTranspFun_const_dom_reduces
|
||
(φ : FaceFormula) (hφ : φ ≠ .top) (f y : String) :
|
||
vApp (.vTranspFun i_dim (CType.univ (ℓ := .zero)) codAtype φ (.vneu (.nvar f)))
|
||
(.vneu (.nvar y)) =
|
||
.vneu (.ntransp i_dim codAtype φ
|
||
(.vneu (.napp (.nvar f) (.vneu (.nvar y))))) := by
|
||
-- CCHM Π β-rule
|
||
rw [vApp_vTranspFun]
|
||
-- Inverse transport through constant domain `.univ` is identity
|
||
rw [vTranspInv_const i_dim (CType.univ (ℓ := .zero)) φ _
|
||
(rfl : CType.dimAbsent i_dim (CType.univ (ℓ := .zero)) = true)]
|
||
-- Apply `f` (a neutral) to `y` (a neutral) — stuck `napp`
|
||
rw [vApp_vneu]
|
||
-- Forward transport through the varying codomain — stuck neutral
|
||
rw [vTransp_stuck _ _ _ _ hφ codAtype_varies (by intro h; cases h)]
|
||
|
||
-- ── Π-case with varying domain, varying codomain ─────────────────────────────
|
||
--
|
||
-- Concrete setup: BOTH domain and codomain vary in `i` — the full CCHM case
|
||
-- where inverse transport is non-trivial.
|
||
-- Body: `pi (path univ (var "a0") (papp (var "p") (dim-var i)))
|
||
-- (path univ (var "b0") (papp (var "q") (dim-var i)))`.
|
||
|
||
private def domAtype : CType (.succ .zero) :=
|
||
.path (CType.univ (ℓ := .zero)) (.var "a0") (.papp (.var "p") (DimExpr.var i_dim))
|
||
|
||
private def codBtype : CType (.succ .zero) :=
|
||
.path (CType.univ (ℓ := .zero)) (.var "b0") (.papp (.var "q") (DimExpr.var i_dim))
|
||
|
||
private theorem domAtype_varies : CType.dimAbsent i_dim domAtype = false := by decide
|
||
|
||
private theorem codBtype_varies : CType.dimAbsent i_dim codBtype = false := by decide
|
||
|
||
private theorem pi_varying_all :
|
||
CType.dimAbsent i_dim (.pi "_" domAtype codBtype) = false := by decide
|
||
|
||
/-- vTransp along a pi with both sides varying still produces a unified
|
||
`vTranspFun` — no special-case logic needed at the line level. -/
|
||
theorem eval_transp_pi_varying_dom
|
||
(φ : FaceFormula) (hφ : φ ≠ .top) (f : String) :
|
||
eval .nil (.transp i_dim (.pi "_" domAtype codBtype) φ (.var f)) =
|
||
.vTranspFun i_dim domAtype codBtype φ (.vneu (.nvar f)) := by
|
||
rw [eval_transp_pi _ _ _ _ _ _ _ hφ pi_varying_all, eval_var]
|
||
rfl
|
||
|
||
/-- The reversed domain line also varies in `i_dim`. Reversing substitutes
|
||
`i := inv i` in the right-endpoint `DimExpr.var i_dim`, producing
|
||
`DimExpr.inv (DimExpr.var i_dim)`, which still mentions `i_dim`. -/
|
||
private theorem domAtype_reversed_varies :
|
||
CType.dimAbsent i_dim (domAtype.substDimExpr i_dim (.inv (.var i_dim))) = false := by
|
||
decide
|
||
|
||
/-- Full CCHM Π β-rule in the **varying-domain** case. Applying a
|
||
`vTranspFun i_dim domAtype codBtype φ f` to `y`:
|
||
1. inverse-transports `y` through `domAtype` → stuck
|
||
(`ntransp i_dim (domAtype[i := inv i]) φ y`),
|
||
2. applies `f` to the stuck result → stuck `napp`,
|
||
3. forward-transports through `codBtype` → stuck `ntransp`.
|
||
All three stalls cascade through the axiom equations without incident. -/
|
||
theorem vApp_vTranspFun_varying_dom_reduces
|
||
(φ : FaceFormula) (hφ : φ ≠ .top) (f y : String) :
|
||
vApp (.vTranspFun i_dim domAtype codBtype φ (.vneu (.nvar f))) (.vneu (.nvar y)) =
|
||
.vneu (.ntransp i_dim codBtype φ
|
||
(.vneu (.napp (.nvar f)
|
||
(.vneu (.ntransp i_dim (domAtype.substDimExpr i_dim (.inv (.var i_dim))) φ
|
||
(.vneu (.nvar y))))))) := by
|
||
-- CCHM Π β-rule.
|
||
rw [vApp_vTranspFun]
|
||
-- Inverse transport unfolds to forward transport along the reversed line.
|
||
unfold vTranspInv
|
||
-- The reversed domAtype still varies in i_dim, so vTransp stalls.
|
||
rw [vTransp_stuck _ _ _ _ hφ domAtype_reversed_varies
|
||
(by intro h; cases h)]
|
||
-- Apply the (neutral) f to the (now-neutral) argument → stuck `napp`.
|
||
rw [vApp_vneu]
|
||
-- Forward transport through the varying codomain → stuck `ntransp`.
|
||
rw [vTransp_stuck _ _ _ _ hφ codBtype_varies (by intro h; cases h)]
|
||
|
||
-- ── Heterogeneous composition: C1, C2, const-line, and stuck ────────────────
|
||
|
||
/-- **C1 at eval level**: `comp` under a `.top` face reduces to its system
|
||
body substituted at the `.one` endpoint. Concrete exercise: with
|
||
`u = .var "body"` (a free variable with no dim dependence) and `A = .univ`,
|
||
the substitution is a no-op and the result is `vneu (nvar "body")`. -/
|
||
theorem eval_comp_top_example (i : DimVar) (t : String) :
|
||
eval .nil (.comp i (CType.univ (ℓ := .zero)) .top (.var "body") (.var t)) =
|
||
.vneu (.nvar "body") := by
|
||
rw [eval_comp_top]
|
||
-- (var "body").substDim i .one = var "body" (var case is trivial)
|
||
simp only [CTerm.substDim]
|
||
rw [eval_var]
|
||
rfl
|
||
|
||
/-- C1 at eval level, with a body that actually uses the line's dim var.
|
||
The substitution replaces the dim, but here `papp (var "p") i` becomes
|
||
`papp (var "p") .one`, which evaluates via `vPApp` on a neutral. -/
|
||
theorem eval_comp_top_dim_subst (i : DimVar) (t : String) :
|
||
eval .nil
|
||
(.comp i (CType.univ (ℓ := .zero)) .top (.papp (.var "p") (.var i)) (.var t)) =
|
||
.vneu (.npapp (.nvar "p") .one) := by
|
||
rw [eval_comp_top]
|
||
-- Reduce `(papp (var "p") (var i)).substDim i .one`:
|
||
-- substDim on papp = papp (t.substDim ..) (DimExpr.subst ..)
|
||
-- var "p" unchanged; DimExpr.subst i .one (var i) collapses via if_true.
|
||
simp only [CTerm.substDim, DimExpr.subst, if_true]
|
||
rw [eval_papp, eval_var]
|
||
have hp : (CEnv.nil.lookup "p").getD (.vneu (.nvar "p")) = .vneu (.nvar "p") := rfl
|
||
rw [hp, vPApp_vneu]
|
||
|
||
/-- **C2 at eval level**: `comp` under a `.bot` face reduces to `transp`
|
||
under `.bot`. When the line `A` is constant (here `.univ`), T2 then
|
||
reduces the transport to identity. -/
|
||
theorem eval_comp_bot_univ (i : DimVar) (u t : String) :
|
||
eval .nil (.comp i (CType.univ (ℓ := .zero)) .bot (.var u) (.var t)) =
|
||
.vneu (.nvar t) := by
|
||
rw [eval_comp_bot]
|
||
-- eval (transp i .univ .bot (var t))
|
||
rw [eval_transp_const _ _ _ _ _ (by intro h; nomatch h)
|
||
(rfl : CType.dimAbsent i (CType.univ (ℓ := .zero)) = true),
|
||
eval_var]
|
||
rfl
|
||
|
||
/-- **Constant-line comp = hcomp**: when `A` is constant in `i`, het comp
|
||
reduces to plain homogeneous composition. The tube becomes
|
||
`.plam i u` (a `vplam` closure). When the whole thing is then
|
||
evaluated at `.top` face, hcomp's top-case fires and `vPApp`s the
|
||
tube at `.one`. Verify end-to-end with a free-variable system body
|
||
`u = .var "body"` (no dim dependence): the chain is
|
||
comp (top) → substDim i .one → eval "body" → nvar "body". -/
|
||
theorem eval_comp_const_line (i : DimVar) (φ : FaceFormula)
|
||
(hφ₁ : φ ≠ .top) (hφ₂ : φ ≠ .bot) (t : String) :
|
||
eval .nil (.comp i (CType.univ (ℓ := .zero)) φ (.var "body") (.var t)) =
|
||
.vneu (.nhcomp (CType.univ (ℓ := .zero)) φ
|
||
(.vplam .nil i (.var "body")) (.vneu (.nvar t))) := by
|
||
rw [eval_comp_const _ _ _ _ _ _ hφ₁ hφ₂
|
||
(rfl : CType.dimAbsent i (CType.univ (ℓ := .zero)) = true)]
|
||
rw [eval_plam, eval_var]
|
||
have : (CEnv.nil.lookup t).getD (.vneu (.nvar t)) = .vneu (.nvar t) := rfl
|
||
rw [this]
|
||
-- `vHCompValue .univ φ (vplam nil i (var "body")) (vneu (nvar t))`
|
||
-- → stuck, since .univ is not .pi.
|
||
exact vHCompValue_stuck _ _ _ _ hφ₁ (by intro h; cases h)
|
||
|
||
/-- Stuck comp: free variables, non-constant non-pi line, non-top non-bot face.
|
||
The "not a pi" precondition uses the skeleton-disjointness form. -/
|
||
theorem eval_comp_neu {ℓ : ULevel} (i : DimVar) (A : CType ℓ) (φ : FaceFormula) (u t : String)
|
||
(hφ₁ : φ ≠ .top) (hφ₂ : φ ≠ .bot) (hA : CType.dimAbsent i A = false)
|
||
(h_not_pi : A.skeleton ≠ SkeletalCType.pi) :
|
||
eval .nil (.comp i A φ (.var u) (.var t)) =
|
||
.vneu (.ncomp i A φ (.vneu (.nvar u)) (.vneu (.nvar t))) := by
|
||
rw [eval_comp_stuck _ _ _ _ _ _ hφ₁ hφ₂ hA h_not_pi, eval_var, eval_var]
|
||
have hu : (CEnv.nil.lookup u).getD (.vneu (.nvar u)) = .vneu (.nvar u) := rfl
|
||
have ht : (CEnv.nil.lookup t).getD (.vneu (.nvar t)) = .vneu (.nvar t) := rfl
|
||
rw [hu, ht]
|
||
|
||
-- ── Π hcomp: CCHM β-rule with pointwise reduction ──────────────────────────
|
||
|
||
/-- **Π hcomp β-rule at `.top`**: `hcomp (pi A B) .top tube base` is
|
||
`vPApp tube .one` by `vHCompValue_top` — the tube covers the whole cube,
|
||
so the composition's result is just the tube at `1`. Demonstrate with
|
||
a vplam tube: `tube = vplam .nil j (var "u_body")`. The result is
|
||
`eval .nil ((var "u_body").substDim j .one) = vneu (nvar "u_body")`. -/
|
||
theorem vHCompValue_top_reduces (j : DimVar) (base : CVal) :
|
||
vHCompValue (.pi "_" (CType.univ (ℓ := .zero)) (CType.univ (ℓ := .zero))) .top
|
||
(.vplam .nil j (.var "u_body")) base =
|
||
.vneu (.nvar "u_body") := by
|
||
rw [vHCompValue_top, vPApp_vplam]
|
||
-- (var "u_body").substDim j .one = var "u_body" (no dim usage)
|
||
simp only [CTerm.substDim]
|
||
rw [eval_var]
|
||
rfl
|
||
|
||
/-- **Π hcomp β-rule** at a non-top face, with concrete structure.
|
||
Apply `hcomp (pi .univ .univ) φ tube base` to `y` where:
|
||
· tube = `.vneu (.nvar "tube")` (a free variable),
|
||
· base = `.vneu (.nvar "base_fn")` (a free function),
|
||
· y = `.vneu (.nvar "y")`.
|
||
Expected reduction chain:
|
||
1. `vHCompValue_pi` produces `vHCompFun .univ φ tube base`.
|
||
2. `vApp_vHCompFun` unfolds to
|
||
`vHCompValue .univ φ (.vTubeApp tube y) (vApp base y)`.
|
||
3. `vApp_vneu` reduces `vApp base y` to `napp (nvar "base_fn") y`.
|
||
4. `vHCompValue_stuck` on `.univ` produces the final neutral `nhcomp`. -/
|
||
theorem vApp_vHCompFun_reduces (φ : FaceFormula) (hφ : φ ≠ .top) :
|
||
vApp (.vHCompFun (CType.univ (ℓ := .zero)) φ
|
||
(.vneu (.nvar "tube"))
|
||
(.vneu (.nvar "base_fn")))
|
||
(.vneu (.nvar "y")) =
|
||
.vneu (.nhcomp (CType.univ (ℓ := .zero)) φ
|
||
(.vTubeApp (.vneu (.nvar "tube")) (.vneu (.nvar "y")))
|
||
(.vneu (.napp (.nvar "base_fn") (.vneu (.nvar "y"))))) := by
|
||
rw [vApp_vHCompFun, vApp_vneu,
|
||
vHCompValue_stuck _ _ _ _ hφ (by intro h; cases h)]
|
||
|
||
/-- **vTubeApp reduction**: `(λj. (tube @ j) arg) @ r = (tube @ r) arg`.
|
||
Exercised with a vplam tube: `tube = vplam .nil j (var "u_body")`.
|
||
The chain:
|
||
1. `vPApp_vTubeApp` unfolds to `vApp (vPApp tube r) arg`.
|
||
2. `vPApp_vplam` reduces the inner `vPApp` to `eval .nil ("u_body"[j := r])`.
|
||
3. The body doesn't mention j, so the substDim is identity.
|
||
4. `eval_var` looks up "u_body" → `nvar "u_body"`.
|
||
5. `vApp_vneu` produces `napp (nvar "u_body") arg`. -/
|
||
theorem vPApp_vTubeApp_reduces (j : DimVar) (r : DimExpr) :
|
||
vPApp (.vTubeApp (.vplam .nil j (.var "u_body")) (.vneu (.nvar "arg"))) r =
|
||
.vneu (.napp (.nvar "u_body") (.vneu (.nvar "arg"))) := by
|
||
rw [vPApp_vTubeApp, vPApp_vplam]
|
||
-- substDim j r (var "u_body") = var "u_body" (no dim dep)
|
||
simp only [CTerm.substDim]
|
||
rw [eval_var]
|
||
have hlook : (CEnv.nil.lookup "u_body").getD (.vneu (.nvar "u_body")) =
|
||
.vneu (.nvar "u_body") := rfl
|
||
rw [hlook, vApp_vneu]
|
||
|
||
-- ── Path transport: CCHM endpoint reductions ─────────────────────────────────
|
||
--
|
||
-- Concrete path-transport setup. A varying path line
|
||
-- `path A₀(i) a(i) b(i)`
|
||
-- where A₀ = .univ (so it doesn't vary),
|
||
-- a = .var "a_line" (free variable; here conservatively no i-dep,
|
||
-- but could have),
|
||
-- b = .papp (.var "b_pt") (DimExpr.var i_dim) — uses i_dim
|
||
-- The right endpoint `b` mentions `i_dim`, so the whole path line varies.
|
||
|
||
private def pathLine_a : CTerm := .var "a_line"
|
||
private def pathLine_b : CTerm := .papp (.var "b_pt") (DimExpr.var i_dim)
|
||
private def pathLineA : CType (.succ .zero) :=
|
||
.path (CType.univ (ℓ := .zero)) pathLine_a pathLine_b
|
||
|
||
private theorem pathLineA_varies : CType.dimAbsent i_dim pathLineA = false := by decide
|
||
|
||
/-- Transport along a varying path line produces a `vPathTransp` closure
|
||
storing the path term (as a CTerm, not a value). -/
|
||
theorem eval_transp_path_example
|
||
(φ : FaceFormula) (hφ : φ ≠ .top) (p : String) :
|
||
eval .nil (.transp i_dim pathLineA φ (.var p)) =
|
||
.vPathTransp .nil i_dim (CType.univ (ℓ := .zero)) pathLine_a pathLine_b φ (.var p) := by
|
||
show eval .nil
|
||
(.transp i_dim (.path (CType.univ (ℓ := .zero)) pathLine_a pathLine_b) φ (.var p)) = _
|
||
rw [eval_transp_path _ _ _ _ _ _ _ hφ pathLineA_varies]
|
||
|
||
/-- **Path transport at the `.zero` endpoint**: CCHM's `(j=0)` clause fires,
|
||
yielding the line's left endpoint at `i=1` — here `.var "a_line"`
|
||
(which has no `i`-dep, so its `substDim i .one` is itself). -/
|
||
theorem vPApp_vPathTransp_zero_reduces
|
||
(φ : FaceFormula) (p : CTerm) :
|
||
vPApp (.vPathTransp .nil i_dim (CType.univ (ℓ := .zero))
|
||
pathLine_a pathLine_b φ p) .zero =
|
||
.vneu (.nvar "a_line") := by
|
||
rw [vPApp_vPathTransp_zero]
|
||
-- pathLine_a.substDim i_dim .one = pathLine_a (no dim dep; var case)
|
||
show eval .nil (CTerm.substDim i_dim .one (.var "a_line")) = _
|
||
simp only [CTerm.substDim]
|
||
rw [eval_var]; rfl
|
||
|
||
/-- **Path transport at the `.one` endpoint**: CCHM's `(j=1)` clause fires,
|
||
yielding the line's right endpoint at `i=1`. Here `pathLine_b` mentions
|
||
`i_dim`, so its `substDim i_dim .one` replaces the dim variable with
|
||
`.one`, producing `papp (var "b_pt") .one`. Evaluation then gives
|
||
`npapp (nvar "b_pt") .one`. -/
|
||
theorem vPApp_vPathTransp_one_reduces
|
||
(φ : FaceFormula) (p : CTerm) :
|
||
vPApp (.vPathTransp .nil i_dim (CType.univ (ℓ := .zero))
|
||
pathLine_a pathLine_b φ p) .one =
|
||
.vneu (.npapp (.nvar "b_pt") .one) := by
|
||
rw [vPApp_vPathTransp_one]
|
||
-- pathLine_b.substDim i_dim .one = papp (var "b_pt") (DimExpr.subst i_dim .one (DimExpr.var i_dim))
|
||
-- = papp (var "b_pt") .one
|
||
simp only [pathLine_b, CTerm.substDim, DimExpr.subst, if_true]
|
||
rw [eval_papp, eval_var]
|
||
have hb : (CEnv.nil.lookup "b_pt").getD (.vneu (.nvar "b_pt")) =
|
||
.vneu (.nvar "b_pt") := rfl
|
||
rw [hb, vPApp_vneu]
|
||
|
||
/-- When the path line is fully constant (all of A₀, a, b absent from i),
|
||
transport reduces via T2 at eval level (arm 2), returning the base
|
||
unchanged — no `vPathTransp` produced. -/
|
||
theorem eval_transp_constant_path (i : DimVar) (φ : FaceFormula) (p : String) :
|
||
eval .nil (.transp i (.path (CType.univ (ℓ := .zero)) (.var "a0") (.var "b0")) φ (.var p)) =
|
||
.vneu (.nvar p) := by
|
||
have hA : CType.dimAbsent i
|
||
(.path (CType.univ (ℓ := .zero)) (.var "a0") (.var "b0")) = true :=
|
||
rfl
|
||
by_cases hφ : φ = .top
|
||
· subst hφ; rw [eval_transp_top, eval_var]; rfl
|
||
· rw [eval_transp_const _ _ _ _ _ hφ hA, eval_var]
|
||
rfl
|
||
|
||
-- ── Multi-clause comp reductions ───────────────────────────────────────────────
|
||
|
||
/-- **Empty multi-clause comp reduces to plain transport.** A `compN` with
|
||
no clauses has no system — nothing to override, so the result is just
|
||
transport of the base. Demonstrated with `A = .univ` where transport is
|
||
identity (via T2). -/
|
||
theorem eval_compN_empty (i : DimVar) (t : String) :
|
||
eval .nil (.compN i (CType.univ (ℓ := .zero)) [] (.var t)) = .vneu (.nvar t) := by
|
||
rw [eval_compN, vCompNAtTerm_def]
|
||
-- find? on [] is none; filter on [] is []; [] arm → transport
|
||
simp only [List.find?, List.filter]
|
||
-- Now: eval .nil (.transp i .univ .bot (.var t))
|
||
rw [eval_transp_const _ _ _ _ _ (by intro h; nomatch h)
|
||
(rfl : CType.dimAbsent i (CType.univ (ℓ := .zero)) = true),
|
||
eval_var]
|
||
rfl
|
||
|
||
/-- **compN with a `.top`-faced clause fires on that clause**, returning
|
||
the clause's body substituted at `i := .one`. This is the CCHM
|
||
full-system rule lifted to multi-clause. -/
|
||
theorem eval_compN_top_fires (i : DimVar) (u t : String) :
|
||
eval .nil (.compN i (CType.univ (ℓ := .zero)) [(.top, .var u)] (.var t)) =
|
||
.vneu (.nvar u) := by
|
||
rw [eval_compN, vCompNAtTerm_def]
|
||
-- find? matches the (.top, _) head immediately.
|
||
simp only [List.find?]
|
||
-- Goal: eval .nil ((var u).substDim i .one) = vneu (nvar u)
|
||
simp only [CTerm.substDim]
|
||
rw [eval_var]; rfl
|
||
|
||
/-- **compN where a `.top` clause is NOT at the head but later**: the
|
||
scanning `find?` still picks it up. Exercised with clauses
|
||
`[(φ, _), (.top, u)]` for some non-top `φ`. -/
|
||
theorem eval_compN_top_later (i : DimVar) (u t : String) (k : DimVar) :
|
||
eval .nil (.compN i (CType.univ (ℓ := .zero))
|
||
[(.eq0 k, .var "dummy"), (.top, .var u)] (.var t)) =
|
||
.vneu (.nvar u) := by
|
||
rw [eval_compN, vCompNAtTerm_def]
|
||
-- find? skips (.eq0 k, _), hits (.top, _)
|
||
simp only [List.find?]
|
||
simp only [CTerm.substDim]
|
||
rw [eval_var]; rfl
|
||
|
||
-- ── Path transport at a composite endpoint (inv .zero = .one) ────────────────
|
||
--
|
||
-- Demonstrates the key correctness property: even when the applied dim
|
||
-- expression isn't literally `.zero` or `.one`, if it *evaluates to* an
|
||
-- endpoint (e.g. `.inv .zero = 1`), the multi-clause `dimExprEq1` helper
|
||
-- detects this and fires the corresponding clause.
|
||
|
||
/-- **Path transport at `inv .zero`** (= 1 semantically) fires the (j=1)
|
||
clause of the CCHM multi-clause system, yielding `b(1)`. Exercises:
|
||
· `FaceFormula.dimExprEq0 (inv .zero) = dimExprEq1 .zero = .bot`
|
||
· `FaceFormula.dimExprEq1 (inv .zero) = dimExprEq0 .zero = .top`
|
||
So the compN system becomes `[(φ, _), (.bot, a), (.top, b)]` and
|
||
`vCompNAtTerm`'s `find?` picks the third clause. -/
|
||
theorem vPApp_vPathTransp_inv_zero
|
||
(φ : FaceFormula) (hφ : φ ≠ .top) (hφbot : φ ≠ .bot) (p : CTerm) :
|
||
vPApp (.vPathTransp .nil i_dim (CType.univ (ℓ := .zero))
|
||
pathLine_a pathLine_b φ p) (.inv .zero) =
|
||
.vneu (.npapp (.nvar "b_pt") .one) := by
|
||
rw [vPApp_vPathTransp_general _ _ _ _ _ _ _ _
|
||
(by intro h; nomatch h)
|
||
(by intro h; nomatch h)]
|
||
-- After: vCompNAtTerm .nil i_dim .univ
|
||
-- [(φ, p@(inv 0)), (dimExprEq0 (inv 0), a), (dimExprEq1 (inv 0), b)]
|
||
-- (p@(inv 0))
|
||
rw [vCompNAtTerm_def]
|
||
-- Reduce the dimExprEq0/dimExprEq1 at inv .zero:
|
||
-- dimExprEq0 (inv .zero) = dimExprEq1 .zero = .bot
|
||
-- dimExprEq1 (inv .zero) = dimExprEq0 .zero = .top
|
||
simp only [FaceFormula.dimExprEq0, FaceFormula.dimExprEq1]
|
||
-- Now `find?` scans [(φ, _), (.bot, _), (.top, _)]. It skips φ (non-top
|
||
-- by hφ), skips .bot (non-top), hits .top.
|
||
-- The `match φ with .top => ... | _ => ...` on the head first clause
|
||
-- reduces to `| _ => false` since φ ≠ .top.
|
||
have _hφtop_eq : (match φ with | .top => true | _ => false) = false := by
|
||
cases φ <;> first | rfl | exact absurd rfl hφ
|
||
simp only [List.find?]
|
||
-- Now `find?` on [(.bot, a), (.top, b)]: skip .bot, match .top.
|
||
-- Continue reducing:
|
||
show eval .nil (pathLine_b.substDim i_dim .one) = _
|
||
simp only [pathLine_b, CTerm.substDim, DimExpr.subst, if_true]
|
||
rw [eval_papp, eval_var]
|
||
have hb : (CEnv.nil.lookup "b_pt").getD (.vneu (.nvar "b_pt")) =
|
||
.vneu (.nvar "b_pt") := rfl
|
||
rw [hb, vPApp_vneu]
|
||
|
||
-- ── Heterogeneous Π composition ─────────────────────────────────────────────
|
||
|
||
/-- **Hetero Π comp produces a `vCompFun`**: evaluating `comp^i (pi A B) φ u t`
|
||
when the pi line genuinely varies packages everything into a closure
|
||
that runs the CCHM β-rule on application. -/
|
||
theorem eval_comp_pi_example (u_name t_name : String)
|
||
(φ : FaceFormula) (hφ₁ : φ ≠ .top) (hφ₂ : φ ≠ .bot) :
|
||
eval .nil (.comp i_dim (.pi "_" domAtype codBtype) φ
|
||
(.var u_name) (.var t_name)) =
|
||
.vCompFun .nil i_dim domAtype codBtype φ (.var u_name) (.var t_name) := by
|
||
rw [eval_comp_pi _ _ _ _ _ _ _ _ hφ₁ hφ₂ pi_varying_all]
|
||
|
||
/-- **Const-domain hetero Π comp β degenerate case**: when `domA = .univ`
|
||
(const in i), the fill `y_at_i` and `y_at_0` both reduce to `y` (via
|
||
`vTransp_const`). The inner comp becomes just `comp^i codB φ (u y) (t y)`. -/
|
||
theorem vApp_vCompFun_const_dom_example (u_name t_name y_name : String) (φ : FaceFormula) :
|
||
vApp (.vCompFun .nil i_dim (CType.univ (ℓ := .zero)) codBtype φ (.var u_name) (.var t_name))
|
||
(.vneu (.nvar y_name)) =
|
||
eval (CEnv.nil.extend "$y" (.vneu (.nvar y_name)))
|
||
(.comp i_dim codBtype φ
|
||
(.app (.var u_name)
|
||
(.transp ⟨"$fj"⟩
|
||
((CType.univ (ℓ := .zero)).substDimExpr i_dim
|
||
(.join (.inv (.var ⟨"$fj"⟩)) (.var i_dim)))
|
||
φ (.var "$y")))
|
||
(.app (.var t_name)
|
||
(.transp ⟨"$fj"⟩
|
||
((CType.univ (ℓ := .zero)).substDimExpr i_dim (.inv (.var ⟨"$fj"⟩)))
|
||
φ (.var "$y")))) := by
|
||
rw [vApp_vCompFun]
|
||
|
||
/-- **Varying-domain hetero Π comp β** also fires, producing the CCHM
|
||
fill-based inner comp term. Uses `domAtype` (genuinely varying in i). -/
|
||
theorem vApp_vCompFun_varying_dom_fires
|
||
(u_name t_name y_name : String) (φ : FaceFormula) :
|
||
vApp (.vCompFun .nil i_dim domAtype codBtype φ (.var u_name) (.var t_name))
|
||
(.vneu (.nvar y_name)) =
|
||
eval (CEnv.nil.extend "$y" (.vneu (.nvar y_name)))
|
||
(.comp i_dim codBtype φ
|
||
(.app (.var u_name)
|
||
(.transp ⟨"$fj"⟩
|
||
(domAtype.substDimExpr i_dim
|
||
(.join (.inv (.var ⟨"$fj"⟩)) (.var i_dim)))
|
||
φ (.var "$y")))
|
||
(.app (.var t_name)
|
||
(.transp ⟨"$fj"⟩
|
||
(domAtype.substDimExpr i_dim (.inv (.var ⟨"$fj"⟩)))
|
||
φ (.var "$y")))) := by
|
||
rw [vApp_vCompFun]
|
||
|
||
/-- **Spot-check of the fill's endpoint correctness** at the CType level:
|
||
`domAtype.substDimExpr i_dim (.join (.inv (.var fj)) (.var i_dim))`
|
||
is NOT equal to `domAtype` (genuine substitution happens), confirming
|
||
the fill construction is non-trivial. -/
|
||
example :
|
||
domAtype.substDimExpr i_dim
|
||
(.join (.inv (.var ⟨"$fj"⟩)) (.var i_dim)) =
|
||
.path (CType.univ (ℓ := .zero)) (.var "a0")
|
||
(.papp (.var "p") (.join (.inv (.var ⟨"$fj"⟩)) (.var i_dim))) := by
|
||
simp only [domAtype, CType.substDimExpr, CTerm.substDim, DimExpr.subst]
|
||
rfl
|