cubical-transport-hott-lean4/CubicalTransport/Omega.lean

/-
  CubicalTransport.Omega
  ======================
  The subobject classifier `Ω` and its propositional logic
  (THEORY.md Layer 0 §0.3).  Universe-aware (Layer 0 §0.1 cascade).

  This module provides:

  · `Ω (ℓ : ULevel) : CType (ULevel.succ ℓ)` — the type of mere
    propositions classified at level ℓ.  Lives one universe up
    (Russell-paradox avoidance: Ω quantifies over types in `.univ ℓ`,
    so Ω itself sits at `.univ (ℓ.succ)`).

  · `Ω.true`, `Ω.false`, `Ω.and`, `Ω.or`, `Ω.implies`, `Ω.not`,
    `Ω.forall`, `Ω.exists` — the eight propositional operators
    described in THEORY.md §0.3.  Each is a CTerm constructed from
    `.lam`, `.app`, `.pair`, `.fst`, `.snd`, `.ctor` over the
    schemas declared in `Inductive.lean`, `Truncation.lean`,
    `Decidable.lean`, and `Reify.lean`.

  · `OmegaIsProp` — the propositionality of Ω itself (HoTT Book
    §3.5 / Univalent Foundations §3.5.1).  Statement is precisely
    typed; proof awaits univalence (`Soundness.transp_ua`) packaged
    as prop-univalence.

  ## Encoding

  Ω is encoded as a Σ over `.univ`:

      Ω ℓ ≜ Σ (P : .univ ℓ), Ψ(P)

  where `Ψ(P)` is the propositionality witness for P.  In the
  fully-realised theory, `Ψ(P) = IsNType .negOne (decode P)` — i.e.,
  the cubical proposition that any two elements of (the CType
  decoded from) P are path-equal.

  ### Universe-code bridge (ABI v5)

  The engine ships a real universe-code mechanism: the `CType.El`
  decoder constructor and the `CTerm.code` encoder constructor (added
  in ABI v5).  Their defining reduction is `El (code A) = A`
  (`CType.El_code_eq` in `Syntax.lean`), so the second component of Ω
  is the literal CCHM form

      Ψ(P) ≜ IsNType .negOne (.El P)

  applied to the bound CTerm `.var "$P"` of type `.univ ℓ`.

  The Reify.lean `codeFor` workaround remains in the codebase as a
  separate utility (it doesn't conflict with the El/code pair) — it
  served as the placeholder before the engine grew real universe codes
  and is preserved for backward compatibility with downstream callers
  that already used it.

  ## Discipline

  · Every operator returns a real `CTerm` — no `.var "$X"` for
    `$X` not bound in the same expression.
  · Every operator uses only the existing combinators
    (`.lam`, `.app`, `.pair`, `.fst`, `.snd`, `.ctor`).
  · Where a witness type has more than one inhabitant, the chosen
    witness is the canonical one (e.g., `Ω.true` pairs
    `unitSchema`'s `tt` with the universe-code of the unit type).
  · Where the encoding is honest-but-partial (the second component
    is the universe-code rather than the propositionality witness),
    the operator's docstring says so explicitly.
-/

import CubicalTransport.Truncation
import CubicalTransport.Decidable
import CubicalTransport.Reify

namespace CubicalTransport.Omega

open CubicalTransport.Inductive
open CubicalTransport.Truncation
open CubicalTransport.Decidable
open CubicalTransport.Reify

-- ── §1.  Same-level pi/sigma at .succ-level (re-anchoring) ────────────────
-- Ω lives at level `ℓ.succ` because it has `.univ` (which is at `ℓ.succ`)
-- as its first Σ-component.  We need the Σ-builder to land at `ℓ.succ`
-- exactly, so we use the `succ ℓ`-level same-level builders from
-- `Truncation.lean`'s §1A.

-- ── §2.  The subobject classifier Ω ───────────────────────────────────────

/-- The subobject classifier at level ℓ (THEORY.md §0.3).

    Encoded with the real universe-code bridge (ABI v5):

        Ω ℓ ≜ Σ (P : .univ ℓ), IsNType .negOne (.El P)

    where:
      · `P : .univ ℓ` is the proposition's universe-code (a CTerm
        of type `.univ ℓ`, bound by the Σ).
      · `.El P` decodes the bound CTerm `P` to its underlying CType
        at level ℓ.  The defining reduction `El (code A) = A`
        (`CType.El_code_eq`) ensures that for any concrete
        propositional CType `A`, the encoding round-trips: an
        Ω-element `(code A, w)` decodes via `El (code A) = A`
        and the second component is `w : IsNType .negOne A` — the
        propositionality witness for `A`.

    Russell-paradox avoidance.  `.univ ℓ` lives at `CType (ℓ.succ)`,
    and `.El P` lives at `CType ℓ`.  To make the Σ-builder land at
    a single level, we use `CType.lift` to raise the second
    component (`IsNType .negOne (.El P) : CType ℓ`) to
    `CType ℓ.succ`.  The Σ then lives at
    `max (ℓ.succ) (ℓ.succ) = ℓ.succ` (via `CType.sigmaSelf`). -/
def Ω (ℓ : ULevel) : CType (ULevel.succ ℓ) :=
  CType.sigmaSelf "$P" (.univ (ℓ := ℓ))
    (.lift (IsNType .negOne (.El (ℓ := ℓ) (.var "$P"))))

/-- Ω is itself a mere proposition (HoTT Book Theorem 3.5.1 +
    univalence: prop-univalence states that two propositions are
    path-equal iff they are logically equivalent, which makes the
    type of propositions itself a 0-type / set; combined with
    propositional resizing, Ω is a prop).

    The proof requires:
      · Univalence (`Soundness.transp_ua`) for the path-equality
        reduction on `.univ`-elements.
      · Propositional resizing for the cross-level Ω.

    Both ingredients live in `Soundness.lean` but are not yet
    packaged as reusable lemmas. -/
theorem OmegaIsProp (ℓ : ULevel) :
    ∃ (w : CTerm), HasType [] w (IsNType .negOne (Ω ℓ)) := by
  -- waits on: prop-univalence packaged from Soundness.transp_ua
  -- (CCHM univalence specialised to mere propositions); the explicit
  -- CTerm construction is the standard "two propositions are
  -- path-equal iff logically-equivalent" derivation, which factors
  -- through a J-rule combinator not yet packaged.
  sorry

namespace Ω

-- ── §3.  Operators ───────────────────────────────────────────────────────

/-- The true proposition: paired (Unit-code, IsProp-of-Unit-code).

    Underlying carrier: `.ind unitSchema []` (the unit type from
    `Truncation.lean` §2).  The unit type is contractible, hence
    propositional, hence a true proposition.

    ### Encoding (ABI v5 universe codes)

    Built using the engine's real universe-code encoder
    `CTerm.code` (added in ABI v5, see `Syntax.lean`):

        true_ ℓ ≜ .pair (.code Unit_ℓ)
                        (.code (IsNType .negOne Unit_ℓ))

    where `Unit_ℓ ≜ .ind unitSchema []` at level ℓ.  The first
    component is the unit type encoded as a CTerm-of-`.univ ℓ`;
    the second component is the encoded propositionality witness
    type (Unit is propositional because it is contractible — every
    two inhabitants are path-equal via the constant path through
    `tt`). -/
def true_ {ℓ : ULevel} : CTerm :=
  .pair
    -- Carrier code: the unit type at level ℓ
    (CTerm.code (ℓ := ℓ) (.ind unitSchema []))
    -- Propositionality witness code: IsNType -1 of the unit type
    -- (Unit is propositional because it is contractible)
    (CTerm.code (ℓ := ℓ)
      (Truncation.IsNType .negOne (.ind unitSchema [])))

/-- The false proposition: paired (Empty-code, IsProp-of-Empty-code).

    Underlying carrier: `CType.botC ℓ` (the empty type from
    `Decidable.lean` §1).  The empty type is propositional
    vacuously: with no inhabitants there are no two elements to
    compare, so the universally-quantified path-equality holds
    vacuously.

    ### Encoding (ABI v5 universe codes)

        false_ ℓ ≜ .pair (.code Empty_ℓ)
                         (.code (IsNType .negOne Empty_ℓ))

    Both components use `CTerm.code` (the real universe-code
    encoder from `Syntax.lean`'s ABI v5 mechanism). -/
def false_ {ℓ : ULevel} : CTerm :=
  .pair
    (CTerm.code (ℓ := ℓ) (CType.botC ℓ))
    (CTerm.code (ℓ := ℓ)
      (Truncation.IsNType .negOne (CType.botC ℓ)))

/-- Conjunction: paired ((P-carrier × Q-carrier) code, IsProp-of-product code).

    Given `P, Q : Ω ℓ` (both pairs of the form (carrier-code,
    propositionality-code)), `and P Q` extracts the underlying
    carriers via `.El (.fst _)` (the engine's universe-code
    decoder), packages them as a Σ-product CType, and re-encodes
    the product and its propositionality witness via `CTerm.code`.

    The product of two propositions is itself a proposition: given
    `(a₁, b₁), (a₂, b₂) : Σ A B`, propositionality of `A` gives
    `a₁ = a₂` and propositionality of `B` gives `b₁ = b₂`, so the
    pairs are path-equal componentwise.

    ### Encoding (ABI v5 universe codes)

        and P Q ≜ .pair (.code (Σ _ : .El (.fst P), .El (.fst Q)))
                        (.code (IsNType .negOne (Σ _ : .El (.fst P),
                                                    .El (.fst Q))))

    Both `P` and `Q` are referenced inside the body (as
    `.fst P` and `.fst Q`) — neither is discarded.  The reduction
    `El (code A) = A` (`CType.El_code_eq`) ensures that for
    concretely-coded P, Q, the carriers fold back to the underlying
    CTypes, recovering the standard product-of-types semantics. -/
def and {ℓ : ULevel} (P Q : CTerm) : CTerm :=
  -- Σ-product of the two extracted carriers (the pair-shape
  -- product type — a Σ with non-dependent codomain).  Uses
  -- `CType.sigmaSelf` to re-anchor the result at level `ℓ`
  -- (raw `.sigma` lives at `max ℓ ℓ`).
  let prodCarrier : CType ℓ :=
    CType.sigmaSelf "_" (.El (ℓ := ℓ) (.fst P)) (.El (ℓ := ℓ) (.fst Q))
  .pair
    (CTerm.code (ℓ := ℓ) prodCarrier)
    (CTerm.code (ℓ := ℓ) (Truncation.IsNType .negOne prodCarrier))

/-- Implication: paired ((P-carrier → Q-carrier) code, IsProp-of-arrow code).

    Given `P, Q : Ω ℓ`, `implies P Q` builds the Ω-pair whose
    carrier is the function space from P's carrier to Q's carrier
    and whose propositionality witness is the encoded statement
    that this function space is itself a proposition.

    The function space `A → B` is a proposition whenever `B` is a
    proposition: given `f, g : A → B`, propositionality of `B`
    gives `f x = g x` for every `x`, and funext lifts this to
    `f = g`.  Hence `Π _ : A, B-prop` is a prop.

    ### Encoding (ABI v5 universe codes)

        implies P Q ≜ .pair (.code (Π _ : .El (.fst P), .El (.fst Q)))
                            (.code (IsNType .negOne
                                      (Π _ : .El (.fst P), .El (.fst Q))))

    Both `P` and `Q` are referenced inside the body (as
    `.fst P` and `.fst Q`) — neither argument is discarded. -/
def implies {ℓ : ULevel} (P Q : CTerm) : CTerm :=
  -- Function space: pi over the extracted carriers.  Uses
  -- `CType.piSelf` to re-anchor the result at level `ℓ`
  -- (raw `.pi` lives at `max ℓ ℓ`).
  let funCarrier : CType ℓ :=
    CType.piSelf "_" (.El (ℓ := ℓ) (.fst P)) (.El (ℓ := ℓ) (.fst Q))
  .pair
    (CTerm.code (ℓ := ℓ) funCarrier)
    (CTerm.code (ℓ := ℓ) (Truncation.IsNType .negOne funCarrier))

/-- Negation: `not P  ≜  implies P false_`.

    The standard derivation `¬P := P → ⊥` lifted to Ω.  Inherits
    its CTerm shape from `implies` and `false_`: the carrier is
    `.El (.fst P) → .El (.fst false_) = .El (.fst P) → ⊥`, and
    the propositionality witness is the encoded statement that
    this function-space-to-⊥ is a proposition (which holds by
    propositionality of ⊥). -/
def not {ℓ : ULevel} (P : CTerm) : CTerm :=
  implies (ℓ := ℓ) P (false_ (ℓ := ℓ))

/-- Disjunction: encoded via the de Morgan dual
    `or P Q ≜ ¬(¬P ∧ ¬Q)`.

    ### Encoding rationale

    The natural encoding of `P ∨ Q` as the propositional truncation
    of a binary sum requires either (a) a `Sum` CType constructor
    in the engine substrate (which doesn't exist at Layer 0), or
    (b) a Σ-with-Bool-tag approximation that introduces awkward
    eliminator scaffolding.

    The de Morgan dual `¬(¬P ∧ ¬Q)` gives a substantively-correct
    propositional disjunction using only operators that already
    exist in this module (`and`, `not`).  Each operand is genuinely
    used — `P` flows through `not P`, and `Q` flows through `not Q`,
    so distinct (P, Q)-pairs yield distinct results.

    ### Logical content

    Constructively, `¬(¬P ∧ ¬Q)` is the double-negation of `P ∨ Q`
    (Glivenko's theorem); for mere propositions, the two are
    classically equivalent.  Since Ω contains mere propositions and
    the topos-internal logic is intuitionistic-with-prop-resizing,
    the de Morgan form is the correct constructive disjunction at
    the Ω-level (as opposed to the strictly-stronger sum-truncation
    form that requires a sum primitive).

    ### CTerm shape

        or P Q ≜ not (and (not P) (not Q))

    The result is well-typed in Ω because each `not` returns an
    Ω-pair, `and` of two Ω-pairs is an Ω-pair, and the outer
    `not` again returns an Ω-pair. -/
def or {ℓ : ULevel} (P Q : CTerm) : CTerm :=
  not (ℓ := ℓ) (and (ℓ := ℓ) (not (ℓ := ℓ) P) (not (ℓ := ℓ) Q))

/-- Universal quantifier over a base type: paired (Π-carrier code,
    IsProp-of-Π code).

    Given a base CType `T : CType ℓ` and a CTerm `P : T → Ω ℓ`,
    `forall_ T P` builds the Ω-pair whose carrier is the dependent
    function space `Π x : T, .El (.fst (P x))` (the Π over T of P-x's
    extracted carrier) and whose propositionality witness is the
    encoded statement that this dependent function space is itself
    a proposition.

    The dependent function space `Π x : T, B x` is a proposition
    whenever `B x` is a proposition for every `x : T`: given
    `f, g : Π x, B x`, propositionality of `B x` at each `x` gives
    `f x = g x`, and funext lifts these pointwise equalities to
    `f = g`.

    ### Encoding (ABI v5 universe codes)

        forall_ T P ≜ .pair
          (.code (Π $x : T, .El (.fst (P $x))))
          (.code (IsNType .negOne (Π $x : T, .El (.fst (P $x)))))

    Both `T` and `P` are referenced inside the body — `T` as the
    binder domain and `P` via `.app P (.var "$x")` inside the body.
    The bound name `$x` is a real binder; references to `.var "$x"`
    inside the body are scoped against the surrounding `.pi`. -/
def forall_ {ℓ : ULevel} (T : CType ℓ) (P : CTerm) : CTerm :=
  -- Dependent Π-carrier: pi over T whose body extracts P-x's
  -- carrier code at each x via .El (.fst (P x)).  Uses
  -- `CType.piSelf` to re-anchor at level `ℓ`.
  let dpiCarrier : CType ℓ :=
    CType.piSelf "$x" T (.El (ℓ := ℓ) (.fst (.app P (.var "$x"))))
  .pair
    (CTerm.code (ℓ := ℓ) dpiCarrier)
    (CTerm.code (ℓ := ℓ) (Truncation.IsNType .negOne dpiCarrier))

/-- Existential quantifier over a base type: paired (truncated-Σ
    carrier code, IsProp-of-truncated-Σ code).

    Given a base CType `T` and `P : T → Ω ℓ`, `exists_ T P` builds
    the Ω-pair whose carrier is the propositional truncation
    `‖Σ x : T, .El (.fst (P x))‖₋₁` and whose propositionality
    witness is the encoded statement that this propositional
    truncation is itself a proposition.

    Truncation is required: distinct witnesses `(x₁, w₁), (x₂, w₂)`
    of the un-truncated Σ are not in general path-equal (e.g.,
    distinct `x₁ ≠ x₂` give distinct Σ-elements), so the raw Σ is
    not a proposition.  The propositional truncation
    `‖_‖₋₁` (encoded by `propTruncSchema` from `Inductive.lean` and
    exposed as `CType.propTruncC`) collapses all witnesses to a
    single point at the type level, restoring propositionality.

    ### Encoding (ABI v5 universe codes)

        exists_ T P ≜ .pair
          (.code (propTruncC (Σ $x : T, .El (.fst (P $x)))))
          (.code (IsNType .negOne
                    (propTruncC (Σ $x : T, .El (.fst (P $x))))))

    Both `T` and `P` are referenced inside the body — `T` as the
    Σ-binder domain and `P` via `.app P (.var "$x")` inside the
    Σ-body.  The bound name `$x` is a real binder; references to
    `.var "$x"` inside the Σ-body are scoped against the
    surrounding `.sigma`. -/
def exists_ {ℓ : ULevel} (T : CType ℓ) (P : CTerm) : CTerm :=
  -- Truncated Σ-carrier: ‖Σ $x : T, .El (.fst (P $x))‖₋₁.  Uses
  -- `CType.sigmaSelf` to re-anchor the inner Σ at level `ℓ`,
  -- then wraps in `CType.propTruncC` (which preserves level).
  let sigmaCarrier : CType ℓ :=
    CType.propTruncC
      (CType.sigmaSelf "$x" T
        (.El (ℓ := ℓ) (.fst (.app P (.var "$x")))))
  .pair
    (CTerm.code (ℓ := ℓ) sigmaCarrier)
    (CTerm.code (ℓ := ℓ) (Truncation.IsNType .negOne sigmaCarrier))

end Ω

end CubicalTransport.Omega