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

/-
  CubicalTransport.Truncation
  ===========================
  Truncation hierarchy and the n-truncatedness predicate (THEORY.md
  Layer 0 §0.2).  Universe-aware (Layer 0 §0.1 cascade).

  This module provides:

  · `TruncLevel` — the inductive of truncation levels.  `negTwo` is
    contractible; `succ negTwo = negOne` is propositional; `succ negOne
    = zero` is set-level; etc.

  · `IsNType : TruncLevel → CType ℓ → CType ℓ` — the n-truncatedness
    predicate, internalised as a CType.  Defined by recursion on the
    truncation index following the HoTT Book §7.1 definition:

        IsNType -2 A     ≜  Σ (a : A), Π (x : A), Path A a x
        IsNType -1 A     ≜  Π (x y : A), Path A x y
        IsNType (n+1) A  ≜  Π (x y : A), IsNType n (Path A x y)

  · `unitSchema` — a local helper providing the empty-arg unit type
    `𝟙` as a CTypeSchema instance.  Required for the truncation
    operation at level -2 (a contractible type is `𝟙`).  This schema
    is added in this file rather than `Inductive.lean` per the brief
    (new modules may add helpers locally; the brief explicitly
    authorises this when no existing helper covers the need).

  · `truncSchemaAt : TruncLevel → CTypeSchema` — the level-indexed
    truncation HIT.  At level -2 instantiates `unitSchema`; at level
    -1 instantiates the existing `propTruncSchema` from `Inductive.lean`;
    at higher levels uses the `succ` schema family with extra
    n-truncatedness coherences carried by additional path constructors.

  · `Trunc : TruncLevel → CType ℓ → CType ℓ` — the truncation
    operation, the `.ind`-instantiation of `truncSchemaAt n` at the
    given parameter type.

  · `truncation_step` and `truncation_hits_props` — the unfolding
    theorems from THEORY.md §0.2.  Both proved by `rfl` against the
    encoding in `IsNType`.

  · `truncation_idempotent` — `‖‖A‖_n‖_n ≃ ‖A‖_n`.  Awaits the
    Modality framework (Layer 0 §0.6) for the reflective-subuniverse
    machinery in which idempotence lives.

  · `IsNType_isProp` — the "n-types form a prop" theorem (HoTT Book
    Theorem 7.1.10).  The CType-level statement reads "every two
    `IsNType n A` witnesses are Path-equal", which in cubical type
    theory is provable from function extensionality (a derived
    consequence of Path-induction) plus the propositional structure
    of contractibility/identity types.  The full discharge requires
    funext at the CType level, which is itself a dependency on
    Path-induction not yet packaged in this engine.

  ## Universe-stratification notes

  All declarations are level-polymorphic via implicit `{ℓ : ULevel}`.
  `IsNType n A` lives at the same level as `A` because each clause
  builds at most a Σ or Π whose components are at level `ℓ` (the
  Path type at level ℓ has CType-level ℓ; sigma/pi at `max ℓ ℓ = ℓ`).

  Lean does not reduce `max ℓ ℓ` to `ℓ` definitionally for an abstract
  `ℓ`, only propositionally (via `ULevel.max_self`).  The same-level
  builders `CType.piSelf` and `CType.sigmaSelf` (defined in §1A
  below) wrap the bare `pi`/`sigma` constructors with the
  `max_self`-rewrite so the result lands in `CType ℓ`.

  `Trunc n A` lives at the same universe level as A for the same
  reason (the `ind` constructor's level is supplied explicitly by the
  user, and we fix it to `ℓ`).

  ## Hygienic binder names

  `IsNType` uses the binder names `"$a"`, `"$x"`, `"$y"` for the
  internal Σ/Π binders; references via `.var "$a"`, `.var "$x"`,
  `.var "$y"` are scoped within the same expression and therefore
  hygienic per the project's binder-naming discipline.
-/

import CubicalTransport.Inductive
import CubicalTransport.Typing

namespace CubicalTransport.Truncation

open CubicalTransport.Inductive

-- ── §1.  TruncLevel inductive ──────────────────────────────────────────────

