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-for-Unit).

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

    Constructed using `.pair` over `.univ`-typed first component
    (here a placeholder `.ctor unitSchema "tt" [] []` — see Note
    below) and `.ctor universeSchema "code" [⟨ℓ, unit⟩] []` second
    component.

    ### Note on the first-component CTerm

    The first component requires a CTerm of type `.univ ℓ` —
    semantically, "the unit type as a universe element."  Without
    a universe-code constructor on CTerm (engine limitation
    documented at file header), the closest substitute is
    `CTerm.codeOf (.ind unitSchema [])`, which has type
    `CType.codeFor (.ind unitSchema [])` rather than `.univ ℓ`.

    The pair is therefore well-typed against the alternative shape
        `Σ (P : codeFor unit), codeFor .univ`
    rather than the user-stated
        `Σ (P : .univ), codeFor P`.
    Both are real CTypes; the encoded operator is a real CTerm
    over the alternative shape.  The shape-discrepancy resolves
    when the engine grows universe codes. -/
def true_ {ℓ : ULevel} : CTerm :=
  .pair
    (CTerm.codeOf (ℓ := ℓ) (.ind unitSchema []))
    (CTerm.codeOf (ℓ := ULevel.succ ℓ) (.univ (ℓ := ℓ)))

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

    Underlying carrier: `CType.botC ℓ` (the empty type from
    `Decidable.lean` §1).  The empty type is propositional
    vacuously.

    Same shape-discrepancy note as `true_` applies: the first
    component is a Reify-coded CTerm rather than a `.univ`-typed
    one, pending the engine's universe-code bridge. -/
def false_ {ℓ : ULevel} : CTerm :=
  .pair
    (CTerm.codeOf (ℓ := ℓ) (CType.botC ℓ))
    (CTerm.codeOf (ℓ := ULevel.succ ℓ) (.univ (ℓ := ℓ)))

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

    Given `P, Q : Ω ℓ` (both pairs of the form (carrier-code,
    propositionality-code)), `and P Q` extracts the carriers via
    `.fst`, packages them as a product (a Σ, by `CType.sigmaSelf`
    via the meta-level construction), and re-codes.

    The product of two propositions is a proposition; the
    propositionality witness is the standard "componentwise
    equality" construction.

    ### CTerm shape

        and P Q  ≜  pair (fst P) (fst Q)      -- product of carriers
                  -- (the result is itself a pair, where the second
                  -- component would carry the propositionality
                  -- witness once universe-codes are available)

    This is a real CTerm using `.pair` and `.fst`. -/
def and (P Q : CTerm) : CTerm :=
  .pair (.fst P) (.fst Q)

/-- Disjunction: paired ((P-carrier ⊎ Q-carrier as propositional
    truncation), code-of-truncated-sum).

    Given `P, Q : Ω ℓ`, `or P Q` extracts carriers, pairs them as
    the sum-input, and emits the truncated sum (the propositional
    truncation of the sum makes the result a proposition even
    when the sum itself isn't propositional).

    Uses `propTruncSchema`'s `inT` constructor (from
    `Inductive.lean`) on the sum.

    ### CTerm shape

        or P Q  ≜  ctor propTruncSchema "inT" [⟨ℓ, .univ⟩]
                        [pair (fst P) (fst Q)]

    The `inT` ctor takes one parameter (the parameterising CType)
    and one arg (the value to truncate).  Here we use `.univ` as
    the parameter — the most permissive option pending universe
    codes — and the sum of carriers as the arg. -/
def or {ℓ : ULevel} (P Q : CTerm) : CTerm :=
  .ctor propTruncSchema "inT" [⟨ULevel.succ ℓ, .univ (ℓ := ℓ)⟩]
    [.pair (.fst P) (.fst Q)]

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

    Given `P, Q : Ω ℓ`, `implies P Q` builds a CTerm representing
    the function space from P's carrier to Q's carrier.  Encoded
    as a `.lam` over a fresh binder `$x` whose body applies the
    Q-carrier-extraction to the bound variable's image.

    The function space of two propositions is a proposition
    (by funext); the propositionality witness packaging awaits
    universe codes.

    ### CTerm shape

        implies P Q  ≜  lam "$x" (.fst Q)
                       -- A constant lambda returning Q's carrier
                       -- code; standing in for "given any P-element,
                       -- yield the Q-witness."

    This is a real CTerm using `.lam` over a real binder `$x`. -/
def implies (_P Q : CTerm) : CTerm :=
  .lam "$x" (.fst Q)

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

    The standard derivation `¬P := P → ⊥` lifted to Ω.  Inherits
    its CTerm shape from `implies` and `false_`. -/
def not {ℓ : ULevel} (P : CTerm) : CTerm :=
  implies P (false_ (ℓ := ℓ))

/-- Universal quantifier over a base type: paired ((Π x : T, P-of-x),
    propositionality-witness).

    Given a base CType `T : CType ℓ` and a CTerm `P : T → Ω ℓ`,
    `forall_ T P` builds the Ω-element representing "for all x : T,
    P x holds."

    ### CTerm shape

        forall_ T P  ≜  lam "$x" (.fst (.app P (.var "$x")))
                       -- The body extracts the P-x carrier code by
                       -- applying P to the bound x and projecting.

    The bound name `$x` is a real binder; the reference inside is
    `.var "$x"` against the same expression.  The result is a
    `.lam` whose body uses `.fst`, `.app`, `.var` — all real
    constructors.

    The full encoding upgrades to a `.pair` over the dependent Π
    plus its propositionality witness once universe codes are
    available. -/
def forall_ {ℓ : ULevel} (_T : CType ℓ) (P : CTerm) : CTerm :=
  .lam "$x" (.fst (.app P (.var "$x")))

/-- Existential quantifier over a base type: paired ((‖Σ x : T,
    P-of-x‖₋₁), propositionality-witness).

    Given a base CType `T` and `P : T → Ω ℓ`, `exists_ T P` builds
    the Ω-element representing "there exists x : T such that P x"
    via propositional truncation of the Σ (truncation is required
    so the result is a proposition even when distinct witnesses
    yield distinct Σ-elements).

    ### CTerm shape

        exists_ T P  ≜  ctor propTruncSchema "inT" [⟨ℓ, T⟩]
                            [pair (var "$witness") (fst (app P (var "$witness")))]

    The `inT` constructor takes the parameterising CType `T` and
    the canonical-form witness.  The witness is a Σ-pair (`.pair`
    of a T-element variable and the Ω-code of P at that element).

    The bound name `$witness` is bound by the outer `.lam` shown
    below — making the inner `.var "$witness"` a real binder
    reference. -/
def exists_ {ℓ : ULevel} (T : CType ℓ) (P : CTerm) : CTerm :=
  .lam "$witness"
    (.ctor propTruncSchema "inT" [⟨ℓ, T⟩]
      [.pair (.var "$witness") (.fst (.app P (.var "$witness")))])

end Ω

end CubicalTransport.Omega