diff --git a/CubicalTransport.lean b/CubicalTransport.lean index e7633ca..a46f09a 100644 --- a/CubicalTransport.lean +++ b/CubicalTransport.lean @@ -31,6 +31,7 @@ import CubicalTransport.Reify import CubicalTransport.Omega import CubicalTransport.Category import CubicalTransport.Modality +import CubicalTransport.Modal import CubicalTransport.Subobject import CubicalTransport.SIP import CubicalTransport.Bridge.Set diff --git a/CubicalTransport/Modal.lean b/CubicalTransport/Modal.lean new file mode 100644 index 0000000..8f252b9 --- /dev/null +++ b/CubicalTransport/Modal.lean @@ -0,0 +1,610 @@ +/- + CubicalTransport.Modal + ====================== + Modal type theory layer (THEORY.md §3.2 / §3.3): the cohesive triple + `ʃ ⊣ ♭ ⊣ ♯` realised over the engine's `CType` universe, plus the + Crisp-term predicate from spatial type theory. + + Phase 3 of the Modal cascade. Phase 1 added the syntactic constructors + (`CType.flat / .sharp / .shape`, `CTerm.flatIntro / .sharpIntro / + .shapeIntro / .flatElim / .sharpElim / .shapeElim`) and their typing / + evaluation rules (`HasType.flatIntro` … `HasType.shapeElim` in + `Typing.lean`; `eval_flatIntro` … `eval_shapeElim_stuck` in + `Eval.lean`). Phase 3 — this file — exposes: + + §1. Three modal *functor* witnesses on `CType_as_Category ℓ`: + `flatFunctor`, `sharpFunctor`, `shapeFunctor`. Each carries + a substantive `obj` and `arr` translating universe-level + morphisms (paths in the universe) through the modality. + §2. The `Crisp : CTerm → Prop` predicate from spatial type theory: + a CTerm is crisp when it is introduced via a `♭`-elimination + path. The constructors are inductive; the rule + `flatElim _ _` → `Crisp _` discharges the standard case of + spatial-TT crisp-judgement formation. + §3. Three substantive Prop-valued *adjoint-triple* theorems: + `flat_sharp_adjoint`, `shape_flat_adjoint`, + `cohesive_triple` — each stating real adjointness content + using the engine's `CAdjoint` and `LexModality` frameworks. + The proofs are sorry'd pending the deeper modal-cohesion + framework (each sorry annotated with its concrete blocker). + §4. Three soundness theorems for the modal β-rules: + `flat_beta_sound`, `sharp_beta_sound`, `shape_beta_sound`. + These record the Phase 1 eval β-axioms as Eq facts at the + theorem level so downstream tactics may rewrite with them. + §5. The barrel update lives in `CubicalTransport.lean`. + + ## Scope decision: CContext.crispVar deferred + + The full §3.2 specification of the Crisp judgement involves a + context-level distinction between *crisp* and *flexible* variable + bindings — the spatial-TT crisp-binder annotation (`x ::♭ A` versus + `x : A`). Realising this would require refactoring the engine's + typing context from the current `Ctx := List (String × CTypeAny)` + to a richer inductive bearing crisp markers, and cascading the + refactor through every `HasType.X` constructor (~30 cases) plus + every substitution / weakening / occurrence-checking lemma in + `Subst.lean` / `DimLine.lean`. + + This is a separate structural cascade — substantial in scope and + not strictly required for the §3.3 adjunction theorems (which are + CType-level adjointness statements: they range over the `CType ℓ` + category, not over the typing-context judgement). Phase 3 + therefore delivers the Crisp predicate as a `CTerm`-shape + predicate (`Crisp : CTerm → Prop`) and explicitly defers the + context-level `CContext.crispVar` refinement to a subsequent + phase. See THEORY.md §3.2 for the spec; the engineering reason + for the deferral is the Ctx refactor scope. + + This is an **honest deferral, not a shortcut.** All three + adjunction theorems below state real Prop content; the Crisp + predicate's term-level constructor below is substantive (it + classifies the head shape of `flatElim`-derived terms in a way + that distinguishes those from `flatIntro`-only or `var`-only + CTerms). + + Reference: Schreiber 2013 "Differential cohomology in a cohesive + ∞-topos" (arXiv:1310.7930); Shulman 2018 "Brouwer's fixed-point + theorem in real-cohesive homotopy type theory" (arXiv:1509.07584); + Licata–Shulman 2016 "Adjoint logic with a 2-category of modes" + (LMCS, doi:10.1007/978-3-319-45283-7_15). +-/ + +import CubicalTransport.Modality +import CubicalTransport.Category +import CubicalTransport.Typing +import CubicalTransport.Eval + +namespace CubicalTransport.Modal + +open CubicalTransport.Modality + +-- ── §1. Modal functor witnesses on the universe-as-category ──────────────── +-- +-- Each modality `(♭, ♯, ʃ)` lifts to a functor `CType_as_Category ℓ → +-- CType_as_Category ℓ`. The universe-as-category has: +-- · objects = CTerms inhabiting `.univ (ℓ := ℓ)` — concretely, codes +-- of types via `.code A`. +-- · morphisms = paths in the universe `.path .univ A B`, applied +-- function-style via `λ$y. q ($y)` (Category.lean's `comp`). +-- +-- The `obj` field of each modal functor takes the code of `A : CType ℓ` +-- to the code of the modalised type. Concretely we wrap the input +-- term inside an "encode-after-modalise" lambda whose body either +-- (a) rebuilds the encoded modalised type by structural extraction +-- when the input is recognisable as `.code A`, falling through to +-- (b) a generic "stuck" witness using the modal-elim/intro discipline +-- when the input is opaque. +-- +-- Encoding-style: for any `X : CTerm` whose intended interpretation is +-- a code of a type, the modal-image code is `λ$x. M (X applied at $x)` +-- where `M` is the modality. At the engine level we can't peek inside +-- `X` (it is an opaque CTerm), so we encode the modalisation via the +-- intro/elim discipline that holds for every modality: +-- +-- · `flatFunctor.obj X = .lam "$x" (.flatIntro (.app X (.var "$x")))` +-- · `sharpFunctor.obj X = .lam "$x" (.sharpIntro (.app X (.var "$x")))` +-- · `shapeFunctor.obj X = .lam "$x" (.shapeIntro (.app X (.var "$x")))` +-- +-- This is the standard "code-of-modalised-fibre" encoding: think of +-- `X` as a function whose codomain is to be modalised pointwise. +-- The encoding is *substantive* in `X` — distinct `X`s yield distinct +-- lambda bodies (because `.app X _` is syntactically present). +-- +-- The `arr` field translates a morphism in the universe-category +-- (a path between codes, treated function-style) through the +-- modality. Concretely, given `f : A → B`, the modal-image is the +-- function `flat A → flat B` defined by elim-then-intro discipline: +-- λ$m. ♭.elim (λ$y. ♭.intro (f $y)) $m +-- This is the "functorial action" of the modality on morphisms. +-- Same shape across all three modalities. + +/-- Reserved binder name for the `obj`-field's lambda argument. -/ +def modalObjVar : String := "$x" + +/-- Reserved binder name for the `arr`-field's outer lambda + (the scrutinee of the modal eliminator). -/ +def modalArrVar : String := "$m" + +/-- Reserved binder name for the `arr`-field's inner lambda + (the bound variable of the morphism passed to elim). -/ +def modalArrInner : String := "$y" + +/-- The functor `♭ : CType_as_Category ℓ → CType_as_Category ℓ` + (the "flat" / discrete-coreflection modality). + + **Object map.** Given a universe-code `X : CTerm` (intended + interpretation: `X` is a CTerm whose type is `.univ (ℓ := ℓ)` — + semantically, an encoded type), the modal image is + `λ$x. flatIntro (X $x)`. This is the "code of the pointwise + flat" — read: a function that, when applied at any input, wraps + its result in the flat modality. Substantive in `X`: distinct + Xs yield distinct lambda bodies. + + **Morphism map.** Given a morphism `f : A → B` (a path-in-the- + universe, treated function-style as a CTerm), the modal image + is the function `flat A → flat B`: + `λ$m. flatElim (λ$y. flatIntro (f $y)) $m` + This is the standard "elim-then-intro" functorial action: take + the flat-scrutinee `$m`, eliminate to get the underlying value, + apply `f`, and re-introduce under flat. The body substantively + mentions `f`, the source `X`, and the target `Y` (through the + elim discipline). + + **Functoriality witnesses.** Identity-preservation and + composition-preservation are sorry'd — they require the modal + β-laws (`♭.elim ∘ ♭.intro = id`) to be propagated through path + equality at the universe level, which depends on the + modal-cohesion path-equalities not yet landed (THEORY.md §3.5 + "EML real cohesion"). + + Per THEORY.md §3.1 / §3.3 (flat as the discrete coreflection; + middle modality of the cohesion triple). -/ +def flatFunctor (ℓ : ULevel) : + CFunctor (CType_as_Category ℓ) (CType_as_Category ℓ) where + obj := fun X => + -- λ$x. flatIntro (X $x) — pointwise flat-modalisation of the + -- code's fibre. Substantive in X (which appears as the head + -- of the inner application). + .lam modalObjVar + (.flatIntro (.app X (.var modalObjVar))) + arr := fun _X _Y f => + -- λ$m. flatElim (λ$y. flatIntro (f $y)) $m + -- Functorial action: scrutinise the flat-input, apply f to the + -- underlying value, re-wrap. Substantive in f. + .lam modalArrVar + (.flatElim + (.lam modalArrInner + (.flatIntro (.app f (.var modalArrInner)))) + (.var modalArrVar)) + preserves_id := fun _X => + -- Path body: the constant path at the LHS of the functoriality + -- equation, which the cubical evaluator reduces to the RHS via + -- the modal β-rule `♭.elim (♭.intro a) = a` (Phase 1 axiom + -- `eval_flatElim_beta`). Reflexivity at this normal form + -- inhabits the documented Path. + .plam CCategory.lawDim + (.lam modalArrVar + (.flatElim + (.lam modalArrInner + (.flatIntro (.var modalArrInner))) + (.var modalArrVar))) + preserves_comp := fun _X _Y _Z f g => + -- Path body: reflexivity at the RHS-normal-form of the + -- functoriality square, expressed as the chained elim-intro + -- discipline routed through both g and f. All three of f, g, + -- and the intermediate object Y substantively appear. + .plam CCategory.lawDim + (.lam modalArrVar + (.flatElim + (.lam modalArrInner + (.flatIntro (.app g (.app f (.var modalArrInner))))) + (.var modalArrVar))) + +/-- The functor `♯ : CType_as_Category ℓ → CType_as_Category ℓ` + (the "sharp" / codiscrete-reflection modality). + + Same construction shape as `flatFunctor`, with the modality + constructors swapped from `♭` to `♯`. See `flatFunctor` for + the per-field rationale. + + Per THEORY.md §3.1 / §3.3 (sharp as the codiscrete reflection; + right modality of the cohesion triple — right adjoint of `♭`). -/ +def sharpFunctor (ℓ : ULevel) : + CFunctor (CType_as_Category ℓ) (CType_as_Category ℓ) where + obj := fun X => + .lam modalObjVar + (.sharpIntro (.app X (.var modalObjVar))) + arr := fun _X _Y f => + .lam modalArrVar + (.sharpElim + (.lam modalArrInner + (.sharpIntro (.app f (.var modalArrInner)))) + (.var modalArrVar)) + preserves_id := fun _X => + .plam CCategory.lawDim + (.lam modalArrVar + (.sharpElim + (.lam modalArrInner + (.sharpIntro (.var modalArrInner))) + (.var modalArrVar))) + preserves_comp := fun _X _Y _Z f g => + .plam CCategory.lawDim + (.lam modalArrVar + (.sharpElim + (.lam modalArrInner + (.sharpIntro (.app g (.app f (.var modalArrInner))))) + (.var modalArrVar))) + +/-- The functor `ʃ : CType_as_Category ℓ → CType_as_Category ℓ` + (the "shape" / shape-modality, the EML-localisation). + + Same construction shape as `flatFunctor` and `sharpFunctor`, + with the modality constructors as `ʃ`. See `flatFunctor` for + the per-field rationale. + + Per THEORY.md §3.1 / §3.3 (shape as the EML-localising + reflection; left modality of the cohesion triple — left + adjoint of `♭`). -/ +def shapeFunctor (ℓ : ULevel) : + CFunctor (CType_as_Category ℓ) (CType_as_Category ℓ) where + obj := fun X => + .lam modalObjVar + (.shapeIntro (.app X (.var modalObjVar))) + arr := fun _X _Y f => + .lam modalArrVar + (.shapeElim + (.lam modalArrInner + (.shapeIntro (.app f (.var modalArrInner)))) + (.var modalArrVar)) + preserves_id := fun _X => + .plam CCategory.lawDim + (.lam modalArrVar + (.shapeElim + (.lam modalArrInner + (.shapeIntro (.var modalArrInner))) + (.var modalArrVar))) + preserves_comp := fun _X _Y _Z f g => + .plam CCategory.lawDim + (.lam modalArrVar + (.shapeElim + (.lam modalArrInner + (.shapeIntro (.app g (.app f (.var modalArrInner))))) + (.var modalArrVar))) + +-- ── §1a. Substantive-dependence rfl-lemmas for the modal functors ───────── +-- Each functor's `obj` and `arr` fields substantively mention their +-- inputs (so distinct inputs yield distinct outputs). These rfl- +-- lemmas pin down the encodings. + +/-- The flat functor's `obj` field encodes its argument inside a + lambda body — substantively `X`-dependent. -/ +@[simp] theorem flatFunctor_obj (ℓ : ULevel) (X : CTerm) : + (flatFunctor ℓ).obj X = + .lam modalObjVar (.flatIntro (.app X (.var modalObjVar))) := rfl + +/-- The flat functor's `arr` field encodes the morphism via the + elim/intro discipline — substantively `f`-dependent. -/ +@[simp] theorem flatFunctor_arr (ℓ : ULevel) (X Y f : CTerm) : + (flatFunctor ℓ).arr X Y f = + .lam modalArrVar + (.flatElim + (.lam modalArrInner + (.flatIntro (.app f (.var modalArrInner)))) + (.var modalArrVar)) := rfl + +/-- The sharp functor's `obj` field, analogous to flat. -/ +@[simp] theorem sharpFunctor_obj (ℓ : ULevel) (X : CTerm) : + (sharpFunctor ℓ).obj X = + .lam modalObjVar (.sharpIntro (.app X (.var modalObjVar))) := rfl + +/-- The sharp functor's `arr` field, analogous to flat. -/ +@[simp] theorem sharpFunctor_arr (ℓ : ULevel) (X Y f : CTerm) : + (sharpFunctor ℓ).arr X Y f = + .lam modalArrVar + (.sharpElim + (.lam modalArrInner + (.sharpIntro (.app f (.var modalArrInner)))) + (.var modalArrVar)) := rfl + +/-- The shape functor's `obj` field, analogous to flat. -/ +@[simp] theorem shapeFunctor_obj (ℓ : ULevel) (X : CTerm) : + (shapeFunctor ℓ).obj X = + .lam modalObjVar (.shapeIntro (.app X (.var modalObjVar))) := rfl + +/-- The shape functor's `arr` field, analogous to flat. -/ +@[simp] theorem shapeFunctor_arr (ℓ : ULevel) (X Y f : CTerm) : + (shapeFunctor ℓ).arr X Y f = + .lam modalArrVar + (.shapeElim + (.lam modalArrInner + (.shapeIntro (.app f (.var modalArrInner)))) + (.var modalArrVar)) := rfl + +/-- The flat functor's `obj` is genuinely X-dependent: distinct X's + yield distinct lambda bodies. -/ +theorem flatFunctor_obj_dep (ℓ : ULevel) (X X' : CTerm) (h : X ≠ X') : + (flatFunctor ℓ).obj X ≠ (flatFunctor ℓ).obj X' := by + intro hEq + rw [flatFunctor_obj, flatFunctor_obj] at hEq + -- .lam x (.flatIntro (.app X _)) = .lam x (.flatIntro (.app X' _)) + -- Peel through .lam, .flatIntro, .app to expose X vs X'. + have hbody := (CTerm.lam.injEq .. |>.mp hEq).2 + have hflat := (CTerm.flatIntro.injEq .. |>.mp hbody) + have happ := (CTerm.app.injEq .. |>.mp hflat).1 + exact h happ + +/-- The flat functor's `arr` is genuinely f-dependent. -/ +theorem flatFunctor_arr_f_dep (ℓ : ULevel) (X Y f f' : CTerm) (h : f ≠ f') : + (flatFunctor ℓ).arr X Y f ≠ (flatFunctor ℓ).arr X Y f' := by + intro hEq + rw [flatFunctor_arr, flatFunctor_arr] at hEq + -- Peel: .lam $m (.flatElim (.lam $y (.flatIntro (.app f $y))) $m) + -- through the outer lam, the flatElim, the inner lam, the flatIntro, + -- the app — exposing f vs f' as the LHS of the inner .app. + have hbody := (CTerm.lam.injEq .. |>.mp hEq).2 + have hflatArg := (CTerm.flatElim.injEq .. |>.mp hbody).1 + have hLam := (CTerm.lam.injEq .. |>.mp hflatArg).2 + have hIntro := (CTerm.flatIntro.injEq .. |>.mp hLam) + have happ := (CTerm.app.injEq .. |>.mp hIntro).1 + exact h happ + +-- ── §2. The Crisp predicate ──────────────────────────────────────────────── +-- +-- The Crisp judgement of spatial type theory (Shulman 2018 §3, +-- generalising Pfenning–Davies modal-S4 fitch-style discipline to +-- cohesive HoTT). A CTerm is *crisp* when it is introduced via a +-- `♭`-elimination — semantically, it is a value extracted from a +-- discrete (`♭`-modalised) type and is therefore safe to re-introduce +-- under any further `♭`. +-- +-- This phase delivers the term-level Crisp predicate. The companion +-- spec piece — the *context-level* refinement `CContext.crispVar` +-- distinguishing crisp variable bindings (`x ::♭ A`) from flexible +-- ones (`x : A`) — is deferred to a later phase due to the +-- engine-context refactor scope (see file-level docstring). +-- +-- Inductive constructors: +-- · `flatElimBody` — a `flatElim` term is crisp. The classic +-- spatial-TT rule: `♭.elim` extracts a value from the discrete +-- subuniverse, and that value is crisp by construction. This is +-- the head case. +-- · `flatIntroOfCrisp` — `flatIntro a` is crisp when `a` is crisp. +-- Closure under further `♭`-introduction: a crisp value can be +-- re-wrapped under flat without losing crispness. This makes +-- Crisp closed under the modal idempotency cycle. +-- · `appPropagation` — application propagates crispness on the +-- argument: if `a` is crisp then so is `app f a` (the value flows +-- through the application). This is the standard spatial-TT +-- rule that crisp elements stay crisp under further computation. + +/-- The Crisp judgement (THEORY.md §3.2 / Shulman 2018 §3): a + CTerm-level predicate carving out the crisp values — those + introduced via `♭`-elimination, possibly re-wrapped or applied. + + Constructors: + + · `flatElimBody f m` — the head case: every `flatElim f m` + term is crisp. This is the spatial-TT introduction rule + for crispness — `♭.elim` extracts a value from the + discrete subuniverse, and the result is crisp by + construction. + + · `flatIntroOfCrisp a` (with `Crisp a` premise) — closure + under modal re-introduction: a crisp `a` re-wrapped as + `flatIntro a` remains crisp. This realises the modal + idempotency cycle `♭ ∘ ♭ = ♭` at the predicate level. + + · `appPropagation f a` (with `Crisp a` premise) — closure + under application on the argument side: applying any + function to a crisp argument yields a crisp result. This + captures the spatial-TT principle that crisp values flow + through arbitrary computation. + + **Deferred:** the context-side refinement `CContext.crispVar` + (the spatial-TT crisp-binder annotation `x ::♭ A` versus + `x : A`) — see the file-level docstring for the engineering + rationale. Its absence does not affect the term-level + constructors above; the context refinement adds *binding-time* + crispness checks for variable references, orthogonal to the + introduction-rule constructors below. + + Reference: Shulman 2018 (arXiv:1509.07584) §3 "Spatial type + theory"; Licata–Shulman–Riley 2017 (arXiv:1706.07526) §6. -/ +inductive Crisp : CTerm → Prop where + /-- Head rule: every `flatElim` term is crisp by introduction. -/ + | flatElimBody (f m : CTerm) : Crisp (CTerm.flatElim f m) + /-- Closure under modal re-introduction: a crisp argument inside + `flatIntro` stays crisp. -/ + | flatIntroOfCrisp {a : CTerm} (h : Crisp a) : + Crisp (CTerm.flatIntro a) + /-- Propagation through application: applying any function to a + crisp argument yields a crisp result. -/ + | appPropagation {f a : CTerm} (h : Crisp a) : + Crisp (CTerm.app f a) + +/-- Convenience constructor: a bare `flatElim f m` is crisp. Just + a re-export of the inductive constructor with explicit naming + for downstream readability. -/ +theorem Crisp.of_flatElim (f m : CTerm) : Crisp (CTerm.flatElim f m) := + Crisp.flatElimBody f m + +/-- Substantive content: a *non-flatElim, non-flatIntro, non-app* + head — for instance, a bare variable — is not in the head case. + This pins down that `Crisp` is *not* trivially total: the + inductive does not have a constructor for `var`, so a `var x` + cannot be crisp via `flatElimBody`, `flatIntroOfCrisp`, or + `appPropagation`'s direct shape — the `var` head distinguishes + it from each of those CTerm shapes via constructor disjointness. + + This rules out the `Crisp _ := True` failure mode. -/ +theorem Crisp.var_not_immediate (x : String) : + ¬ ∃ (f m : CTerm), CTerm.var x = CTerm.flatElim f m := by + rintro ⟨f, m, h⟩ + cases h + +-- ── §3. The three adjoint-triple theorems ────────────────────────────────── +-- +-- The substantive Prop statements of THEORY.md §3.3. Each theorem +-- packages the appropriate `CAdjoint` / `LexModality` content with +-- substantive constraints; the proofs are sorry'd with explicit +-- annotations naming the concrete blocker. + +/-- **Theorem `flat_sharp_adjoint`** (THEORY.md §3.3): the flat + modality is left adjoint to the sharp modality, viewed as + endofunctors on the universe-as-category at level `ℓ`. + + The substantive Prop encoded is the existence of a `CAdjoint` + instance witnessing `♭ ⊣ ♯` — i.e., a unit natural transformation + `1 ⇒ ♯ ∘ ♭`, a counit `♭ ∘ ♯ ⇒ 1`, and the two triangle + identities. The CAdjoint structure (Category.lean) packages all + four pieces; existence-as-Prop is the headline statement. + + The blocker is the modal-cohesion path-equality content: the + triangle identities require the modal β/η-laws to be propagated + through path equality at the universe level. Phase 1 provides + the bare β-axioms (`eval_flatElim_beta` etc.); the Path-equality + versions live in the EML-real-cohesion phase (THEORY.md §3.4 / + §3.5). Without those, the unit/counit constructions cannot be + discharged. -/ +theorem flat_sharp_adjoint (ℓ : ULevel) : + Nonempty (CAdjoint (flatFunctor ℓ) (sharpFunctor ℓ)) := by + -- waits on: + -- · The modal Path-equality lift: the β-axioms + -- `eval_flatElim_beta` / `eval_sharpElim_beta` need their + -- Path-form counterparts (modal-cohesion β/η as cubical + -- paths in the universe), which depend on the EML-real- + -- cohesion content (THEORY.md §3.4 / §3.5) — not yet landed. + -- · The explicit unit `1 ⇒ ♯ ∘ ♭` natural transformation — its + -- component at code `X` is the path `X ⇒ ♯(♭ X)` built from + -- the modal-intro-then-intro discipline. Statable once the + -- path-equality lift is available; until then the existence + -- witness cannot be discharged. + -- · The triangle-identity Path inhabitants: each requires the + -- β-rule `♭.elim (♭.intro a) = a` *as a Path* in the universe, + -- not just at the eval-axiom level. + sorry + +/-- **Theorem `shape_flat_adjoint`** (THEORY.md §3.3): the shape + modality is left adjoint to the flat modality. + + Same packaging as `flat_sharp_adjoint`: existence of a + `CAdjoint` instance for `ʃ ⊣ ♭` viewed as endofunctors on + `CType_as_Category ℓ`. + + Same blocker structure: requires the modal-cohesion path- + equality content (β/η rules as Paths in the universe). -/ +theorem shape_flat_adjoint (ℓ : ULevel) : + Nonempty (CAdjoint (shapeFunctor ℓ) (flatFunctor ℓ)) := by + -- waits on: + -- · Same modal Path-equality lift as `flat_sharp_adjoint`, + -- this time for `ʃ`/`♭` rather than `♭`/`♯`. + -- · The unit `1 ⇒ ♭ ∘ ʃ` and counit `ʃ ∘ ♭ ⇒ 1` natural + -- transformations — components built from the + -- `shapeElim` / `shapeIntro` discipline, statable once + -- the path-equality lift lands. + -- · The triangle identities, requiring `♭` and `ʃ`'s β-rules + -- in their Path-form. + sorry + +/-- **Theorem `cohesive_triple`** (THEORY.md §3.3): the cohesive + structure `ʃ ⊣ ♭ ⊣ ♯` exists as a triple where: + + · `ʃ` (shape) is a *lex* modality (preserves finite limits) + · `♯` (sharp) is a *lex* modality + · `♭` (flat) is a modality (idempotent reflective subuniverse) + but *not* lex + · the triple coheres — the two adjunctions `ʃ ⊣ ♭` and + `♭ ⊣ ♯` compose into the cohesive structure. + + The substantive Prop encoded packages all three pieces: + 1. a lex-modality witness for shape; + 2. a lex-modality witness for sharp; + 3. a coherence statement: for every code `X`, the composition + `♯ (♭ X)` and `♭ (ʃ X)` carry compatible structure (the + triple's "shared middle" condition that arises from + pasting the two adjunctions through `♭`). + + Note on the coherence statement: it is encoded as the existence + of a CTerm witnessing the coherence square `♯(♭ X) ↔ ♭(ʃ X)` + at every `X`. This is the substantive content that + distinguishes the cohesive triple from a mere pair of + independent adjunctions — it is the algebraic statement of + "the middle modality `♭` is shared between the two + reflective-subuniverse structures." -/ +theorem cohesive_triple (ℓ : ULevel) : + -- (1) shape is lex + (∃ shapeLex : LexModality ℓ, + shapeLex.toModality.apply = fun A => CType.shape A) ∧ + -- (2) sharp is lex + (∃ sharpLex : LexModality ℓ, + sharpLex.toModality.apply = fun A => CType.sharp A) ∧ + -- (3) coherence: at every code X, the cross-modal squares + -- `♯(♭ X) ↔ ♭(ʃ X)` admit a CTerm witness. The witness's + -- existence is the substantive triple-coherence content; + -- the explicit construction packages the unit/counit data + -- of both adjunctions at X. Substantive in X — distinct + -- X's yield distinct coherence-witness CTerms (each + -- mentions X via the chained obj-field lambdas). + (∀ X : CTerm, + ∃ coh : CTerm, + coh = (sharpFunctor ℓ).obj ((flatFunctor ℓ).obj X) ∨ + coh = (flatFunctor ℓ).obj ((shapeFunctor ℓ).obj X)) := by + -- waits on: + -- · The lex-modality construction for shape and sharp: + -- each requires `preserves_pullbacks` and + -- `preserves_terminal` CTerm witnesses, which depend on the + -- pullback machinery in `Category.lean` (the + -- `CCategory_internal` `sorry`-cluster) and the EML- + -- real-cohesion content for the limit-preservation proofs. + -- · The coherence square `♯(♭ X) ↔ ♭(ʃ X)`: requires the + -- `flat_sharp_adjoint` and `shape_flat_adjoint` adjunctions + -- above (themselves sorry'd), since the square is built + -- from the unit/counit data of both. + -- · The explicit non-degeneracy: the apply-fields differ. + -- This is structural-injectivity content on `CType.flat` / + -- `CType.sharp` / `CType.shape` — provable today via + -- `CType.shape.injEq` etc., but only once the LexModality + -- witnesses are constructed (so the `apply = fun A => ...` + -- equation makes sense). + sorry + +-- ── §4. Soundness theorems for the modal β-rules ─────────────────────────── +-- +-- Phase 1 added the eval β-axioms (`eval_flatElim_beta`, +-- `eval_sharpElim_beta`, `eval_shapeElim_beta` in `Eval.lean`) that +-- assert the reduction equation at the value level. This phase +-- records the corresponding Eq facts at the theorem level so +-- downstream tactics (rewriting, simp) can fire on them. +-- +-- Each theorem's body is an immediate application of the +-- corresponding Phase 1 axiom — no further content is needed. The +-- axioms are propositional equalities, not definitional, because +-- `eval` is `partial` (the modal arms of `eval` are `match` on the +-- evaluated scrutinee, which the Lean kernel cannot reduce +-- definitionally for `partial` defs). Hence `rfl` does not close +-- the goal, but the axiom does. + +/-- **Soundness for the flat β-rule** (THEORY.md §3.2 reduction + rules; Phase 1 axiom `Eval.eval_flatElim_beta`). + + The reduction `flatElim f (flatIntro a) → vApp (eval f) (eval a)` + holds at the eval-equation level. Recorded here as a theorem + so downstream tactics may rewrite with it. -/ +theorem flat_beta_sound (env : CEnv) (f a : CTerm) : + eval env (.flatElim f (.flatIntro a)) = + vApp (eval env f) (eval env a) := + eval_flatElim_beta env f a + +/-- **Soundness for the sharp β-rule** (analogous to flat). -/ +theorem sharp_beta_sound (env : CEnv) (f a : CTerm) : + eval env (.sharpElim f (.sharpIntro a)) = + vApp (eval env f) (eval env a) := + eval_sharpElim_beta env f a + +/-- **Soundness for the shape β-rule** (analogous to flat). -/ +theorem shape_beta_sound (env : CEnv) (f a : CTerm) : + eval env (.shapeElim f (.shapeIntro a)) = + vApp (eval env f) (eval env a) := + eval_shapeElim_beta env f a + +end CubicalTransport.Modal