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>
194 lines
8.5 KiB
Text
194 lines
8.5 KiB
Text
/-
|
||
CubicalTransport.DecEq
|
||
======================
|
||
Decidable equality for the 5-way mutual block (`CType`, `CTerm`,
|
||
`CTypeArg`, `CtorSpec`, `CTypeSchema`) plus the list/pair helper
|
||
shapes that appear inside it.
|
||
|
||
Lean 4's `deriving instance DecidableEq` does not currently support
|
||
mutual inductives — has to be written manually.
|
||
|
||
## Universe-aware shape
|
||
|
||
`CType` is `CType : ULevel → Type`. Most CType constructors with sub-
|
||
CType payloads keep their sub-components at the same level as the
|
||
outer type (`path`, `glue`, `lift`, `interval`, `univ`, `ind`). But
|
||
`pi` and `sigma` carry sub-components at potentially distinct levels
|
||
`ℓA, ℓB` — only their `max` is fixed by the index.
|
||
|
||
Cross-level decidable equality is genuinely tricky in Lean's type
|
||
theory (an indexed-family `cases hA : HEq A A'` does not give us
|
||
`ℓA = ℓA'` without injectivity-of-the-index, which Lean doesn't ship
|
||
for arbitrary indexed inductives). We therefore route everything
|
||
through a level-erased `Σ ℓ : ULevel, CType ℓ` boolean equality and
|
||
expose only the boolean workhorses (`beqCTypeAny`, `beqCTerm`, etc.)
|
||
for downstream consumers.
|
||
|
||
These workhorses are *computable* — they use the `partial def`
|
||
structure of the mutual block and dispatch by constructor pattern.
|
||
Used by `CubicalTransport.Question` for the syntactic-classifier
|
||
predicates (`IsTransport q := CTerm.beq q.u q.t = true`) and by
|
||
the Rust FFI bridge for cross-language equality checks.
|
||
-/
|
||
|
||
import CubicalTransport.Syntax
|
||
|
||
namespace CubicalTransport.DecEq
|
||
|
||
-- ── Boolean equality on level-erased CType ─────────────────────────────────
|
||
-- Single workhorse: compares Σ-pairs. Sub-component CTypes are also
|
||
-- compared as Σ-pairs, sidestepping any cross-level pattern issues.
|
||
|
||
mutual
|
||
|
||
partial def beqCTypeAny : (Σ ℓ : ULevel, CType ℓ) → (Σ ℓ : ULevel, CType ℓ) → Bool
|
||
| ⟨_, .univ (ℓ := ℓ)⟩, ⟨_, .univ (ℓ := ℓ')⟩ => decide (ℓ = ℓ')
|
||
| ⟨_, .pi var A B⟩, ⟨_, .pi var' A' B'⟩ =>
|
||
var == var' && beqCTypeAny ⟨_, A⟩ ⟨_, A'⟩ && beqCTypeAny ⟨_, B⟩ ⟨_, B'⟩
|
||
| ⟨_, .sigma var A B⟩, ⟨_, .sigma var' A' B'⟩ =>
|
||
var == var' && beqCTypeAny ⟨_, A⟩ ⟨_, A'⟩ && beqCTypeAny ⟨_, B⟩ ⟨_, B'⟩
|
||
| ⟨_, .path A a b⟩, ⟨_, .path A' a' b'⟩ =>
|
||
beqCTypeAny ⟨_, A⟩ ⟨_, A'⟩ && beqCTerm a a' && beqCTerm b b'
|
||
| ⟨_, .glue ψ T f fInv s r c A⟩, ⟨_, .glue ψ' T' f' fInv' s' r' c' A'⟩ =>
|
||
ψ == ψ' && beqCTypeAny ⟨_, T⟩ ⟨_, T'⟩ &&
|
||
beqCTerm f f' && beqCTerm fInv fInv' &&
|
||
beqCTerm s s' && beqCTerm r r' && beqCTerm c c' &&
|
||
beqCTypeAny ⟨_, A⟩ ⟨_, A'⟩
|
||
| ⟨_, .ind (ℓ := ℓ) S ps⟩, ⟨_, .ind (ℓ := ℓ') S' ps'⟩ =>
|
||
decide (ℓ = ℓ') && beqCTypeSchema S S' && beqParams ps ps'
|
||
| ⟨_, .interval⟩, ⟨_, .interval⟩ => true
|
||
| ⟨_, .lift A⟩, ⟨_, .lift A'⟩ =>
|
||
beqCTypeAny ⟨_, A⟩ ⟨_, A'⟩
|
||
| ⟨_, .El P⟩, ⟨_, .El Q⟩ =>
|
||
beqCTerm P Q
|
||
| ⟨_, .modal k A⟩, ⟨_, .modal k' B⟩ =>
|
||
decide (k = k') && beqCTypeAny ⟨_, A⟩ ⟨_, B⟩
|
||
| _, _ => false
|
||
|
||
partial def beqCTerm : CTerm → CTerm → Bool
|
||
| .var x, .var y => x == y
|
||
| .lam x t, .lam y u => x == y && beqCTerm t u
|
||
| .app f a, .app f' a' => beqCTerm f f' && beqCTerm a a'
|
||
| .plam i t, .plam j u => i == j && beqCTerm t u
|
||
| .papp t r, .papp u s => r == s && beqCTerm t u
|
||
| .transp i A φ t, .transp j B ψ u =>
|
||
i == j && φ == ψ && beqCTypeAny ⟨_, A⟩ ⟨_, B⟩ && beqCTerm t u
|
||
| .comp i A φ u t, .comp j B ψ u' t' =>
|
||
i == j && φ == ψ && beqCTypeAny ⟨_, A⟩ ⟨_, B⟩ &&
|
||
beqCTerm u u' && beqCTerm t t'
|
||
| .compN i A cs t, .compN j B cs' t' =>
|
||
i == j && beqCTypeAny ⟨_, A⟩ ⟨_, B⟩ &&
|
||
beqClauses cs cs' && beqCTerm t t'
|
||
| .glueIn φ t a, .glueIn ψ u b =>
|
||
φ == ψ && beqCTerm t u && beqCTerm a b
|
||
| .unglue φ f g, .unglue ψ f' g' =>
|
||
φ == ψ && beqCTerm f f' && beqCTerm g g'
|
||
| .pair a b, .pair a' b' => beqCTerm a a' && beqCTerm b b'
|
||
| .fst t, .fst u => beqCTerm t u
|
||
| .snd t, .snd u => beqCTerm t u
|
||
| .dimExpr r, .dimExpr s => r == s
|
||
| .ctor S c ps as, .ctor S' c' ps' as' =>
|
||
c == c' && beqCTypeSchema S S' && beqParams ps ps' && beqList as as'
|
||
| .indElim S ps m bs t, .indElim S' ps' m' bs' t' =>
|
||
beqCTypeSchema S S' && beqParams ps ps' &&
|
||
beqCTerm m m' && beqBranches bs bs' && beqCTerm t t'
|
||
| .code A, .code B =>
|
||
-- A and B may live at different universe levels. Route through
|
||
-- the level-erased Σ-pair beq to compare them honestly.
|
||
beqCTypeAny ⟨_, A⟩ ⟨_, B⟩
|
||
-- Modal introduction: structural equality on (kind, wrapped term).
|
||
| .modalIntro k a, .modalIntro k' b =>
|
||
decide (k = k') && beqCTerm a b
|
||
-- Modal elimination: structural equality on (kind, eliminator, scrutinee).
|
||
| .modalElim k f m, .modalElim k' f' m' =>
|
||
decide (k = k') && beqCTerm f f' && beqCTerm m m'
|
||
| _, _ => false
|
||
|
||
partial def beqCTypeArg : CTypeArg → CTypeArg → Bool
|
||
| .type A, .type B => beqCTypeAny ⟨_, A⟩ ⟨_, B⟩
|
||
| .param i, .param j => i == j
|
||
| .self, .self => true
|
||
| .dim, .dim => true
|
||
| _, _ => false
|
||
|
||
partial def beqCtorSpec : CtorSpec → CtorSpec → Bool
|
||
| .mk n as bs, .mk n' as' bs' =>
|
||
n == n' && beqArgList as as' && beqClauses bs bs'
|
||
|
||
partial def beqCTypeSchema : CTypeSchema → CTypeSchema → Bool
|
||
| .mk n np cs, .mk n' np' cs' =>
|
||
n == n' && np == np' && beqCtorList cs cs'
|
||
|
||
-- ── List / clause / branch helpers ──────────────────────────────────────────
|
||
|
||
partial def beqParams : List (Σ ℓ : ULevel, CType ℓ) → List (Σ ℓ : ULevel, CType ℓ) → Bool
|
||
| [], [] => true
|
||
| x :: xs, y :: ys => beqCTypeAny x y && beqParams xs ys
|
||
| _, _ => false
|
||
|
||
partial def beqList : List CTerm → List CTerm → Bool
|
||
| [], [] => true
|
||
| x :: xs, y :: ys => beqCTerm x y && beqList xs ys
|
||
| _, _ => false
|
||
|
||
partial def beqArgList : List CTypeArg → List CTypeArg → Bool
|
||
| [], [] => true
|
||
| x :: xs, y :: ys => beqCTypeArg x y && beqArgList xs ys
|
||
| _, _ => false
|
||
|
||
partial def beqCtorList : List CtorSpec → List CtorSpec → Bool
|
||
| [], [] => true
|
||
| x :: xs, y :: ys => beqCtorSpec x y && beqCtorList xs ys
|
||
| _, _ => false
|
||
|
||
partial def beqClauses : List (FaceFormula × CTerm) → List (FaceFormula × CTerm) → Bool
|
||
| [], [] => true
|
||
| (φ, t) :: xs, (ψ, u) :: ys =>
|
||
φ == ψ && beqCTerm t u && beqClauses xs ys
|
||
| _, _ => false
|
||
|
||
partial def beqBranches : List (String × CTerm) → List (String × CTerm) → Bool
|
||
| [], [] => true
|
||
| (n, t) :: xs, (n', u) :: ys =>
|
||
n == n' && beqCTerm t u && beqBranches xs ys
|
||
| _, _ => false
|
||
|
||
end
|
||
|
||
-- ── Same-level CType beq derived from Σ-level beq ──────────────────────────
|
||
|
||
/-- Same-level boolean equality for `CType ℓ`. -/
|
||
def CType.beq {ℓ : ULevel} (a b : CType ℓ) : Bool :=
|
||
beqCTypeAny ⟨ℓ, a⟩ ⟨ℓ, b⟩
|
||
|
||
/-- Same-level boolean equality for CTerm. -/
|
||
def CTerm.beq (a b : CTerm) : Bool := beqCTerm a b
|
||
|
||
/-- Boolean equality for CTypeArg. -/
|
||
def CTypeArg.beq (a b : CTypeArg) : Bool := beqCTypeArg a b
|
||
|
||
/-- Boolean equality for CtorSpec. -/
|
||
def CtorSpec.beq (a b : CtorSpec) : Bool := beqCtorSpec a b
|
||
|
||
/-- Boolean equality for CTypeSchema. -/
|
||
def CTypeSchema.beq (a b : CTypeSchema) : Bool := beqCTypeSchema a b
|
||
|
||
-- ── Decidable equality ─────────────────────────────────────────────────────
|
||
-- We do NOT provide `DecidableEq` instances for the mutual block. The
|
||
-- universe-stratified `CType : ULevel → Type` has cross-level pi/sigma
|
||
-- sub-components, which would force the DecEq mutual block to handle
|
||
-- HEq elimination across distinct universe indices — which is not
|
||
-- available in Lean 4 without K.
|
||
--
|
||
-- Consumers that need to decide equality on the cubical syntax should
|
||
-- use the boolean `beq`/`beqCTypeAny` workhorses above, which ARE
|
||
-- computable. These are the routes used by `Question.lean`'s
|
||
-- classifiers and the Rust FFI bridge.
|
||
--
|
||
-- (Previously these instances were defined as non-computable
|
||
-- Classical fallbacks, but that was a stratification leak: the
|
||
-- engine is constructive cubical, and Classical reasoning is a
|
||
-- foundational change to its discipline. The boolean `beq` route is
|
||
-- the structural alternative.)
|
||
|
||
end CubicalTransport.DecEq
|