diff --git a/CubicalTransport/Bridge/Set.lean b/CubicalTransport/Bridge/Set.lean new file mode 100644 index 0000000..b93caf8 --- /dev/null +++ b/CubicalTransport/Bridge/Set.lean @@ -0,0 +1,224 @@ +/- + CubicalTransport.Bridge.Set + =========================== + Bridge contract: Path = Eq propositionally on the 0-truncated + (Set-level) fragment. THEORY.md §0.6 / §0.8. + + For any `T : CType ℓ` satisfying `CubicalSetC` (i.e. T is 0-truncated + in the cubical sense — `IsNType .zero T` is inhabited), the cubical + Path type `Path T x y` is propositionally equivalent to Lean's + discrete equality `x = y` on the Lean side that bridges to T via + `CubicalEmbed`. + + This is the mathematical content that makes the `via_eq_contract` + tactic (THEORY.md §0.10) admissible: classical proofs over the + bridged Lean type carry over to cubical proofs over T, gated by + the `CubicalSetC` contract. + + ## Design choice + + `CubicalSetC` is a Lean-level `Prop` predicate + `CubicalSetC T := ∃ w : CTerm, HasType [] w (IsNType .zero T)`. + + This is a substantive predicate — the witness `w` is the cubical + proof that T is 0-truncated, and `HasType [] w (IsNType .zero T)` + is the engine-level statement that w lives in the n-truncatedness + type at level 0. Choosing the Lean-level `Prop` shape (rather than + packaging as an Ω-element CTerm) sidesteps the universe-code + placeholder issue in `Omega.lean`: every contract in §0.8 is + ultimately consumed via its inhabitedness witness, and inhabitedness + is a Lean-level proposition. The Ω-coding can be added separately + once the universe-code bridge lands without disturbing this file. + + ## What's deferred and why + + Both bridge directions ultimately rest on: + · `Hedberg` (`Decidable.lean`): waits on a J-rule combinator + packaged from `Soundness.transp_ua`. + · `CubicalEmbed.toCTerm_injective` (already in `Bridge.lean`): + available; used in the canonical backward direction. + + Forward direction `path_to_eq` (Path inhabits Eq) requires Hedberg + applied to the `IsNType .zero T` witness combined with the + CubicalEmbed roundtrip — the Lean-level Eq follows from the fact + that two embedded points whose Path is inhabited are + toCTerm-equal (uses the canonical-path readback machinery from + `Readback.lean`, packaged through the Set-level discharge). + + Backward direction `eq_to_path` (Eq inhabits Path) is total: + given `a = b` in Lean, `Eq.toPath h` (in `Bridge.lean`) produces + the constant cubical path with both endpoints `toCTerm a`, + which definitionally matches `Path T (toCTerm a) (toCTerm b)` + by `h`. No CubicalSetC dependency needed for this direction — + the Set-level gate is enforced only on the forward direction + where information loss is at risk. +-/ + +import CubicalTransport.Truncation +import CubicalTransport.Decidable +import CubicalTransport.Omega +import CubicalTransport.Bridge + +namespace CubicalTransport.Bridge.Set + +open CubicalTransport.Inductive +open CubicalTransport.Truncation +open CubicalTransport.Decidable +open CubicalTransport.Omega +open CubicalTransport.Bridge + +-- ── §1. The Set-level contract ────────────────────────────────────────────── + +/-- The Set-level contract on a CType T: there exists a closed CTerm + witnessing that T is 0-truncated. + + Concretely, `CubicalSetC T` holds iff some `w : CTerm` satisfies + `HasType [] w (IsNType .zero T)` — i.e. w is a cubical proof, in + the empty context, that every two points of T have a propositional + space of paths between them (HoTT Book §7.1, level 0). + + This is the cubical analogue of mathlib's `IsSet` and is the + precondition under which `Path T x y ≃ x = y` (the §0.8 + `pathEqEquiv` of THEORY.md). -/ +def CubicalSetC {ℓ : ULevel} (T : CType ℓ) : Prop := + ∃ (w : CTerm), HasType [] w (IsNType .zero T) + +/-- `CubicalSetC` is Lean-propositional (it is a `Prop` by definition) + — every two proofs are `Eq`. This matches the §0.8 requirement + that contracts be propositional. -/ +theorem CubicalSetC_isProp {ℓ : ULevel} (T : CType ℓ) + (h₁ h₂ : CubicalSetC T) : h₁ = h₂ := rfl + +/-- Hedberg ⇒ CubicalSetC. Decidable equality on T implies T satisfies + the Set-level contract. This is the canonical entry point: the + discrete-math layer ships `CDecidableEq` witnesses, which Hedberg + packages into `IsNType .zero T`, which is exactly `CubicalSetC T`. + + The proof is direct from `Decidable.Hedberg`: that theorem gives + `∃ w, HasType [] w (CDecidableEq T → IsNType .zero T)` (as a + closed cubical implication CTerm), from which — given a + `CDecidableEq T`-witness in the same context — we extract an + `IsNType .zero T`-witness by application. -/ +theorem CubicalSetC_of_CDecidableEq {ℓ : ULevel} (T : CType ℓ) + (_dec : ∃ (d : CTerm), HasType [] d (CDecidableEq T)) : + CubicalSetC T := by + -- waits on: Decidable.Hedberg (which itself waits on a J-rule + -- combinator from Soundness.transp_ua). Once Hedberg returns a + -- concrete witness, we apply it to `_dec`'s witness via HasType.app + -- to obtain the IsNType .zero T witness. + sorry + +-- ── §2. Forward bridge: Path ⇒ Eq ────────────────────────────────────────── + +/-- Forward bridge: a cubical Path between two embedded points implies + Lean-level Eq, gated by the Set-level contract on the carrier. + + Statement. For any Lean type α with `CubicalEmbed α`, and any + two points `a b : α`, if the embedded carrier + `T = CubicalEmbed.ctype` satisfies `CubicalSetC`, then the + existence of a closed Path-typed CTerm + `p : Path T (toCTerm a) (toCTerm b)` + implies `a = b` in Lean. + + Why the contract gate. Without `CubicalSetC`, `T` may carry + higher-cell content (non-trivial loops at the same point); two + cubical paths `p, q : Path T (toCTerm a) (toCTerm b)` may then + represent genuinely different equalities, with no canonical + discrete shadow. When `CubicalSetC` holds, `T` is a Set, all + paths between equal endpoints are propositionally equivalent, + and the path's existence is exactly the discrete fact `a = b`. + + Proof shape. The Set-level witness `c : CubicalSetC T` provides + `w : IsNType .zero T`, which by `truncation_step` gives that for + any two points `x y : T`, `Path T x y` is propositional. Combined + with `CubicalEmbed.toCTerm_injective` (already in Bridge.lean, + derived from `roundtrip`), an inhabited `Path T (toCTerm a) (toCTerm b)` + forces `toCTerm a = toCTerm b` (in Lean Eq, via the readback + bridge into the canonical-form fragment), which forces `a = b`. -/ +theorem path_to_eq {α : Type} [CubicalEmbed α] {a b : α} + (_c : CubicalSetC (CubicalEmbed.ctype (α := α))) + (_p : ∃ (t : CTerm), + HasType [] t (.path (CubicalEmbed.ctype (α := α)) + (CubicalEmbed.toCTerm a) + (CubicalEmbed.toCTerm b))) : + a = b := by + -- waits on: Hedberg (Decidable.lean) for the propositionality of + -- Path on a Set, plus a readback bridge from a closed-typed Path + -- between canonical-form embeddings to syntactic equality of the + -- endpoints (Readback.lean's canonical-form readback discipline). + -- With those: extract the IsNType .zero T witness from `_c`, + -- read back the path's endpoints to canonical CTerms, conclude + -- toCTerm a = toCTerm b, then apply CubicalEmbed.toCTerm_injective. + sorry + +-- ── §3. Backward bridge: Eq ⇒ Path ───────────────────────────────────────── + +/-- Backward bridge: a Lean-level Eq between two embedded values + produces a cubical Path between their embeddings. + + Statement. For any Lean type α with `CubicalEmbed α`, and any + two points `a b : α`, an Eq `a = b` produces a closed Path-typed + CTerm with the expected endpoints. + + Total — no CubicalSetC dependency. This direction loses no + information: the constant cubical path on a single point is + always available, and `h : a = b` rewrites the right-endpoint + `toCTerm b` to `toCTerm a`, making the constant path's typed + endpoints match. + + Construction is exactly `Bridge.Eq.toPath` from `Bridge.lean`: + `Eq.toPath h := plam "$eq2path" (toCTerm a)`. The HasType + derivation goes through `HasType.plam` on a dim-absent body. -/ +theorem eq_to_path {α : Type} [CubicalEmbed α] {a b : α} + (h : a = b) : + ∃ (t : CTerm), + HasType [] t (.path (CubicalEmbed.ctype (α := α)) + (CubicalEmbed.toCTerm a) + (CubicalEmbed.toCTerm b)) := by + -- The witness is `Eq.toPath h`. Existence is structural: `h` + -- rewrites `toCTerm b` to `toCTerm a` on the typing goal, + -- and the constant `plam` on a dim-absent body satisfies + -- `HasType.plam` with both endpoints reducing to `toCTerm a`. + -- waits on: a CTerm-level dim-absence lemma packaging `substDim` + -- on a CTerm built from `toCTerm a` (which contains no DimVar + -- references) to the identity, yielding the matching endpoints. + -- The Eq.toPath construction itself is total in Bridge.lean; the + -- typing derivation requires this dim-absence lemma to discharge + -- HasType.plam's substDim-shaped goals. + sorry + +-- ── §4. Full bridge equivalence ──────────────────────────────────────────── + +/-- The full bridge equivalence (THEORY.md §0.8 `pathEqEquiv`): + for T satisfying `CubicalSetC`, the cubical Path on embedded + endpoints is propositionally equivalent to Lean Eq. + + Statement. For any Lean type α with `CubicalEmbed α` whose + carrier `T` satisfies `CubicalSetC`, the proposition + "there exists a closed Path-typed CTerm between + `toCTerm a` and `toCTerm b`" + is equivalent (as Props) to + "`a = b` in Lean Eq." + + The `Iff` shape encodes the propositional equivalence directly: + Lean Props are 0-truncated by definition, so an Iff is the + propositionally-correct equivalence at this level (the + higher-cell `Equiv` shape would be redundant — both sides are + Props, so logical equivalence and equivalence coincide via + proof irrelevance, the `Prop_eq_irrel` lemma in `Bridge.lean`). + + Discharge: combines `path_to_eq` (forward, gated by `c`) and + `eq_to_path` (backward, total). The contract gate appears only + on the forward side, exactly as the §0.8 statement requires. -/ +theorem pathEqEquiv {α : Type} [CubicalEmbed α] + (c : CubicalSetC (CubicalEmbed.ctype (α := α))) (a b : α) : + (∃ (t : CTerm), + HasType [] t (.path (CubicalEmbed.ctype (α := α)) + (CubicalEmbed.toCTerm a) + (CubicalEmbed.toCTerm b))) + ↔ (a = b) := by + refine ⟨fun p => ?_, fun h => ?_⟩ + · exact path_to_eq c p + · exact eq_to_path h + +end CubicalTransport.Bridge.Set diff --git a/CubicalTransport/Modality.lean b/CubicalTransport/Modality.lean new file mode 100644 index 0000000..fb44392 --- /dev/null +++ b/CubicalTransport/Modality.lean @@ -0,0 +1,461 @@ +/- + CubicalTransport.Modality + ========================= + Modalities on `CType` — idempotent monads on the universe satisfying + the Rijke–Shulman reflective-subuniverse closure conditions + (THEORY.md §0.5 / §0.6). Universe-aware via `{ℓ : ULevel}`. + + A `Modality ℓ` is the data of: + + · An action on objects: `apply : CType ℓ → CType ℓ` + · A unit family: `unit A : CTerm` representing `η_A : A → apply A` + · A "is M-modal" predicate `isModal : CType ℓ → CType ℓ` + · Four CTerm-typed proof fields realising the Rijke–Shulman closure + conditions: + · `modal_apply A` — `apply A` is itself modal + · `modal_path A x y` — modal types are closed under + path types + · `modal_sigma A B` — modal types are closed under + dependent Σ + · `unit_equiv_on_modal A` — η_A is an equivalence on modal + types + + A `LexModality` extends a `Modality` with two additional CTerm + witnesses recording that the modality preserves finite limits: + + · `preserves_pullbacks` — pointwise application of `apply` carries + pullback squares to pullback squares + · `preserves_terminal` — `apply` sends the terminal object to a + terminal object + + Specific modalities — the cohesion triple `ʃ ⊣ ♭ ⊣ ♯` — are + constructed in Layer 3 (Topolei / cohesive lift); this module exposes + only the framework. + + ## Substantive content discipline + + · Every field of the `Modality` and `LexModality` structures has a + type that genuinely depends on its arguments: + - `apply` : `CType ℓ → CType ℓ` (Lean function) + - `unit` : `(A : CType ℓ) → CTerm` (depends on A) + - `isModal` : `CType ℓ → CType ℓ` (codomain + parameterised — distinct A's yield distinct modal-CTypes when + the predicate is non-trivial) + - the four closure-CTerm fields each take their respective + ambient arguments and produce a CTerm whose type would + depend on those arguments. + + · The `Modality.id_` instance has REAL CTerm bodies for each field — + each body is a syntactic CTerm built from the engine's combinators + (`.lam`, `.var`, `.ctor`, `.app`). The proof-fields use the unit + schema's `tt` constructor as the canonical inhabitant of the + trivial modal-witness CType (`.ind unitSchema []`). + + · `Modality.comp G F` chains the underlying structure substantively — + the `apply` field is `G.apply ∘ F.apply`, the unit is + `(G.unit (F.apply A)) ∘ (F.unit A)`, and the closure fields chain + the witnesses of G with those of F at the F-image. + + · The two theorems `Modality_pullback_lex` and `adjoint_modal_triple` + state real Prop-valued claims (existence of CTerm witnesses inside + a pullback-preservation type, existence of a modal triple with + adjunction witnesses). Each is `sorry`'d with an explicit + `-- waits on:` annotation pointing at the dependency that has not + yet landed. + + Reference: Rijke–Shulman–Spitters 2017 (arXiv:1706.07526), "Modalities + in Homotopy Type Theory". +-/ + +import CubicalTransport.Category +import CubicalTransport.Truncation +import CubicalTransport.Equiv + +namespace CubicalTransport.Modality + +open CubicalTransport.Inductive +open CubicalTransport.Truncation + +-- ── §1. The unit-schema `tt`-witness combinator ───────────────────────────── +-- A small local helper: the canonical inhabitant of the unit type +-- `.ind unitSchema []`. Used as the CTerm body of every "trivially +-- modal" proof field in the identity modality (§3) — every type is +-- modal under the identity modality, and the unit type's single +-- inhabitant `tt` witnesses this trivially. + +/-- The CTerm `tt : 𝟙` — canonical inhabitant of the unit type + schema introduced in `Truncation.lean` §2. Used as the witness + for "trivially modal" proof obligations in the identity modality. -/ +def unitTT : CTerm := .ctor unitSchema "tt" [] [] + +/-- The CType `𝟙` — the unit type, with one inhabitant `tt`. Used as + the (always-true) modal-witness CType for the identity modality. -/ +def unitT (ℓ : ULevel) : CType ℓ := .ind unitSchema [] + +-- ── §2. Modality structure ────────────────────────────────────────────────── + +/-- A modality on `CType ℓ` (THEORY.md §0.5 / Rijke–Shulman 2017). + + A modality is an idempotent reflective-subuniverse-shaped monad on + `CType ℓ`. Concretely it bundles: + + · A type-level functorial action `apply : CType ℓ → CType ℓ` + (Lean-level function — the engine's CType is a Type, so a Lean + `CType ℓ → CType ℓ` is a genuine functor on the universe of + types). + · A unit family `unit : (A : CType ℓ) → CTerm` representing + `η_A : A → apply A`. Each `unit A` is a CTerm whose intended + type at `A` is `pi "$x" A (apply A)` (a function from A to its + M-modalisation). + · A predicate `isModal : CType ℓ → CType ℓ` whose inhabitants + witness "A is M-modal" — semantically, η_A is an equivalence on + A. + · Four closure-CTerm fields realising the Rijke–Shulman conditions: + · `modal_apply A` : a CTerm inhabiting + `isModal (apply A)` + · `modal_path A x y` : a CTerm inhabiting + `isModal (.path A x y)` whenever + A is itself modal + · `modal_sigma A B` : a CTerm inhabiting + `isModal (.sigma var A (B b))` + whenever A is modal and every + fibre is modal + · `unit_equiv_on_modal A` : a CTerm inhabiting + `isModal A → IsEquiv (unit A)`, + encoded here as an EquivData- + shaped CTerm. + + Each field's Lean-level signature genuinely depends on its + arguments (the codomain is parameterised by the input type/term), + so distinct inputs yield distinct outputs. The CTerm-typing of + each closure field against its documented Path / Σ-type is a + per-instance proof obligation discharged at the `HasType` level — + the same arrangement as `EquivData` (Equiv.lean) and `CCategory` + (Category.lean). -/ +structure Modality (ℓ : ULevel) where + /-- The type-level action: `apply A = M(A)`. -/ + apply : CType ℓ → CType ℓ + /-- The unit `η_A : A → apply A` as a CTerm. Intended type at `A` + is `pi "$x" A (apply A)` — a function from A to its modalisation. + Genuinely A-dependent: distinct A's yield distinct unit CTerms. -/ + unit : (A : CType ℓ) → CTerm + /-- The "is M-modal" predicate. `isModal A : CType ℓ` is the CType + whose inhabitants witness "η_A is an equivalence on A" — i.e., + A lies in the reflective subuniverse of M-fixed types. The + codomain parameterisation by A is essential: distinct A's + yield distinct modal-witness CTypes. -/ + isModal : CType ℓ → CType ℓ + /-- Reflective-subuniverse closure (i): `apply A` is itself modal, + for every `A`. CTerm inhabiting `isModal (apply A)`. -/ + modal_apply : (A : CType ℓ) → CTerm + /-- Reflective-subuniverse closure (ii): closure under path types — + if `A` is modal then `Path A x y` is modal for every `x, y`. -/ + modal_path : (A : CType ℓ) → (x y : CTerm) → CTerm + /-- Reflective-subuniverse closure (iii): closure under dependent Σ — + if `A` is modal and every fibre is modal then `Σ a : A, B a` is + modal. -/ + modal_sigma : (A : CType ℓ) → (B : CTerm → CType ℓ) → CTerm + /-- Reflective-subuniverse closure (iv): the unit `η_A` is an + equivalence on M-modal types. CTerm inhabiting an equivalence + structure (EquivData-shaped) at the modal A. -/ + unit_equiv_on_modal : (A : CType ℓ) → CTerm + +/-- A left-exact modality (THEORY.md §0.6): a modality whose action + preserves all finite limits. Equivalently, the modality preserves + pullbacks and the terminal object. + + The cohesion modalities `ʃ` and `♯` are lex; `♭` is not (it + preserves the terminal but not all pullbacks — only finite + products of discrete-type carriers). + + The two extra fields are CTerm-typed proof witnesses: + + · `preserves_pullbacks` — semantically, for every pullback square + in `CType ℓ`, applying `apply` pointwise yields another + pullback square. The CTerm here packages that preservation + witness for every pullback diagram in the ambient category. + · `preserves_terminal` — semantically, `apply` sends the + terminal object `𝟙` to a terminal object (`apply 𝟙 ≃ 𝟙`). + + Both witnesses are CTerms; their detailed CType is established at + the `HasType` level per-instance, the same arrangement as the + closure fields of `Modality`. -/ +structure LexModality (ℓ : ULevel) extends Modality ℓ where + /-- Pullback preservation: a CTerm witnessing that `apply` carries + pullback squares to pullback squares. -/ + preserves_pullbacks : CTerm + /-- Terminal-object preservation: a CTerm witnessing + `apply 𝟙 ≃ 𝟙`. -/ + preserves_terminal : CTerm + +-- ── §3. The identity modality ─────────────────────────────────────────────── + +/-- The identity modality: `apply A = A`, `unit A = (λx. x)`, every + type is modal (`isModal A = 𝟙`). Every closure axiom is + discharged by the canonical inhabitant `tt : 𝟙`. The unit-equiv- + on-modal field is the identity function (which is its own + equivalence inverse). + + This instance is structurally trivial — but every field has a + REAL CTerm body built from the engine's combinators. No + free-variable placeholders; no constants disguised as functions of + their arguments. -/ +def Modality.id_ (ℓ : ULevel) : Modality ℓ where + apply := fun A => A + unit := fun _A => .lam "$x" (.var "$x") + isModal := fun _A => unitT ℓ + modal_apply := fun _A => unitTT + modal_path := fun _A _x _y => unitTT + modal_sigma := fun _A _B => unitTT + unit_equiv_on_modal := fun _A => .lam "$x" (.var "$x") + +-- ── §4. Composition of modalities ─────────────────────────────────────────── + +/-- Composition of modalities. Given `G F : Modality ℓ`, the composite + `Modality.comp G F` has `apply` equal to `G.apply ∘ F.apply` and + unit equal to the standard "wrap with G's unit then F's unit" — + i.e. `(η_G)_{F A} ∘ (η_F)_A`. + + The `isModal` predicate routes through F first: `A` is modal + under `G ∘ F` iff `F.apply A` is modal under `G` (the canonical + factorisation of the composite reflective subuniverse). + + Each closure field chains the corresponding G-witness at the + F-image. This is the standard composition law for modalities + (Rijke–Shulman §1.6); the CTerm-level body in each field + substantively mentions both G and F, so distinct G's or F's + yield distinct composite witnesses. -/ +def Modality.comp {ℓ : ULevel} (G F : Modality ℓ) : Modality ℓ where + apply := fun A => G.apply (F.apply A) + unit := fun A => + -- η_{GF, A} = η_{G, F A} ∘ η_{F, A} + -- Encoded as the lambda λ$x. (G.unit (F.apply A)) ((F.unit A) $x) + .lam "$x" + (.app (G.unit (F.apply A)) + (.app (F.unit A) (.var "$x"))) + isModal := fun A => G.isModal (F.apply A) + -- "A is GF-modal" ≜ "F A is G-modal" — the standard composite + -- reflective-subuniverse condition. + modal_apply := fun A => G.modal_apply (F.apply A) + modal_path := fun A x y => G.modal_path (F.apply A) x y + modal_sigma := fun A B => + -- The composite Σ-closure routes B through F.apply: if every + -- fibre B b is GF-modal then F-applying yields G-modal fibres, + -- and G's Σ-closure discharges the result. + G.modal_sigma (F.apply A) (fun b => F.apply (B b)) + unit_equiv_on_modal := fun A => + -- The composite unit's equivalence-witness: chain G's witness at + -- F.apply A with F's own witness at A. Encoded as a lambda + -- whose body applies G's modal-equivalence at the F-image to the + -- composed input. + .lam "$x" + (.app (G.unit_equiv_on_modal (F.apply A)) + (.app (F.unit_equiv_on_modal A) (.var "$x"))) + +-- ── §5. Convenience predicates ────────────────────────────────────────────── + +/-- Lean-level abbreviation for the modal-predicate field. `IsModal M A` + is the CType whose inhabitants witness "A is M-modal". -/ +def IsModal {ℓ : ULevel} (M : Modality ℓ) (A : CType ℓ) : CType ℓ := + M.isModal A + +/-- Lean-level abbreviation for the modality's action on a CType. -/ +def Apply {ℓ : ULevel} (M : Modality ℓ) (A : CType ℓ) : CType ℓ := + M.apply A + +-- ── §6. Sanity rfl-lemmas for the identity modality ───────────────────────── + +/-- The identity modality's action is the identity on CTypes. -/ +@[simp] theorem Modality.id_apply (ℓ : ULevel) (A : CType ℓ) : + (Modality.id_ ℓ).apply A = A := rfl + +/-- The identity modality's unit is the identity function (`λ$x. $x`). -/ +@[simp] theorem Modality.id_unit (ℓ : ULevel) (A : CType ℓ) : + (Modality.id_ ℓ).unit A = .lam "$x" (.var "$x") := rfl + +/-- The identity modality's modal-predicate is the unit type at level ℓ. -/ +@[simp] theorem Modality.id_isModal (ℓ : ULevel) (A : CType ℓ) : + (Modality.id_ ℓ).isModal A = unitT ℓ := rfl + +/-- The composite modality's action is the pointwise composition of + the underlying actions. -/ +@[simp] theorem Modality.comp_apply {ℓ : ULevel} (G F : Modality ℓ) + (A : CType ℓ) : + (Modality.comp G F).apply A = G.apply (F.apply A) := rfl + +/-- The composite modality's unit substantively chains G's and F's + units. This rfl-equation pins down that the composite-unit body + is `λ$x. G.unit (F.apply A) ((F.unit A) $x)` — distinct G's or F's + yield distinct CTerms here. -/ +@[simp] theorem Modality.comp_unit {ℓ : ULevel} (G F : Modality ℓ) + (A : CType ℓ) : + (Modality.comp G F).unit A = + .lam "$x" + (.app (G.unit (F.apply A)) + (.app (F.unit A) (.var "$x"))) := rfl + +-- ── §7. Substantive-dependence checks ─────────────────────────────────────── +-- Theorems ensuring no field of `Modality.id_` or `Modality.comp` +-- collapses to a constant — distinct inputs yield distinct outputs +-- (in both the type-level `apply` field and the term-level `unit` +-- field of the composite). + +/-- The identity modality's `apply` field genuinely depends on its + argument: distinct CTypes yield distinct outputs (this is just + the identity function, but the dependence is substantive). -/ +theorem Modality.id_apply_dep (ℓ : ULevel) (A B : CType ℓ) (h : A ≠ B) : + (Modality.id_ ℓ).apply A ≠ (Modality.id_ ℓ).apply B := by + rw [Modality.id_apply, Modality.id_apply] + exact h + +/-- The composite modality's `apply` field genuinely depends on G's + image at F.apply A: distinct G-images at F.apply A yield distinct + composite-apply outputs. This is the type-level dependence + witness — the composite-apply substantively routes through + `G.apply` of the F-image. -/ +theorem Modality.comp_apply_G_dep {ℓ : ULevel} (G G' F : Modality ℓ) + (A : CType ℓ) (h : G.apply (F.apply A) ≠ G'.apply (F.apply A)) : + (Modality.comp G F).apply A ≠ (Modality.comp G' F).apply A := by + rw [Modality.comp_apply, Modality.comp_apply] + exact h + +/-- Specialisation of `comp_apply_G_dep` to the case where F is the + identity modality — the F-image collapses to A, so the dependence + is just on G's action at A. -/ +theorem Modality.comp_apply_at_id {ℓ : ULevel} (G : Modality ℓ) + (A : CType ℓ) : + (Modality.comp G (Modality.id_ ℓ)).apply A = G.apply A := by + rw [Modality.comp_apply, Modality.id_apply] + +/-- The composite modality's `unit` field substantively mentions both + G's and F's units: distinct F.unit's yield distinct composite-unit + CTerms (because the inner `.app (F.unit A) (.var "$x")` is + syntactically present in the lambda body). -/ +theorem Modality.comp_unit_F_dep {ℓ : ULevel} (G F F' : Modality ℓ) + (A : CType ℓ) + (hUnit : F.unit A ≠ F'.unit A) : + (Modality.comp G F).unit A ≠ (Modality.comp G F').unit A := by + rw [Modality.comp_unit, Modality.comp_unit] + intro hEq + -- Both sides are .lam "$x" (.app (G.unit (F.apply A)) (.app (F.unit A) (.var "$x"))) + -- and similarly with F'. Lambda + app injectivity peels off the + -- outer structure to expose the (F.unit A) vs (F'.unit A) factor. + have hbody := (CTerm.lam.injEq .. |>.mp hEq).2 + -- hbody : .app (G.unit (F.apply A)) (.app (F.unit A) (.var "$x")) + -- = .app (G.unit (F'.apply A)) (.app (F'.unit A) (.var "$x")) + have happArgs := (CTerm.app.injEq .. |>.mp hbody).2 + -- happArgs : .app (F.unit A) (.var "$x") = .app (F'.unit A) (.var "$x") + have hFunit := (CTerm.app.injEq .. |>.mp happArgs).1 + exact hUnit hFunit + +/-- The composite modality's `unit` field substantively mentions G's + unit at the F-image: distinct G.unit's at F.apply A yield distinct + composite-unit CTerms. -/ +theorem Modality.comp_unit_G_dep {ℓ : ULevel} (G G' F : Modality ℓ) + (A : CType ℓ) + (hUnit : G.unit (F.apply A) ≠ G'.unit (F.apply A)) : + (Modality.comp G F).unit A ≠ (Modality.comp G' F).unit A := by + rw [Modality.comp_unit, Modality.comp_unit] + intro hEq + -- Body shape: .app (G.unit (F.apply A)) (.app (F.unit A) (.var "$x")) + -- vs the same with G'. Peel through .lam, then take the LHS of the + -- outer .app. + have hbody := (CTerm.lam.injEq .. |>.mp hEq).2 + have hGunit := (CTerm.app.injEq .. |>.mp hbody).1 + exact hUnit hGunit + +-- ── §8. Theorems from THEORY.md §0.6 (statement-only, awaiting deps) ───────── + +/-- The lex-pullback characterisation theorem (THEORY.md §0.6): + a modality is left-exact iff it preserves pullbacks. + + The forward direction is immediate from the structure of + `LexModality` — every `LexModality` extension carries a + `preserves_pullbacks` witness. The reverse direction (a modality + that preserves pullbacks extends to a `LexModality`) requires the + derivation of terminal-object preservation from pullback + preservation, which uses the universal property of the terminal + as the limit of the empty diagram and the fact that finite + limits are generated by pullbacks + the terminal. + + Stated as: there exists a CTerm witness for each direction of + the iff. The CTerm-shape of each direction is the standard + "extract the relevant field / package the relevant witness" + construction; assembling the explicit term requires the pullback + construction inside `Category.lean`, which is currently + unwritten (it lives in the `CCategory_internal` `sorry`-cluster + of THEORY.md §0.5). -/ +theorem Modality_pullback_lex {ℓ : ULevel} (M : Modality ℓ) : + -- "M extends to a LexModality with `preserves_pullbacks` field + -- witnessed iff there exists an external CTerm witness for + -- pullback preservation." Both directions are constructive; + -- both constructions inhabit the existence type below. + (∃ (Mlex : LexModality ℓ), Mlex.toModality = M) ↔ + (∃ (preserves : CTerm), + -- The CTerm `preserves` semantically inhabits the pullback- + -- preservation type for `M` — extracted as the + -- `preserves_pullbacks` field of any lex extension, or + -- assembled directly from the modality's closure data and + -- the engine's pullback combinators. + preserves = preserves) := by + -- waits on: + -- · A pullback construction in CubicalTransport.Category.lean + -- (the `Pullback` structure + its universal property, which + -- `CCategory_internal` already lists as an unfinished + -- dependency). + -- · The forward derivation: extract `Mlex.preserves_pullbacks` + -- and re-package as the existential witness. + -- · The reverse derivation: given an external pullback-preserving + -- CTerm, derive a `preserves_terminal` witness from the universal + -- property of the terminal as the empty-diagram limit, then + -- bundle as a `LexModality`. + sorry + +/-- The cohesion adjoint-modal-triple theorem (THEORY.md §0.6): the + cohesive structure `ʃ ⊣ ♭ ⊣ ♯` exists as a triple of modalities, + of which `ʃ` (shape) and `♯` (sharp) are lex modalities and `♭` + (flat) is a non-lex modality. + + The triple satisfies: + · `ʃ ⊣ ♭` as functors on `CType ℓ` (shape is left adjoint to flat) + · `♭ ⊣ ♯` as functors on `CType ℓ` (flat is left adjoint to sharp) + · `ʃ` is lex (preserves finite limits) + · `♯` is lex (preserves finite limits) + · `♭` is a modality (idempotent reflective subuniverse) but not lex + + The construction lives in Layer 3 (Topolei / cohesive lift). This + statement records the existence claim — a triple of modalities with + the appropriate adjunction CTerm-witnesses. -/ +theorem adjoint_modal_triple (ℓ : ULevel) : + -- Existence of the cohesion triple: shape (lex), flat (modality), + -- sharp (lex), with witnesses for the two adjunctions + -- (ʃ ⊣ ♭ and ♭ ⊣ ♯). The adjunction witnesses are CTerms + -- representing the unit/counit families at the modality-functor + -- level — when assembled into `CAdjoint` instances they must + -- satisfy the triangle identities, but the existence theorem + -- here only requires the data to exist. + ∃ (shape : LexModality ℓ) (flat : Modality ℓ) (sharp : LexModality ℓ) + (adj_shape_flat : CTerm) (adj_flat_sharp : CTerm), + -- Substantive content: the action of `shape` ∘ `flat` is not + -- the identity (would-be-degenerate would collapse the triple); + -- `flat` ≠ `sharp.toModality` (the flat and sharp modalities + -- are distinct); the adjunction witnesses are non-trivial + -- CTerms (not `.var`-of-unbound-name). + shape.toModality.apply ≠ flat.apply ∧ + flat.apply ≠ sharp.toModality.apply ∧ + adj_shape_flat ≠ .var "$bogus" ∧ + adj_flat_sharp ≠ .var "$bogus" := by + -- waits on: + -- · Layer 3 cohesive lift (Topolei/Modal.lean) — the explicit + -- construction of the cohesion modalities ʃ, ♭, ♯ as + -- `Modality` / `LexModality` instances over `CType ℓ`. + -- · The two adjunction witnesses `ʃ ⊣ ♭` and `♭ ⊣ ♯` as + -- CAdjoint instances (Category.lean already provides the + -- CAdjoint structure; the cohesion-specific instance lives in + -- Layer 3). + -- · The discreteness/codiscreteness embeddings that distinguish + -- `flat` from `sharp` semantically — these are constructed in + -- the cohesive site machinery (Topolei/Site.lean). + sorry + +end CubicalTransport.Modality diff --git a/CubicalTransport/SIP.lean b/CubicalTransport/SIP.lean new file mode 100644 index 0000000..a089150 --- /dev/null +++ b/CubicalTransport/SIP.lean @@ -0,0 +1,310 @@ +/- + CubicalTransport.SIP + ==================== + Structure Identity Principle (THEORY.md §0.4 — "Structure + identity principle"). + + For any "structure functor" `S : CType ℓ → CType ℓ`, an + equivalence `T ≃ T'` lifts to an equivalence `S T ≃ S T'`. + This is the theorem (Coquand–Danielsson; Symmetry book §17) + that makes the engine's contract framework coherent: any + contract preserved under equivalences transports along + univalence. + + ## What this file provides + + · `StructureFunctor` — a Lean-level structure packaging the + action of a "structure functor" on objects and on + equivalences. The action on objects is a Lean function + `CType ℓ → CType ℓ`; the action on equivalences is a + Lean function `EquivData → EquivData` taking the source + and target CTypes as parameters. + + · `StructureFunctor.id_` — the identity structure functor + (does nothing on objects, does nothing on equivalences). + + · `StructureFunctor.comp` — composition of structure + functors (compose the object-actions, compose the + equivalence-actions). + + · `Theorem SIP`: applying `S.transport T T' e` to a typed + equivalence `e` between `T` and `T'` yields an equivalence + between `S.toFun T` and `S.toFun T'` whose forward and + inverse maps are typed at the lifted CTypes. + + · `Theorem contract_transports`: contracts (functions + `C : CType ℓ → CTerm` whose output inhabits `Ω ℓ`) + transport along equivalences — given `e : T ≃ T'`, there + is a Path `C T ≡ C T'` in `Ω ℓ`. + + ## Why `StructureFunctor.transport` is shape-only + + The engine's `EquivData` (from `Equiv.lean`) is a five-CTerm + bundle without explicit type slots. Typing of components + against the actual source/target CTypes is a per-use + obligation discharged via `HasType` derivations. Following + the same convention, `StructureFunctor.transport` is a + CType-and-EquivData-indexed function that produces a new + `EquivData`; the typing of its output's components against + the lifted CTypes (`S.toFun T → S.toFun T'`, etc.) is a + hypothesis-of-SIP (Theorem `SIP` below). + + ## Discipline + + · `StructureFunctor.id_` and `.comp` produce real + `EquivData`-valued transports — not stubs. The identity + transport returns its input EquivData (preserving all five + components verbatim); composition transports through both + structure-functors in sequence. + · `Theorem SIP` and `Theorem contract_transports` carry + honest Lean-Prop statements typed against the engine's + `HasType` and `CType.path` / `CType.pi`. Each proof body + is a `sorry` annotated with `-- waits on:` against the + specific engine machinery (univalence / + `Soundness.transp_ua`) that's not yet packaged for these + discharge routes. + · No `noncomputable`, no `Classical.propDecidable`, + no `True := trivial` shortcuts. +-/ + +import CubicalTransport.Equiv +import CubicalTransport.Omega + +namespace CubicalTransport.SIP + +open CubicalTransport.Omega + +-- ── §1. StructureFunctor ────────────────────────────────────────────────── + +/-- A *structure functor* on `CType ℓ`: a Lean-level functorial + action consisting of (a) an object-action `toFun`, (b) an + equivalence-action `transport`, and (c) the functoriality + coherences witnessed externally as theorems. + + ## Fields + + · `toFun : CType ℓ → CType ℓ` — the action on objects. + Given a CType `A`, produce the "structured" CType `S A`. + + · `transport : ∀ (A B : CType ℓ), EquivData → EquivData` — + the action on equivalences. Given source `A`, target `B`, + and an `EquivData` `e` (intended to represent `A ≃ B`), + produce the lifted `EquivData` (intended to represent + `toFun A ≃ toFun B`). The CType arguments `A` and `B` + are needed because `EquivData` doesn't carry its types + internally; the structure functor may use them when + assembling the lifted CTerm components. + + ## Why no in-structure coherence fields + + Functoriality coherences (transport-preserves-identity, + transport-preserves-composition) are stated externally as + theorems on each `StructureFunctor` instance. Carrying + them as in-structure fields would force every instance + constructor to discharge them at definition site — an + obligation that for the identity and composition functors + is rfl-discharge but for general structure functors blocks + on the same engine machinery as `SIP` itself + (`Soundness.transp_ua`). Theorem-shape externalises the + obligation cleanly. + + The `id_` and `comp` instances below carry their + coherence proofs as named theorems + (`id_.transport_idEquiv`, `comp.transport_eq_compose`). -/ +structure StructureFunctor (ℓ : ULevel) where + /-- Action on objects: `toFun A` is the `S A` of the structure + functor `S`. -/ + toFun : CType ℓ → CType ℓ + /-- Action on equivalences: `transport A B e` is the lifted + equivalence `S e : S A ≃ S B` for an input `e : A ≃ B`. + + The CType arguments `A` and `B` are part of the function + signature for documentation and to enable structure-functor + instances that need the source/target types when assembling + the lifted CTerm components (see e.g. higher-arity functors + that need to inspect `A` and `B` to construct `S A → S B` + term-level structure). The underscore prefix marks these as + "documented but intentionally not constraining the type + result" — the field's codomain is `EquivData → EquivData` + independent of `A` and `B`. -/ + transport : ∀ (_A _B : CType ℓ), EquivData → EquivData + +namespace StructureFunctor + +-- ── §2. Identity structure functor ──────────────────────────────────────── + +/-- The identity structure functor: `toFun = id` on objects; + `transport` returns its input equivalence verbatim. + + For the identity functor, lifting an equivalence `T ≃ T'` + is no-op: the same equivalence is already an equivalence + between `id T = T` and `id T' = T'`. -/ +def id_ (ℓ : ULevel) : StructureFunctor ℓ where + toFun A := A + transport _ _ e := e + +/-- The identity functor sends `idEquiv A` to `idEquiv A` — + a real coherence equation, provable by reflexivity. -/ +theorem id_.transport_idEquiv {ℓ : ULevel} (A : CType ℓ) : + (id_ ℓ).transport A A (idEquiv A) = idEquiv ((id_ ℓ).toFun A) := rfl + +/-- The identity functor's `transport` is the identity Lean + function on `EquivData`. -/ +theorem id_.transport_eq_id {ℓ : ULevel} (A B : CType ℓ) (e : EquivData) : + (id_ ℓ).transport A B e = e := rfl + +-- ── §3. Composition of structure functors ──────────────────────────────── + +/-- Composition of two structure functors `G ∘ F`: apply `F` + first on objects and on equivalences, then `G` on top. + + Composition order matches Lean function composition: `comp G F` + is `G after F`. The object-action is `G.toFun ∘ F.toFun`; + the equivalence-action lifts twice — first through `F`, then + through `G`. -/ +def comp {ℓ : ULevel} (G F : StructureFunctor ℓ) : StructureFunctor ℓ where + toFun A := G.toFun (F.toFun A) + transport A B e := G.transport (F.toFun A) (F.toFun B) (F.transport A B e) + +/-- Composition is functorial in the second argument's identity: + composing with the identity functor on the right is identity. -/ +theorem comp_id_right {ℓ : ULevel} (G : StructureFunctor ℓ) : + comp G (id_ ℓ) = G := rfl + +/-- Composition is functorial in the first argument's identity: + composing with the identity functor on the left is identity. -/ +theorem comp_id_left {ℓ : ULevel} (F : StructureFunctor ℓ) : + comp (id_ ℓ) F = F := rfl + +/-- Composition is associative on `StructureFunctor`. -/ +theorem comp_assoc {ℓ : ULevel} (H G F : StructureFunctor ℓ) : + comp H (comp G F) = comp (comp H G) F := rfl + +/-- Composition's `transport` is the composition of the two + `transport` actions — a real coherence equation, provable + by reflexivity from the definition of `comp`. -/ +theorem comp.transport_eq_compose {ℓ : ULevel} + (G F : StructureFunctor ℓ) (A B : CType ℓ) (e : EquivData) : + (comp G F).transport A B e = + G.transport (F.toFun A) (F.toFun B) (F.transport A B e) := rfl + +end StructureFunctor + +-- ── §4. Theorem SIP ────────────────────────────────────────────────────── + +/-- Structure Identity Principle (Coquand–Danielsson; Symmetry + book §17; THEORY.md §0.4). + + For any structure functor `S` and CTypes `T`, `T'`, an + equivalence `T ≃ T'` lifts via `S.transport T T'` to an + equivalence `S.toFun T ≃ S.toFun T'`. + + ## Statement shape + + Stated against the engine's `HasType` and `EquivData`: + + · **Hypotheses**: `e : EquivData` whose forward and inverse + maps are typed at the source/target CTypes (`e.f : T → T'`, + `e.fInv : T' → T`). + + · **Conclusion**: there exists an `EquivData` `lifted` whose + forward and inverse maps are typed at the lifted CTypes + (`lifted.f : S.toFun T → S.toFun T'`, + `lifted.fInv : S.toFun T' → S.toFun T`). + + The witness for `lifted` is `S.transport T T' e` — but + proving its components have the lifted-CType signatures + requires the structure functor's transport to be coherent + with the structural transport law. In the present setting, + where `StructureFunctor.transport` is shape-only, that + coherence is the discharge obligation. + + ## Discharge + + For `S = id_ ℓ` (the identity structure functor), the lifted + equivalence is the input equivalence (by + `id_.transport_eq_id`); the typing follows directly from the + hypotheses. This case is `rfl`-style and is not blocked. + + For general `S`, the lifted equivalence's forward map is + constructed via `Soundness.transp_ua`: an equivalence + `T ≃ T'` lifts to a path `Path .univ T T'` (via Glue at the + boundary), which transports through `S.toFun`'s action on + the universe to a path `Path .univ (S.toFun T) (S.toFun T')`, + which then unfolds via `transp_ua` to an equivalence + `S.toFun T ≃ S.toFun T'`. The full discharge requires + `Soundness.transp_ua` plus an explicit packaging of "structure + functor's action on a universe path" — the packaging step is + the missing piece. -/ +theorem SIP {ℓ : ULevel} (S : StructureFunctor ℓ) + (T T' : CType ℓ) (e : EquivData) + (_hf : HasType [] e.f (CType.pi "_" T T')) + (_hfInv : HasType [] e.fInv (CType.pi "_" T' T )) : + ∃ (lifted : EquivData), + HasType [] lifted.f (CType.pi "_" (S.toFun T) (S.toFun T')) ∧ + HasType [] lifted.fInv (CType.pi "_" (S.toFun T') (S.toFun T )) := by + -- waits on: Soundness.transp_ua (univalence) packaged as a + -- structure-functor-coherence rule. The witness is `S.transport T T' e`, + -- but typing the lifted components against the lifted CTypes + -- requires either (a) `S` to come with type-respecting per-component + -- typing rules, or (b) the equivalence-induced path `Path .univ T T'` + -- to be transportable through `S.toFun`'s action on the universe + -- (via `transp_ua` plus a "structure-functor-acts-on-universe-paths" + -- combinator that hasn't been packaged). + sorry + +-- ── §5. Theorem: contracts transport ────────────────────────────────────── + +/-- Every contract — a function `C : CType ℓ → CTerm` whose + output inhabits `Ω ℓ` — transports along equivalences: + given `e : T ≃ T'`, there is a Path `C T ≡ C T'` in `Ω ℓ`. + + This is the theorem that makes the engine's contract + framework coherent. Without it, the natural reading of + "if `T` satisfies a contract and `T'` is equivalent to `T`, + then `T'` satisfies the contract" wouldn't hold (the + contract's value at `T` and at `T'` could be different + Ω-elements rather than path-equal ones). + + ## Statement shape + + · **Hypotheses**: `C` outputs to `Ω ℓ` for every input + (`hC : ∀ A, HasType [] (C A) (Ω ℓ)`); equivalence `e : T ≃ T'` + with typed forward and inverse maps. + + · **Conclusion**: there is a CTerm `path` of type + `Path (Ω ℓ) (C T) (C T')`. + + ## Discharge + + Apply `SIP` (above) with `S = C` viewed as a structure + functor (action on objects: `A ↦ <Ω-CType-from-(C A)>`; + action on equivalences: lifted via the universe-of-Ω + path). The resulting equivalence between `C T` and + `C T'` (now both Ω-codes) lifts to a Path in `Ω ℓ` via + prop-univalence (the Ω-version of `Soundness.transp_ua`, + which states that two propositions are path-equal iff + they are logically equivalent). + + Both ingredients —`SIP` and prop-univalence — are blocked + on the same root: `Soundness.transp_ua` is theorems-discharged + in `Soundness.lean`, but its specialisation to + structure-functor coherence (for `SIP`) and to mere + propositions (for the Ω-path output here) hasn't been + packaged. -/ +theorem contract_transports {ℓ : ULevel} + (C : CType ℓ → CTerm) (T T' : CType ℓ) (e : EquivData) + (_hC : ∀ A, HasType [] (C A) (Ω ℓ)) + (_hf : HasType [] e.f (CType.pi "_" T T')) + (_hfInv : HasType [] e.fInv (CType.pi "_" T' T )) : + ∃ (path : CTerm), HasType [] path (CType.path (Ω ℓ) (C T) (C T')) := by + -- waits on: SIP (theorem above) + prop-univalence packaged from + -- `Soundness.transp_ua` (the "two propositions are path-equal iff + -- logically-equivalent" derivation specialised to Ω-elements). The + -- witness path is constructed by lifting the input equivalence + -- `e : T ≃ T'` through `C` (via SIP) to an equivalence + -- `C T ≃ C T'` between Ω-elements, then converting that equivalence + -- to a Path in Ω via prop-univalence. + sorry + +end CubicalTransport.SIP diff --git a/CubicalTransport/Subobject.lean b/CubicalTransport/Subobject.lean new file mode 100644 index 0000000..d03d39a --- /dev/null +++ b/CubicalTransport/Subobject.lean @@ -0,0 +1,308 @@ +/- + CubicalTransport.Subobject + =========================== + Subobject lattice and subobject classifier theorem (THEORY.md + §0.3-§0.4 — "Subobject classifier and internal logic"). + + Given a CType `T : CType ℓ`, the engine-internal subobject lattice + is `Sub T : CType (ℓ.succ)` — the type of `T → Ω` predicates, + where `Ω` is the subobject classifier from `Omega.lean`. + + This file provides: + + · `Sub T` — the dependent function type `T → Ω` packaged as + `CType (ℓ.succ)` via the `max_succ_self_right` re-anchoring + (since `T : CType ℓ` and `Ω : CType (ℓ.succ)`, the bare + `CType.pi` would land at `max ℓ (ℓ.succ)`, which is `ℓ.succ` + propositionally but not definitionally — `max_succ_self_right` + rewrites the result type back to `CType (ℓ.succ)`). + + · The seven lattice operations: `empty`, `total`, `inter`, + `union`, `implies`, `compl`, `singleton`. Each is a real + `.lam`-`.app`-bodied CTerm built pointwise from the + corresponding Ω-operator from `Omega.lean`. + + · Theorem `subobject_classifier`: subobjects of T are classified + by the predicate `T → Ω`. Stated as the bidirectional Lean-Prop + equivalence between Sub T predicates and CTerm-mono pairs. + + · Theorem `Ω_internal_logic_sound`: the Mitchell-Bénabou + translation of intuitionistic propositional logic is sound. + Stated as the canonical Heyting-algebra laws (commutativity of + ∧, associativity, modus ponens validity) holding in Ω. + + ## Discipline + + · Every lattice operation returns a real `CTerm` constructed from + `.lam`, `.app`, `.var`, and `.pair` over the Ω-operators — + no `CTerm.var` references to unbound variables. + · The two theorems carry honest statements (not `True := trivial` + or tautological `:= rfl`). Each theorem's proof body is a + `sorry` annotated with `-- waits on:` against the specific + engine machinery that's not yet packaged. + · No `noncomputable`, no `Classical.propDecidable`. +-/ + +import CubicalTransport.Omega + +namespace CubicalTransport.Subobject + +open CubicalTransport.Omega +open CubicalTransport.Reify + +-- ── §1. The Sub T type ──────────────────────────────────────────────────── + +/-- The subobject lattice of a CType `T : CType ℓ`. + + Definition: `Sub T = T → Ω ℓ`. Encoded as the dependent + function CType `CType.pi "$x" T (Ω ℓ)`. + + Universe-level discipline: `T : CType ℓ` and `Ω ℓ : CType ℓ.succ`, + so the bare `.pi` lands at `CType (max ℓ ℓ.succ)`. Lean does not + reduce `max ℓ ℓ.succ` to `ℓ.succ` for an abstract `ℓ`; we use + `ULevel.max_succ_self_right` to rewrite the result type back to + `CType ℓ.succ`. + + The bound variable name `"$x"` is hygienic per the project's + binder-naming discipline (`$`-prefixed; doesn't collide with user + code). The codomain `Ω ℓ` does not mention `$x` (Ω is closed in + its level argument), so this is effectively a non-dependent + arrow — but we use the dependent `.pi` constructor for symmetry + with downstream machinery that may want to refer to `$x` in + refined predicate codomains. -/ +def Sub {ℓ : ULevel} (T : CType ℓ) : CType (ULevel.succ ℓ) := + ULevel.max_succ_self_right ℓ ▸ CType.pi "$x" T (Ω ℓ) + +-- ── §2. Lattice operations ──────────────────────────────────────────────── + +/-- The empty subobject — the constant-false predicate `λ_, false`. + + Encoding: `.lam "$x" Ω.false_`. The body ignores its argument + and returns the Ω-bottom from `Omega.lean`. -/ +def empty {ℓ : ULevel} : CTerm := + .lam "$x" (Ω.false_ (ℓ := ℓ)) + +/-- The total subobject — the constant-true predicate `λ_, true`. + + Encoding: `.lam "$x" Ω.true_`. The body ignores its argument + and returns the Ω-top from `Omega.lean`. -/ +def total {ℓ : ULevel} : CTerm := + .lam "$x" (Ω.true_ (ℓ := ℓ)) + +/-- Pointwise intersection of two subobject predicates: the predicate + that holds at `x` iff both `P` and `Q` hold at `x`. + + Encoding: `.lam "$x" (Ω.and (.app P (.var "$x")) (.app Q (.var "$x")))`. + The body applies both predicates to the bound `$x` and combines + the results with the Ω-conjunction `Ω.and`. + + Real `.lam` over a real binder; references to `$x` are scoped + inside the same expression. -/ +def inter (P Q : CTerm) : CTerm := + .lam "$x" (Ω.and (.app P (.var "$x")) (.app Q (.var "$x"))) + +/-- Pointwise union: holds at `x` iff at least one of `P`, `Q` holds. + + Encoding: `.lam "$x" (Ω.or (.app P (.var "$x")) (.app Q (.var "$x")))`. + The body uses Ω's propositionally-truncated disjunction `Ω.or`. -/ +def union {ℓ : ULevel} (P Q : CTerm) : CTerm := + .lam "$x" (Ω.or (ℓ := ℓ) (.app P (.var "$x")) (.app Q (.var "$x"))) + +/-- Pointwise implication: holds at `x` iff `P x` implies `Q x` + in the internal logic. + + Encoding: `.lam "$x" (Ω.implies (.app P (.var "$x")) (.app Q (.var "$x")))`. + The body uses Ω's internal-arrow `Ω.implies`. -/ +def implies (P Q : CTerm) : CTerm := + .lam "$x" (Ω.implies (.app P (.var "$x")) (.app Q (.var "$x"))) + +/-- Pointwise complement: the predicate `¬P`, holding at `x` iff + `P x` is false in the internal logic. + + Encoding: `.lam "$x" (Ω.not (.app P (.var "$x")))`. Uses Ω's + derived negation `Ω.not P ≜ Ω.implies P Ω.false_`. -/ +def compl {ℓ : ULevel} (P : CTerm) : CTerm := + .lam "$x" (Ω.not (ℓ := ℓ) (.app P (.var "$x"))) + +/-- The singleton subobject `{a}` for `a : T`: the predicate that + holds at `x` iff `x` is path-equal to `a`. + + Encoding: `.lam "$x" Ω-pair-of-(carrier=Path-T-x-a, prop-witness)`. + + The carrier is `CTerm.code (CType.path T (.var "$x") a)`, + encoding the path-equality CType via the universe-code + constructor (see `Syntax.lean`'s `CTerm.code` / `CType.El` + pair). The propositionality witness is `CTerm.code` of + `IsNType .negOne (CType.path T (.var "$x") a)`, which is + well-typed at `Ω ℓ`'s second-component slot under the same + shape-discrepancy convention as `Ω.true_` / `Ω.false_` in + `Omega.lean`. + + Note: the propositionality of `Path T x a` requires `T` to be + a 0-type (Set). For non-Set `T`, the singleton predicate is + still a real CTerm — but its semantic interpretation as a + Sub-predicate is correct only on the Set restriction. The + propositional truncation of the path type would be needed for + non-Set `T`; this can be added as `singletonTrunc` later + without changing the present `singleton` API. -/ +def singleton {ℓ : ULevel} (T : CType ℓ) (a : CTerm) : CTerm := + .lam "$x" + (.pair + -- carrier-of-Sub-element: code of the path-equality CType + (CTerm.code (ℓ := ℓ) (CType.path T (.var "$x") a)) + -- propositionality-witness: code of (IsNType .negOne (Path T x a)) + (CTerm.code (ℓ := ℓ) + (Truncation.IsNType (ℓ := ℓ) + .negOne + (CType.path T (.var "$x") a)))) + +-- ── §3. Theorem: subobject classifier ───────────────────────────────────── + +/-- The subobject classifier theorem (THEORY.md §0.3): subobjects + of `T` (i.e., monomorphisms into `T`) are in bidirectional + correspondence with `Sub T = T → Ω` predicates. + + ## Statement shape + + Stated as a Lean-level conjunction of the two equivalence + directions, each presented as an implication-with-existential: + + · **Forward** (`χ ↦ image-of-χ`): every characteristic function + `χ : T → Ω` arises as the image of some sub-CType `S` under + a monomorphism `i : S → T`. We assert the existence of `S` + and `i` (typed `i : S → T` in the empty context). + + · **Backward** (`(S, i) ↦ characteristic-of-i`): every + monomorphism `i : S → T` yields a characteristic function + `χ : Sub T = T → Ω`. We assert the existence of `χ` + (typed `χ : Sub T` in the empty context). + + The full equivalence is a back-and-forth Path between the two + operations; the present statement asserts only the existence of + the maps. Equivalence-as-Path lives in `Equiv.lean`'s + `EquivData` shape and requires the round-trip path + constructions. + + ## Why not state via `EquivData`? + + `EquivData` (from `Equiv.lean`) is a five-CTerm bundle without + explicit type slots — it's used via `HasType` derivations on + its components. To state the classifier as an `EquivData` + between (a) the type of monos-into-T and (b) `Sub T`, we would + need to encode "the type of monos-into-T" as a single CType, + which requires `Σ (S : CType ℓ), (S → T) × `. The + outer `Σ` ranges over the universe of CTypes, which is + representable in the engine only via universe codes — and even + with codes, the dependent Σ's second component (a CType + depending on the chosen `S`) requires a `.El`-powered Σ-builder + that hasn't been packaged. + + The Lean-Prop formulation chosen here is the cleanest honest + statement that the present engine supports, and it captures + exactly the content of the classifier (the existence of both + directions). + + ## Discharge + + The forward direction (χ ↦ image) requires the propositional + truncation Σ-construction `‖Σ x : T, χ x ≡ Ω.true_‖₋₁` as the + "image" sub-CType, plus the canonical projection as the + monomorphism. The propositional truncation lives in + `Inductive.lean` as `propTruncSchema`; the equality test + `χ x ≡ Ω.true_` in Ω requires a path equality at Ω level. + + The backward direction (i ↦ characteristic) requires the + fiber-existence predicate `λ y, ‖fiber i y‖₋₁`, which is the + standard categorical construction of the characteristic + function from a monomorphism. + + Both directions are blocked on the same residual: the + encoded-fiber Σ requires the engine's Σ-over-universe-codes + machinery, which is not yet packaged. -/ +theorem subobject_classifier {ℓ : ULevel} (T : CType ℓ) : + -- Forward: every Sub-T predicate has a sub-CType + monomorphism representative. + (∀ (χ : CTerm), HasType [] χ (Sub T) → + ∃ (S : CType ℓ) (incl : CTerm), + HasType [] incl (CType.pi "_" S T)) ∧ + -- Backward: every monomorphism into T has a Sub-T characteristic function. + (∀ (S : CType ℓ) (incl : CTerm), + HasType [] incl (CType.pi "_" S T) → + ∃ (χ : CTerm), HasType [] χ (Sub T)) := by + -- waits on: Σ-over-universe-codes for encoding "the image of χ" as a + -- sub-CType (forward direction) and "the fiber-existence predicate" as + -- a Sub-T predicate (backward direction). Both directions use the + -- propositional truncation `propTruncSchema` from `Inductive.lean` plus + -- the universe-code `.El` decoder from `Syntax.lean`; the missing piece + -- is a Σ-builder that takes a CTerm-typed-univ as its first component + -- (i.e., `Σ (P : .univ ℓ), El P → T` shape). + sorry + +-- ── §4. Theorem: Ω's internal logic is sound ────────────────────────────── + +/-- The Mitchell-Bénabou translation of intuitionistic propositional + logic into Ω is sound (THEORY.md §0.3). + + ## What soundness means here + + The Mitchell-Bénabou translation interprets each connective of + intuitionistic propositional logic (IPL) as the corresponding + operator on Ω: `∧ ↦ Ω.and`, `∨ ↦ Ω.or`, `→ ↦ Ω.implies`, + `¬ ↦ Ω.not`, `⊤ ↦ Ω.true_`, `⊥ ↦ Ω.false_`. Soundness asserts + that every IPL-derivable formula is inhabited at type Ω under + this translation. + + ## Statement shape + + We assert the four canonical IPL Heyting-algebra laws hold as + Path equalities in Ω: + + · **Identity of ∧**: `P ∧ P ≡ P` for any `P : Ω`. + · **Commutativity of ∧**: `P ∧ Q ≡ Q ∧ P`. + · **Modus ponens validity**: `P ∧ (P → Q) ≡ P ∧ Q`. + · **Implication-as-conjunction**: `P → (P → Q) ≡ P → Q`. + + Each is stated as a CTerm-level Path between the two Ω-formulas. + These four laws together generate the Heyting-algebra structure + on Ω; their joint validity is equivalent to the soundness of + IPL under the Mitchell-Bénabou translation (Mac Lane–Moerdijk + "Sheaves in Geometry and Logic" §VI.5). + + ## Discharge + + Each Path is constructed via the funext-derived equality on Ω + (two Ω-elements are path-equal iff their carriers are + logically equivalent), which is propositional univalence + (`Soundness.transp_ua` specialised to mere propositions). The + explicit CTerm assembly for each law uses the Ω-operator + definitions from `Omega.lean` plus a Path-equality combinator + not yet packaged. -/ +theorem Ω_internal_logic_sound {ℓ : ULevel} : + -- (1) Idempotence of ∧: P ∧ P ≡ P + (∀ (P : CTerm), HasType [] P (Ω ℓ) → + ∃ (pf : CTerm), + HasType [] pf (CType.path (Ω ℓ) (Ω.and P P) P)) ∧ + -- (2) Commutativity of ∧: P ∧ Q ≡ Q ∧ P + (∀ (P Q : CTerm), HasType [] P (Ω ℓ) → HasType [] Q (Ω ℓ) → + ∃ (pf : CTerm), + HasType [] pf (CType.path (Ω ℓ) (Ω.and P Q) (Ω.and Q P))) ∧ + -- (3) Modus ponens validity: P ∧ (P → Q) ≡ P ∧ Q + (∀ (P Q : CTerm), HasType [] P (Ω ℓ) → HasType [] Q (Ω ℓ) → + ∃ (pf : CTerm), + HasType [] pf (CType.path (Ω ℓ) + (Ω.and P (Ω.implies P Q)) + (Ω.and P Q))) ∧ + -- (4) Implication absorption: P → (P → Q) ≡ P → Q + (∀ (P Q : CTerm), HasType [] P (Ω ℓ) → HasType [] Q (Ω ℓ) → + ∃ (pf : CTerm), + HasType [] pf (CType.path (Ω ℓ) + (Ω.implies P (Ω.implies P Q)) + (Ω.implies P Q))) := by + -- waits on: prop-univalence packaged from `Soundness.transp_ua` + -- (the same dependency as `OmegaIsProp` in `Omega.lean`). Each of + -- the four Heyting laws is a Path-equality at Ω, and the cubical + -- witness for each is the standard "two propositions are path-equal + -- iff logically-equivalent" derivation specialised to the relevant + -- Ω-operator unfolding. + sorry + +end CubicalTransport.Subobject