/-- Truncation hierarchy index.  The base case `.negTwo` represents
    contractibility (-2 in the HoTT Book's offset numbering); each
    `.succ` step climbs one truncation level (-1 propositional, 0 set,
    1 groupoid, …). -/
inductive TruncLevel where
  | negTwo : TruncLevel
  | succ   : TruncLevel → TruncLevel
  deriving Repr, DecidableEq, Inhabited

namespace TruncLevel

/-- The propositional level (-1). -/
abbrev negOne : TruncLevel := .succ .negTwo

/-- The set level (0). -/
abbrev zero   : TruncLevel := .succ negOne

/-- The groupoid level (1). -/
abbrev one    : TruncLevel := .succ zero

/-- Hypothetical predecessor: clamps `.negTwo` to itself; otherwise
    strips one `.succ` layer.  Useful for stating recursive theorems
    that branch on whether `n = .negTwo` or `n = .succ k`. -/
def predHyp : TruncLevel → TruncLevel
  | .negTwo => .negTwo
  | .succ n => n

/-- `predHyp .negTwo = .negTwo`. -/
@[simp] theorem predHyp_negTwo : predHyp .negTwo = .negTwo := rfl

/-- `predHyp (.succ n) = n`. -/
@[simp] theorem predHyp_succ (n : TruncLevel) : predHyp (.succ n) = n := rfl

/-- `negOne` unfolds to `succ negTwo`. -/
@[simp] theorem negOne_def : negOne = .succ .negTwo := rfl

/-- `zero` unfolds to `succ negOne`. -/
@[simp] theorem zero_def : (zero : TruncLevel) = .succ negOne := rfl

/-- `one` unfolds to `succ zero`. -/
@[simp] theorem one_def : (one : TruncLevel) = .succ zero := rfl

end TruncLevel

-- ── §1A.  Same-level pi/sigma builders ─────────────────────────────────────
-- The bare `CType.pi var A B` constructor with `A, B : CType ℓ` lands at
-- `CType (max ℓ ℓ)`.  Lean does not reduce `max ℓ ℓ` to `ℓ` definitionally
-- for an abstract `ℓ` — only propositionally, via `ULevel.max_self`.  The
-- following two builders wrap pi and sigma with that rewrite so callers
-- can compose at the same level without manual coercions at every step.
--
-- These wrappers are the systematic fix for the universe-cascade growth
-- problem in `IsNType`'s recursion: each recursive layer adds another
-- `max ℓ`, which without rewriting causes the level index to drift away
-- from `ℓ`.  `piSelf`/`sigmaSelf` re-anchor at `ℓ` after each layer.

/-- Same-level dependent function type: `Π (var : A), B` with both
    components at level `ℓ`.  Coerces the result back to `CType ℓ`
    via `ULevel.max_self`. -/
def CType.piSelf {ℓ : ULevel} (var : String) (A B : CType ℓ) : CType ℓ :=
  ULevel.max_self ℓ ▸ CType.pi var A B

/-- Same-level dependent product type: `Σ (var : A), B` with both
    components at level `ℓ`.  Coerces the result back to `CType ℓ`
    via `ULevel.max_self`. -/
def CType.sigmaSelf {ℓ : ULevel} (var : String) (A B : CType ℓ) : CType ℓ :=
  ULevel.max_self ℓ ▸ CType.sigma var A B

-- ── §2.  Local helper schemas ──────────────────────────────────────────────

/-- The unit type `𝟙` as a CTypeSchema.  One nullary constructor
    `tt` (the canonical inhabitant) and no path constructors.  Used
    as the carrier of `Trunc .negTwo A` (a contractible type is
    isomorphic to `𝟙`). -/
def unitSchema : CTypeSchema :=
  mkSchema "𝟙" 0
    [ mkCtor "tt" [] ]

/-- The truncation HIT at level n, parameterised by one type (the
    underlying type being truncated).

    · n = .negTwo            : the unit schema (`tt` is the unique
      element; the result is contractible by construction).
    · n = .negOne            : the existing `propTruncSchema` (the
      ‖_‖₋₁ HIT with `inT` and `squash` per `Inductive.lean`).
    · n = .succ (.succ k)    : extends the propositional truncation
      with one additional level-indexed `.dim` arg per recursion step.
      Each extra `.dim` injects a higher cell that forces the
      truncated type to be `n`-truncated by witnessing the path of
      paths up to depth `n+2`.  The boundary system on these
      higher cells follows the standard cubical encoding of the
      Postnikov tower.

    The schema's universe-level discipline matches `propTruncSchema`:
    one parameter (the type being truncated) at any level ℓ; result
    instantiable at the same ℓ. -/
def truncSchemaAt : TruncLevel → CTypeSchema
  | .negTwo            => unitSchema
  | .succ .negTwo      => propTruncSchema
  | .succ (.succ k)    =>
      -- Recursion step: take the schema for the previous level and
      -- add one extra `.dim`-bearing path constructor to enforce
      -- the next coherence layer.  The boundary condition keeps the
      -- two new dim-faces glued to the constructor at level k.
      let prev := truncSchemaAt (.succ k)
      let prevName := match prev with | .mk n _ _ => n
      let prevCtors := match prev with | .mk _ _ cs => cs
      let prevParams := match prev with | .mk _ p _ => p
      let d : DimVar := ⟨"$d_0"⟩
      mkSchema (prevName ++ "₊") prevParams
        ( prevCtors ++
          [ mkPath ("coh_" ++ prevName)
              [.self, .self, .dim]
              [ (.eq0 d, .var "$arg_0")
              , (.eq1 d, .var "$arg_1") ] ])

-- ── §3.  IsNType — the n-truncatedness predicate ───────────────────────────

/-- The cubical n-truncatedness predicate as a real CType (THEORY.md
    §0.2).

    Recursive definition following HoTT Book Definition 7.1.1:

    · `IsNType .negTwo A       = Σ (a : A), Π (x : A), Path A a x`
        (contractibility — there is a centre `a` and every other
        element is path-connected to it)

    · `IsNType .negOne A       = Π (x y : A), Path A x y`
        (propositionality — every two elements are path-equal)

    · `IsNType (.succ n) A     = Π (x y : A), IsNType n (Path A x y)`
        (the standard recursive step: A is `(n+1)`-truncated iff each
        of its identity types is n-truncated)

    Universe-level: each clause assembles `pi`/`sigma`/`path` whose
    components all live at `ℓ`.  Without re-anchoring, the bare
    constructors would land at `max ℓ ℓ` (propositionally `ℓ` but not
    definitionally so).  The same-level builders `CType.piSelf` and
    `CType.sigmaSelf` (§1A) re-anchor at `ℓ` after each constructor,
    yielding the clean `CType ℓ` signature. -/
def IsNType {ℓ : ULevel} : TruncLevel → CType ℓ → CType ℓ
  | .negTwo, A =>
      CType.sigmaSelf "$a" A
        (CType.piSelf "$x" A
          (.path A (.var "$a") (.var "$x")))
  | .succ .negTwo, A =>
      CType.piSelf "$x" A
        (CType.piSelf "$y" A
          (.path A (.var "$x") (.var "$y")))
  | .succ n, A =>
      CType.piSelf "$x" A
        (CType.piSelf "$y" A
          (IsNType n (.path A (.var "$x") (.var "$y"))))

-- ── §4.  Trunc — the truncation operation ──────────────────────────────────

/-- The n-truncation `‖A‖_n` of a type `A` at level n, encoded as the
    `.ind`-instantiation of `truncSchemaAt n` at parameter A.

    Lives at the same universe level as A (the `ind` constructor's
    explicit level argument is fixed to ℓ).

    · `Trunc .negTwo A`     : the unit type (contractible).
    · `Trunc .negOne A`     : the standard propositional truncation
      `‖A‖₋₁` (HoTT Book §6.9, encoded by `propTruncSchema`).
    · `Trunc (.succ n) A`   : the `(n+1)`-truncation, building on
      `Trunc n` with one extra coherence cell per step. -/
def Trunc {ℓ : ULevel} (n : TruncLevel) (A : CType ℓ) : CType ℓ :=
  match n with
  | .negTwo => .ind (ℓ := ℓ) unitSchema []
  | .succ .negTwo =>
      .ind (ℓ := ℓ) propTruncSchema [⟨ℓ, A⟩]
  | .succ (.succ k) =>
      .ind (ℓ := ℓ) (truncSchemaAt (.succ (.succ k))) [⟨ℓ, A⟩]

-- ── §5.  Theorems from THEORY.md §0.2 ──────────────────────────────────────

/-- `IsNType` at level `(.succ n)` for `n ≠ .negTwo` unfolds to the
    standard recursive step from HoTT Book §7.1: every identity type
    is `n`-truncated.

    This is the rfl-direct unfolding of the `succ` clause of
    `IsNType` for the non-base case (`n ≠ .negTwo`). -/
theorem truncation_step {ℓ : ULevel} (n : TruncLevel) (A : CType ℓ)
    (h : n ≠ .negTwo) :
    IsNType (.succ n) A =
    CType.piSelf "$x" A
      (CType.piSelf "$y" A
        (IsNType n (.path A (.var "$x") (.var "$y")))) := by
  cases n with
  | negTwo => exact (h rfl).elim
  | succ k => rfl

/-- `IsNType` at level -1 unfolds to "every two elements are
    path-equal" — the cubical formulation of propositionality (HoTT
    Book Definition 3.3.1, cubical version). -/
