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>
554 lines
21 KiB
Text
554 lines
21 KiB
Text
/-
|
||
CubicalTransport.Question — The universal question form
|
||
=======================================================
|
||
Implements `docs/QUESTIONS.md` Levels 1 + 1.5 + 2.
|
||
|
||
The CCHM partial-element-filler problem `comp i A φ u t` is *the*
|
||
universal cubical question. This module reifies that question as
|
||
a Lean record `CompQ`, defines `ask` (run the engine), `Equiv`
|
||
(answers coincide), and a vocabulary of classifying predicates
|
||
that pin specific question shapes (`IsConstLine`, `IsFullFace`,
|
||
`IsPathLine`, …).
|
||
|
||
## Universe-aware shape (Layer 0 §0.1 cascade)
|
||
|
||
The four reified question shapes (`CompQ`, `TranspQ`, `HCompQ`,
|
||
`CompNQ`) carry their type-line's universe level explicitly. All
|
||
classifiers and theorems are level-aware. For ergonomic backwards-
|
||
compat with Dev_REL1 / Dev_REL2 callers, the default level is
|
||
`.zero` (covers `.bool`, `.nat`, `.list`, `.path`, etc.).
|
||
|
||
Cross-level pi/sigma sub-component classification (where the
|
||
domain and codomain live at distinct levels whose `max` equals
|
||
the outer body level) is restricted to the same-level case (via
|
||
`ULevel.max_self`).
|
||
|
||
## Computable Decidable instances (no Classical)
|
||
|
||
All `Decidable` instances in this module are *computable*. The
|
||
body-shape classifier predicates are decided via:
|
||
|
||
1. Compare `q.body.skeleton` (level-erased constructor tag) with
|
||
the target `SkeletalCType` value. This step is decidable
|
||
because `SkeletalCType` has `DecidableEq` derived.
|
||
2. On match: extract the witness by structural pattern-matching
|
||
(`cases hb : q.body`).
|
||
3. On mismatch: refute the existential by skeleton inequality
|
||
(the existential's body would forces a skeleton equation
|
||
contradicted by `hs`).
|
||
|
||
The `IsTransport` predicate uses `CTerm.beq` (the boolean equality
|
||
workhorse from `DecEq.lean`), which is computable, with a
|
||
decidability instance routed through that boolean.
|
||
-/
|
||
|
||
import CubicalTransport.TransportLaws
|
||
import CubicalTransport.CompLaws
|
||
import CubicalTransport.DecEq
|
||
|
||
namespace Question
|
||
|
||
open CubicalTransport.DecEq
|
||
|
||
-- ── CompQ — the universal question, reified ─────────────────────────────────
|
||
|
||
/-- The CCHM partial-element-filler question, reified as data. -/
|
||
structure CompQ where
|
||
/-- Universe level of the type-line `body`. -/
|
||
level : ULevel := .zero
|
||
env : CEnv
|
||
binder : DimVar
|
||
body : CType level
|
||
φ : FaceFormula
|
||
u : CTerm
|
||
t : CTerm
|
||
|
||
/-- "Asking" a question runs the engine on a `.comp` term. -/
|
||
def CompQ.ask (q : CompQ) : CVal :=
|
||
eval q.env (.comp q.binder q.body q.φ q.u q.t)
|
||
|
||
/-- Two questions are *equivalent* when their engine answers coincide. -/
|
||
def CompQ.Equiv (q₁ q₂ : CompQ) : Prop := q₁.ask = q₂.ask
|
||
|
||
@[refl] theorem CompQ.Equiv.refl (q : CompQ) : q.Equiv q := rfl
|
||
|
||
@[symm] theorem CompQ.Equiv.symm {q₁ q₂ : CompQ}
|
||
(h : q₁.Equiv q₂) : q₂.Equiv q₁ := Eq.symm h
|
||
|
||
theorem CompQ.Equiv.trans {q₁ q₂ q₃ : CompQ}
|
||
(h₁ : q₁.Equiv q₂) (h₂ : q₂.Equiv q₃) : q₁.Equiv q₃ :=
|
||
Eq.trans h₁ h₂
|
||
|
||
/-- Smart constructor: every transport `transpⁱ A φ t` is the
|
||
degenerate question `compⁱ A φ t t`. -/
|
||
def CompQ.ofTransp {ℓ : ULevel} (env : CEnv) (i : DimVar) (A : CType ℓ)
|
||
(φ : FaceFormula) (t : CTerm) : CompQ :=
|
||
{ level := ℓ, env := env, binder := i, body := A, φ := φ, u := t, t := t }
|
||
|
||
-- ── Classifiers — the meta-vocabulary of question shapes ─────────────────────
|
||
|
||
/-- The line is constant in its binder. -/
|
||
@[simp]
|
||
def IsConstLine (q : CompQ) : Prop :=
|
||
q.body.dimAbsent q.binder = true
|
||
|
||
/-- The face is the full face. -/
|
||
@[simp]
|
||
def IsFullFace (q : CompQ) : Prop := q.φ = .top
|
||
|
||
/-- The face is the empty face. -/
|
||
@[simp]
|
||
def IsEmptyFace (q : CompQ) : Prop := q.φ = .bot
|
||
|
||
/-- The base equals the partial element.
|
||
|
||
Computable formulation via `CTerm.beq`: full propositional Eq
|
||
on CTerm requires `DecidableEq CTerm`, which is non-trivial to
|
||
define computably (the mutual `CTerm`/`CType` block doesn't
|
||
auto-derive `DecidableEq`). We use the boolean-equality
|
||
workhorse from `DecEq.lean` instead. -/
|
||
@[simp]
|
||
def IsTransport (q : CompQ) : Prop :=
|
||
CTerm.beq q.u q.t = true
|
||
|
||
/-- The line is a Path type. -/
|
||
@[simp]
|
||
def IsPathLine (q : CompQ) : Prop :=
|
||
∃ (A₀ : CType q.level) (a b : CTerm), q.body = .path A₀ a b
|
||
|
||
/-- The line is a Glue type. -/
|
||
@[simp]
|
||
def IsGlueLine (q : CompQ) : Prop :=
|
||
∃ (ψ : FaceFormula) (T : CType q.level) (f fInv s r c : CTerm)
|
||
(A : CType q.level),
|
||
q.body = .glue ψ T f fInv s r c A
|
||
|
||
/-- The line is a Π type whose sub-components live at the same level
|
||
as the body. Cross-level pi (sub-components at distinct levels
|
||
whose `max` equals the body level) is not classified here.
|
||
|
||
Computable form: `q.body.skeleton = .pi` (a necessary condition).
|
||
The full witness extraction is done in the Decidable instance via
|
||
`cases` on `q.body`. -/
|
||
@[simp]
|
||
def IsPiLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.pi
|
||
|
||
/-- The line is a Σ type (same-level specialisation). -/
|
||
@[simp]
|
||
def IsSigmaLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.sigma
|
||
|
||
/-- The line is a schema-defined inductive. -/
|
||
@[simp]
|
||
def IsIndLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.ind
|
||
|
||
/-- The line is the cubical interval — only meaningful at level 0. -/
|
||
@[simp]
|
||
def IsIntervalLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.interval
|
||
|
||
/-- The line is the universe at some level. -/
|
||
@[simp]
|
||
def IsUnivLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.univ
|
||
|
||
/-- The line is the universe-code decoder `.El P` for some bound CTerm
|
||
`P`. Encoded via the level-erased skeleton tag. -/
|
||
@[simp]
|
||
def IsElLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.El
|
||
|
||
/-- The line is a modality of kind `k` (Refactor Phase 2). Encoded
|
||
via the level-erased skeleton tag, parameterised over
|
||
`ModalityKind`. Specialise via `IsModalLine q .flat` /
|
||
`IsModalLine q .sharp` / `IsModalLine q .shape`. -/
|
||
@[simp]
|
||
def IsModalLine (q : CompQ) (k : ModalityKind) : Prop :=
|
||
q.body.skeleton = SkeletalCType.modal k
|
||
|
||
-- ── Decidability for the core classifiers ───────────────────────────────────
|
||
-- All instances are computable. Body-shape predicates are skeleton-eq
|
||
-- forms, decidable via `DecidableEq SkeletalCType`.
|
||
|
||
instance (q : CompQ) : Decidable (IsConstLine q) :=
|
||
inferInstanceAs (Decidable (q.body.dimAbsent q.binder = true))
|
||
|
||
instance (q : CompQ) : Decidable (IsFullFace q) :=
|
||
inferInstanceAs (Decidable (q.φ = .top))
|
||
|
||
instance (q : CompQ) : Decidable (IsEmptyFace q) :=
|
||
inferInstanceAs (Decidable (q.φ = .bot))
|
||
|
||
instance (q : CompQ) : Decidable (IsTransport q) :=
|
||
inferInstanceAs (Decidable (CTerm.beq q.u q.t = true))
|
||
|
||
instance (q : CompQ) : Decidable (IsIntervalLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.interval))
|
||
|
||
instance (q : CompQ) : Decidable (IsUnivLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.univ))
|
||
|
||
instance instDecidableIsPathLine (q : CompQ) : Decidable (IsPathLine q) := by
|
||
-- IsPathLine is an existential; decide via skeleton, then extract.
|
||
by_cases hs : q.body.skeleton = SkeletalCType.path
|
||
· -- skeleton = .path; the only constructor with that skel is .path.
|
||
-- Generalise q's projection so cases can dispatch the indexed inductive.
|
||
obtain ⟨level, env, binder, body, φ, u, t⟩ := q
|
||
simp only at hs
|
||
cases body with
|
||
| univ => simp at hs
|
||
| pi var A B => simp at hs
|
||
| sigma var A B => simp at hs
|
||
| path A a b => exact isTrue ⟨A, a, b, rfl⟩
|
||
| glue ψ T f fInv s r c A => simp at hs
|
||
| ind S params => simp at hs
|
||
| interval => simp at hs
|
||
| lift A => simp at hs
|
||
| El P => simp at hs
|
||
| modal k A => simp at hs
|
||
· refine isFalse (fun ⟨_, _, _, hbody⟩ => hs ?_)
|
||
rw [hbody]; rfl
|
||
|
||
instance instDecidableIsGlueLine (q : CompQ) : Decidable (IsGlueLine q) := by
|
||
by_cases hs : q.body.skeleton = SkeletalCType.glue
|
||
· obtain ⟨level, env, binder, body, φ, u, t⟩ := q
|
||
simp only at hs
|
||
cases body with
|
||
| univ => simp at hs
|
||
| pi var A B => simp at hs
|
||
| sigma var A B => simp at hs
|
||
| path A a b => simp at hs
|
||
| glue ψ T f fInv s r c A =>
|
||
exact isTrue ⟨ψ, T, f, fInv, s, r, c, A, rfl⟩
|
||
| ind S params => simp at hs
|
||
| interval => simp at hs
|
||
| lift A => simp at hs
|
||
| El P => simp at hs
|
||
| modal k A => simp at hs
|
||
· refine isFalse (fun ⟨_, _, _, _, _, _, _, _, hbody⟩ => hs ?_)
|
||
rw [hbody]; rfl
|
||
|
||
instance (q : CompQ) : Decidable (IsPiLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.pi))
|
||
|
||
instance (q : CompQ) : Decidable (IsSigmaLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.sigma))
|
||
|
||
instance (q : CompQ) : Decidable (IsIndLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.ind))
|
||
|
||
instance instDecidableIsElLine (q : CompQ) : Decidable (IsElLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.El))
|
||
|
||
instance (q : CompQ) (k : ModalityKind) : Decidable (IsModalLine q k) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.modal k))
|
||
|
||
-- ── Classifier-conditioned theorems ─────────────────────────────────────────
|
||
|
||
namespace CompQ
|
||
|
||
/-- C1 in question form. -/
|
||
@[simp]
|
||
theorem ask_of_full_face (q : CompQ) (h : IsFullFace q) :
|
||
q.ask = eval q.env (q.u.substDim q.binder .one) := by
|
||
unfold ask
|
||
rw [show q.φ = .top from h]
|
||
exact eval_comp_top q.env q.binder q.body q.u q.t
|
||
|
||
/-- C2 in question form. -/
|
||
@[simp]
|
||
theorem ask_of_empty_face (q : CompQ) (h : IsEmptyFace q) :
|
||
q.ask = eval q.env (.transp q.binder q.body .bot q.t) := by
|
||
unfold ask
|
||
rw [show q.φ = .bot from h]
|
||
exact eval_comp_bot q.env q.binder q.body q.u q.t
|
||
|
||
/-- Constant-line question: hetero comp reduces to hcomp. -/
|
||
@[simp]
|
||
theorem ask_of_const_line (q : CompQ)
|
||
(hC : IsConstLine q)
|
||
(hφ₁ : ¬ IsFullFace q) (hφ₂ : ¬ IsEmptyFace q) :
|
||
q.ask = vHCompValue q.body q.φ
|
||
(eval q.env (.plam q.binder q.u)) (eval q.env q.t) := by
|
||
unfold ask
|
||
exact eval_comp_const q.env q.binder q.body q.φ q.u q.t hφ₁ hφ₂ hC
|
||
|
||
/-- Helper: dimAbsent rewriting from negation of IsConstLine. -/
|
||
private theorem dimAbsent_eq_false_of_not_isConstLine (q : CompQ)
|
||
(h : ¬ IsConstLine q) :
|
||
CType.dimAbsent q.binder q.body = false := by
|
||
unfold IsConstLine at h
|
||
match hb : CType.dimAbsent q.binder q.body with
|
||
| true => exact absurd hb h
|
||
| false => rfl
|
||
|
||
end CompQ
|
||
|
||
-- ──────────────────────────────────────────────────────────────────────────
|
||
-- TranspQ — transport question
|
||
-- ──────────────────────────────────────────────────────────────────────────
|
||
|
||
/-- Transport question, reified as data. -/
|
||
structure TranspQ where
|
||
/-- Universe level of the type-line `body`. -/
|
||
level : ULevel := .zero
|
||
env : CEnv
|
||
binder : DimVar
|
||
body : CType level
|
||
φ : FaceFormula
|
||
t : CTerm
|
||
|
||
/-- "Asking" a transport question runs the engine on `.transp`. -/
|
||
def TranspQ.ask (q : TranspQ) : CVal :=
|
||
eval q.env (.transp q.binder q.body q.φ q.t)
|
||
|
||
/-- Two transport questions are equivalent when their answers agree. -/
|
||
def TranspQ.Equiv (q₁ q₂ : TranspQ) : Prop := q₁.ask = q₂.ask
|
||
|
||
@[refl] theorem TranspQ.Equiv.refl (q : TranspQ) : q.Equiv q := rfl
|
||
@[symm] theorem TranspQ.Equiv.symm {q₁ q₂ : TranspQ}
|
||
(h : q₁.Equiv q₂) : q₂.Equiv q₁ := Eq.symm h
|
||
theorem TranspQ.Equiv.trans {q₁ q₂ q₃ : TranspQ}
|
||
(h₁ : q₁.Equiv q₂) (h₂ : q₂.Equiv q₃) : q₁.Equiv q₃ := Eq.trans h₁ h₂
|
||
|
||
/-- Bridge: every `TranspQ` is a `CompQ` (with `u = t`). -/
|
||
def TranspQ.toCompQ (q : TranspQ) : CompQ :=
|
||
{ level := q.level, env := q.env, binder := q.binder, body := q.body, φ := q.φ
|
||
, u := q.t, t := q.t }
|
||
|
||
namespace TranspQ
|
||
|
||
@[simp]
|
||
def IsConstLine (q : TranspQ) : Prop := q.body.dimAbsent q.binder = true
|
||
@[simp]
|
||
def IsFullFace (q : TranspQ) : Prop := q.φ = .top
|
||
@[simp]
|
||
def IsEmptyFace (q : TranspQ) : Prop := q.φ = .bot
|
||
@[simp]
|
||
def IsPathLine (q : TranspQ) : Prop :=
|
||
∃ (A₀ : CType q.level) (a b : CTerm), q.body = .path A₀ a b
|
||
@[simp]
|
||
def IsPiLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.pi
|
||
@[simp]
|
||
def IsSigmaLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.sigma
|
||
@[simp]
|
||
def IsGlueLine (q : TranspQ) : Prop :=
|
||
∃ (ψ : FaceFormula) (T : CType q.level) (f fInv s r c : CTerm)
|
||
(A : CType q.level),
|
||
q.body = .glue ψ T f fInv s r c A
|
||
@[simp]
|
||
def IsIndLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.ind
|
||
@[simp]
|
||
def IsIntervalLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.interval
|
||
@[simp]
|
||
def IsUnivLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.univ
|
||
|
||
@[simp]
|
||
def IsElLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.El
|
||
/-- The line is a modality of kind `k` (Refactor Phase 2). -/
|
||
@[simp]
|
||
def IsModalLine (q : TranspQ) (k : ModalityKind) : Prop :=
|
||
q.body.skeleton = SkeletalCType.modal k
|
||
|
||
instance (q : TranspQ) : Decidable (IsConstLine q) :=
|
||
inferInstanceAs (Decidable (q.body.dimAbsent q.binder = true))
|
||
instance (q : TranspQ) : Decidable (IsFullFace q) :=
|
||
inferInstanceAs (Decidable (q.φ = .top))
|
||
instance (q : TranspQ) : Decidable (IsEmptyFace q) :=
|
||
inferInstanceAs (Decidable (q.φ = .bot))
|
||
|
||
instance (q : TranspQ) : Decidable (IsIntervalLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.interval))
|
||
instance (q : TranspQ) : Decidable (IsUnivLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.univ))
|
||
instance (q : TranspQ) : Decidable (IsPiLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.pi))
|
||
instance (q : TranspQ) : Decidable (IsSigmaLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.sigma))
|
||
instance (q : TranspQ) : Decidable (IsIndLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.ind))
|
||
|
||
instance instDecidableTranspIsElLine (q : TranspQ) : Decidable (IsElLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.El))
|
||
|
||
instance (q : TranspQ) (k : ModalityKind) : Decidable (IsModalLine q k) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.modal k))
|
||
|
||
instance instDecidableTranspIsPathLine (q : TranspQ) : Decidable (IsPathLine q) := by
|
||
by_cases hs : q.body.skeleton = SkeletalCType.path
|
||
· obtain ⟨level, env, binder, body, φ, t⟩ := q
|
||
simp only at hs
|
||
cases body with
|
||
| univ => simp at hs
|
||
| pi var A B => simp at hs
|
||
| sigma var A B => simp at hs
|
||
| path A a b => exact isTrue ⟨A, a, b, rfl⟩
|
||
| glue ψ T f fInv s r c A => simp at hs
|
||
| ind S params => simp at hs
|
||
| interval => simp at hs
|
||
| lift A => simp at hs
|
||
| El P => simp at hs
|
||
| modal k A => simp at hs
|
||
· refine isFalse (fun ⟨_, _, _, hbody⟩ => hs ?_)
|
||
rw [hbody]; rfl
|
||
|
||
instance instDecidableTranspIsGlueLine (q : TranspQ) : Decidable (IsGlueLine q) := by
|
||
by_cases hs : q.body.skeleton = SkeletalCType.glue
|
||
· obtain ⟨level, env, binder, body, φ, t⟩ := q
|
||
simp only at hs
|
||
cases body with
|
||
| univ => simp at hs
|
||
| pi var A B => simp at hs
|
||
| sigma var A B => simp at hs
|
||
| path A a b => simp at hs
|
||
| glue ψ T f fInv s r c A =>
|
||
exact isTrue ⟨ψ, T, f, fInv, s, r, c, A, rfl⟩
|
||
| ind S params => simp at hs
|
||
| interval => simp at hs
|
||
| lift A => simp at hs
|
||
| El P => simp at hs
|
||
| modal k A => simp at hs
|
||
· refine isFalse (fun ⟨_, _, _, _, _, _, _, _, hbody⟩ => hs ?_)
|
||
rw [hbody]; rfl
|
||
|
||
/-- T1 in question form: transport under a full face is identity. -/
|
||
@[simp]
|
||
theorem ask_of_full_face (q : TranspQ) (h : IsFullFace q) :
|
||
q.ask = eval q.env q.t := by
|
||
unfold ask; rw [show q.φ = .top from h]
|
||
exact eval_transp_top q.env q.binder q.body q.t
|
||
|
||
/-- T2 in question form: transport along a constant line is identity. -/
|
||
@[simp]
|
||
theorem ask_of_const_line (q : TranspQ)
|
||
(hC : IsConstLine q) (hφ : ¬ IsFullFace q) :
|
||
q.ask = eval q.env q.t := by
|
||
unfold ask
|
||
exact eval_transp_const q.env q.binder q.body q.φ q.t hφ hC
|
||
|
||
end TranspQ
|
||
|
||
-- ──────────────────────────────────────────────────────────────────────────
|
||
-- HCompQ — homogeneous-comp question (value-level)
|
||
-- ──────────────────────────────────────────────────────────────────────────
|
||
|
||
/-- Homogeneous composition question. -/
|
||
structure HCompQ where
|
||
/-- Universe level of the type `body`. -/
|
||
level : ULevel := .zero
|
||
body : CType level
|
||
φ : FaceFormula
|
||
tube : CVal
|
||
base : CVal
|
||
|
||
def HCompQ.ask (q : HCompQ) : CVal := vHCompValue q.body q.φ q.tube q.base
|
||
|
||
def HCompQ.Equiv (q₁ q₂ : HCompQ) : Prop := q₁.ask = q₂.ask
|
||
|
||
@[refl] theorem HCompQ.Equiv.refl (q : HCompQ) : q.Equiv q := rfl
|
||
@[symm] theorem HCompQ.Equiv.symm {q₁ q₂ : HCompQ}
|
||
(h : q₁.Equiv q₂) : q₂.Equiv q₁ := Eq.symm h
|
||
theorem HCompQ.Equiv.trans {q₁ q₂ q₃ : HCompQ}
|
||
(h₁ : q₁.Equiv q₂) (h₂ : q₂.Equiv q₃) : q₁.Equiv q₃ := Eq.trans h₁ h₂
|
||
|
||
namespace HCompQ
|
||
|
||
@[simp]
|
||
def IsFullFace (q : HCompQ) : Prop := q.φ = .top
|
||
@[simp]
|
||
def IsPiLine (q : HCompQ) : Prop := q.body.skeleton = SkeletalCType.pi
|
||
|
||
instance (q : HCompQ) : Decidable (IsFullFace q) :=
|
||
inferInstanceAs (Decidable (q.φ = .top))
|
||
|
||
instance (q : HCompQ) : Decidable (IsPiLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.pi))
|
||
|
||
/-- Full-face hcomp: tube evaluated at `1` is the answer. -/
|
||
@[simp]
|
||
theorem ask_of_full_face (q : HCompQ) (h : IsFullFace q) :
|
||
q.ask = vPApp q.tube .one := by
|
||
unfold ask; rw [show q.φ = .top from h]
|
||
exact vHCompValue_top q.body q.tube q.base
|
||
|
||
end HCompQ
|
||
|
||
-- ──────────────────────────────────────────────────────────────────────────
|
||
-- CompNQ — multi-clause heterogeneous-comp question
|
||
-- ──────────────────────────────────────────────────────────────────────────
|
||
|
||
/-- Multi-clause heterogeneous-comp question. -/
|
||
structure CompNQ where
|
||
/-- Universe level of the type-line `body`. -/
|
||
level : ULevel := .zero
|
||
env : CEnv
|
||
binder : DimVar
|
||
body : CType level
|
||
clauses : List (FaceFormula × CTerm)
|
||
t : CTerm
|
||
|
||
def CompNQ.ask (q : CompNQ) : CVal :=
|
||
vCompNAtTerm q.env q.binder q.body q.clauses q.t
|
||
|
||
def CompNQ.Equiv (q₁ q₂ : CompNQ) : Prop := q₁.ask = q₂.ask
|
||
|
||
@[refl] theorem CompNQ.Equiv.refl (q : CompNQ) : q.Equiv q := rfl
|
||
@[symm] theorem CompNQ.Equiv.symm {q₁ q₂ : CompNQ}
|
||
(h : q₁.Equiv q₂) : q₂.Equiv q₁ := Eq.symm h
|
||
theorem CompNQ.Equiv.trans {q₁ q₂ q₃ : CompNQ}
|
||
(h₁ : q₁.Equiv q₂) (h₂ : q₂.Equiv q₃) : q₁.Equiv q₃ := Eq.trans h₁ h₂
|
||
|
||
namespace CompNQ
|
||
|
||
/-- Bool-valued: does some clause have face `.top`? -/
|
||
def hasTopClause (q : CompNQ) : Bool :=
|
||
q.clauses.any fun ⟨φ, _⟩ => match φ with | .top => true | _ => false
|
||
|
||
/-- The clause list contains some clause whose face is `.top`. -/
|
||
def HasTopClause (q : CompNQ) : Prop := q.hasTopClause = true
|
||
|
||
instance (q : CompNQ) : Decidable (HasTopClause q) :=
|
||
inferInstanceAs (Decidable (q.hasTopClause = true))
|
||
|
||
/-- The list of "live" clauses. -/
|
||
def liveClauses (q : CompNQ) : List (FaceFormula × CTerm) :=
|
||
q.clauses.filter fun ⟨φ, _⟩ => match φ with | .bot => false | _ => true
|
||
|
||
/-- Every clause has face `.bot` (or empty). -/
|
||
def AllBotOrEmpty (q : CompNQ) : Prop := q.liveClauses = []
|
||
|
||
instance (q : CompNQ) : Decidable (AllBotOrEmpty q) :=
|
||
inferInstanceAs (Decidable (q.liveClauses = []))
|
||
|
||
/-- Exactly one live clause. -/
|
||
def IsSingleLive (q : CompNQ) : Prop := ∃ p, q.liveClauses = [p]
|
||
|
||
instance (q : CompNQ) : Decidable (IsSingleLive q) :=
|
||
match h : q.liveClauses with
|
||
| [p] => isTrue ⟨p, h⟩
|
||
| [] => isFalse (fun ⟨_, hp⟩ => by rw [h] at hp; cases hp)
|
||
| _ :: _ :: _ => isFalse (fun ⟨_, hp⟩ => by rw [h] at hp; cases hp)
|
||
|
||
/-- The CompN reduction "anatomy" axiom restated. -/
|
||
theorem ask_def (q : CompNQ) :
|
||
q.ask =
|
||
match q.clauses.find?
|
||
(fun ⟨φ, _⟩ => match φ with | .top => true | _ => false) with
|
||
| some ⟨_, u⟩ => eval q.env (u.substDim q.binder .one)
|
||
| none =>
|
||
let live := q.clauses.filter
|
||
(fun ⟨φ, _⟩ => match φ with | .bot => false | _ => true)
|
||
match live with
|
||
| [] => eval q.env (.transp q.binder q.body .bot q.t)
|
||
| [⟨φ, u⟩] => vCompAtTerm q.env q.binder q.body φ u q.t
|
||
| _ => .vneu (.ncompN q.env q.binder q.body
|
||
(live.map (fun ⟨φ, u⟩ => (φ, eval q.env u)))
|
||
(eval q.env q.t)) := by
|
||
unfold ask
|
||
exact vCompNAtTerm_def q.env q.binder q.body q.clauses q.t
|
||
|
||
end CompNQ
|
||
|
||
end Question
|