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>
582 lines
22 KiB
Text
582 lines
22 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 `.flat` modality. Encoded via the level-erased
|
||
skeleton tag. -/
|
||
@[simp]
|
||
def IsFlatLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.flat
|
||
|
||
/-- The line is a `.sharp` modality. -/
|
||
@[simp]
|
||
def IsSharpLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.sharp
|
||
|
||
/-- The line is a `.shape` modality. -/
|
||
@[simp]
|
||
def IsShapeLine (q : CompQ) : Prop :=
|
||
q.body.skeleton = SkeletalCType.shape
|
||
|
||
-- ── 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
|
||
| flat A => simp at hs
|
||
| sharp A => simp at hs
|
||
| shape 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
|
||
| flat A => simp at hs
|
||
| sharp A => simp at hs
|
||
| shape 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) : Decidable (IsFlatLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.flat))
|
||
|
||
instance (q : CompQ) : Decidable (IsSharpLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.sharp))
|
||
|
||
instance (q : CompQ) : Decidable (IsShapeLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.shape))
|
||
|
||
-- ── 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
|
||
@[simp]
|
||
def IsFlatLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.flat
|
||
@[simp]
|
||
def IsSharpLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.sharp
|
||
@[simp]
|
||
def IsShapeLine (q : TranspQ) : Prop := q.body.skeleton = SkeletalCType.shape
|
||
|
||
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) : Decidable (IsFlatLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.flat))
|
||
instance (q : TranspQ) : Decidable (IsSharpLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.sharp))
|
||
instance (q : TranspQ) : Decidable (IsShapeLine q) :=
|
||
inferInstanceAs (Decidable (q.body.skeleton = SkeletalCType.shape))
|
||
|
||
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
|
||
| flat A => simp at hs
|
||
| sharp A => simp at hs
|
||
| shape 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
|
||
| flat A => simp at hs
|
||
| sharp A => simp at hs
|
||
| shape 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
|