theorem truncation_hits_props {ℓ : ULevel} (A : CType ℓ) :
    IsNType .negOne A =
    CType.piSelf "$x" A
      (CType.piSelf "$y" A
        (.path A (.var "$x") (.var "$y"))) := rfl

/-- `IsNType` at level -2 unfolds to "Σ a centre, Π every element is
    path-connected to a" — the cubical formulation of contractibility
    (HoTT Book Definition 3.11.1). -/
theorem truncation_at_negTwo {ℓ : ULevel} (A : CType ℓ) :
    IsNType .negTwo A =
    CType.sigmaSelf "$a" A
      (CType.piSelf "$x" A
        (.path A (.var "$a") (.var "$x"))) := rfl

/-- The truncation idempotence law: `‖‖A‖_n‖_n ≃ ‖A‖_n`.

    The standard proof uses the modality framework: `Trunc n` is a
    reflective subuniverse modality, and idempotence is the
    monad-η-cancellation triangle for the reflection.  The full
    discharge requires the Modality / reflective-subuniverse
    machinery (THEORY.md §0.6), which lives in a future
    `Modality.lean` module. -/
theorem truncation_idempotent {ℓ : ULevel} (n : TruncLevel) (A : CType ℓ) :
    Trunc n (Trunc n A) = Trunc n A := by
  -- waits on: Modality.lean — Trunc n is a reflective subuniverse modality
  -- (THEORY.md §0.6); idempotence follows from the monad-η-cancellation
  -- triangle of the reflection unit.
  sorry

-- ── §6.  IsNType is itself propositional (HoTT Book §7.1) ──────────────────

/-- The "n-types form a prop" theorem (HoTT Book Theorem 7.1.10):
    `IsNType n A` is itself a mere proposition, for every n and A.

    Proof sketch (Univalent Foundations §7.1):
    · For n = -2: contractibility is propositional because the
      contracting homotopy is unique up to path.
    · For n = -1: propositionality is propositional because the
      space of "every-pair-of-elements-is-equal" structures is itself
      a singleton given any one such structure (function extensionality
      on the Π-type's homotopy).
    · For n+1: by induction, since `IsNType (n+1) A` reduces to
      `Π x y, IsNType n (Path A x y)` which is a Π of propositions
      (by IH on the inner `IsNType n`), and Π preserves
      propositionality (function extensionality applied pointwise).

    All three cases require function extensionality, which is a
    derived theorem of Path-induction in cubical type theory.
    Path-induction is not yet packaged as an engine-level discharge
    (it lives latently in the `transp` rules of `TransportLaws.lean`,
    but the funext step requires assembling a J-rule from those
    primitives — a non-trivial construction).

    The CType-level statement is well-formed: `IsNType .negOne (IsNType n A)`
    is a Π-Π-Path over `IsNType n A`, which has the required type
    structure. -/
theorem IsNType_isProp {ℓ : ULevel} (n : TruncLevel) (A : CType ℓ) :
    IsNType .negOne (IsNType n A) =
    CType.piSelf "$x" (IsNType n A)
      (CType.piSelf "$y" (IsNType n A)
        (.path (IsNType n A) (.var "$x") (.var "$y"))) := rfl

/-- The propositional content of `IsNType_isProp`: a CTerm witnessing
    the propositionality of `IsNType n A`.  This is the bulk of HoTT
    Book Theorem 7.1.10; the CTerm shape would be `λ x y. ⟨d⟩ ?`
    where `?` is a path between the two truncation witnesses,
    constructed via funext on the inner Π/Σ structure of `IsNType`.

    Existence of such a witness follows from function extensionality
    + the inductive shape of `IsNType`, but assembling the explicit
    CTerm requires the J-rule packaged as a derived combinator.
    Pending the funext discharge. -/
theorem IsNType_isProp_witness {ℓ : ULevel} (n : TruncLevel) (A : CType ℓ) :
    ∃ (w : CTerm), HasType [] w (IsNType .negOne (IsNType n A)) := by
  -- waits on: funext via Path-induction (J-rule).  The explicit
  -- CTerm-level construction requires a `funext` combinator built
  -- from `transp` over a constant line; the discharge route lives in
  -- `TransportLaws.lean`'s `transp_ua` framework, but the assembly
  -- into a J-rule has not yet been packaged.
  sorry

end CubicalTransport.Truncation