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

/-
  CubicalTransport.Soundness
  =========================
  The Phase 1 Week 6 closeout — soundness theorems that tie transport,
  composition, and glue into a coherent story (cells-spec §14 "Key
  Theorems", Cubical Core section).

  **What this file does:** restate the critical proof obligations from
  §14 as Lean theorems, prove what is derivable from the existing axiom
  base (T1–T5, C1/C2/C4, the six glueIn/unglue face-disjoint axioms,
  the eval-level axioms), and clearly mark remaining obligations with
  their discharge conditions.

  **Why this file exists:** to make the "Phase 1 complete" claim
  auditable.  Every obligation is either proved or stated as a named
  axiom with a documented discharge path.  Future work (Glue transport,
  Phase 2 cells) slots in by *proving* these axioms rather than by
  restructuring the module layout.

  ## Proved theorems (from existing axioms)

  §3 `transp_refl_eval`         — eval-level constant-line transport identity
                                  (combines `eval_transp_top` and `eval_transp_const`).
  §4 `hcomp_face_top`           — C1: composition under full face = tube at 1.
  §5 `ua_endpoints_zero / _one` — univalence line endpoints (re-export).
  §6 `glue_beta_bot`            — unglue-of-glue on the empty face is identity.
  §7 `glue_eta_bot`             — glue-of-unglue on the empty face is identity.

  Step-level T1/T2/C1 wrappers (`transp_refl_step`, `transp_refl_const_step`,
  `hcomp_face_top_step`) have been removed — their underlying axioms are
  now NbE theorems in `Readback.lean` (`readback_transp_id`,
  `readback_transp_const_id`, `readback_comp_full`).

  ## Proof obligations (axioms to be discharged later)

  - `transp_ua` — transport along a `uaLine e A B` at `.bot` computes as
    `e.f`.  Needs a Glue transport rule on `CTerm.transp i (.glue …) φ t`
    (the CCHM formula using half-adjoint structure).  Currently outside
    scope; stated here so `Soundness.lean` can be pointed at when the
    Glue transport rule lands.

  - `glue_beta_top`, `glue_eta_top` — full CCHM glue β/η on the `.top`
    face.  These hold only up to the equivalence's *coherence* rules
    (`e.f ∘ e.fInv ~ id`, etc.), which are terms in the calculus, not
    rewrite rules.  A term-evaluator with conversion modulo β would
    discharge them; our syntactic `eval` cannot.

  - `cell_*` laws (idL / idR / assoc / inv / interchange) — Phase 2
    cells-layer work; stated briefly below for completeness.
-/

import CubicalTransport.TransportLaws
import CubicalTransport.CompLaws
import CubicalTransport.Glue

namespace Soundness

-- ── §1–2. Transport identity at NbE level ───────────────────────────────────
-- The step-level T1 (`transp_id`) and T2 (`transp_const_id`) wrappers
-- formerly here have been removed; their NbE equivalents live in
-- `Readback.lean` as `readback_transp_id` and `readback_transp_const_id`.
-- The eval-level identity below (`transp_refl_eval`) is the convenient
-- downstream surface.

-- ── §3. Eval-level constant-line transport ───────────────────────────────────

/-- Eval-level constant-line identity.  Combines `eval_transp_top` with
    `eval_transp_const` to cover every face. -/
theorem transp_refl_eval {ℓ : ULevel} (env : CEnv) (i : DimVar) (A : CType ℓ)
    (φ : FaceFormula) (t : CTerm) (hA : CType.dimAbsent i A = true) :
    eval env (.transp i A φ t) = eval env t := by
  by_cases hφ : φ = .top
  · subst hφ; exact eval_transp_top env i A t
  · exact eval_transp_const env i A φ t hφ hA

-- ── §4. Composition agrees with the tube on full face (C1) ───────────────────

/-- `hcomp_faces` (cells-spec §14): composition under a full face
    reduces to the tube body substituted at the 1-endpoint.  This is the
    "composition agrees with tube on constrained face" obligation;
    at `.top` the constraint is total. -/
theorem hcomp_face_top {ℓ : ULevel} (env : CEnv) (i : DimVar) (A : CType ℓ) (u t : CTerm) :
    eval env (.comp i A .top u t) = eval env (u.substDim i .one) :=
  eval_comp_top env i A u t

-- The step-level C1 wrapper (`hcomp_face_top_step`, formerly using
-- `comp_full`) has been removed alongside the C1 axiom; the NbE form
-- `readback_comp_full` in `Readback.lean` is now the canonical statement.

-- ── §5. Univalence line endpoints ────────────────────────────────────────────

/-- `ua_endpoints` (cells-spec §14, half 1): the left endpoint of the
    univalence line is the full-face glue, which computationally behaves
    like `A` via `e`. -/
theorem ua_endpoints_zero {ℓ : ULevel} (e : EquivData) (A B : CType ℓ) :
    uaLine e A B .zero = e.toGlueType .top A B :=
  uaLine_zero e A B

/-- `ua_endpoints` (half 2): the right endpoint is the empty-face glue,
    which computationally is just `B`. -/
theorem ua_endpoints_one {ℓ : ULevel} (e : EquivData) (A B : CType ℓ) :
    uaLine e A B .one = e.toGlueType .bot A B :=
  uaLine_one e A B

/-- The univalence line, evaluated at `r = 0`, has inhabitants that
    behave like `A` (via `e.f`) under `unglue`.  Consumers of the left
    endpoint can rely on this without unfolding `uaLine`. -/
theorem ua_endpoint_zero_unglue (env : CEnv) (f g : CTerm) :
    eval env (.unglue .top f g) = vApp (eval env f) (eval env g) :=
  eval_unglue_top env f g

/-- At `r = 1`, `unglue` is the identity — inhabitants behave like `B`. -/
theorem ua_endpoint_one_unglue (env : CEnv) (f g : CTerm) :
    eval env (.unglue .bot f g) = eval env g :=
  eval_unglue_bot env f g

-- ── §6. glue β on the empty face ─────────────────────────────────────────────

/-- `glue_beta` (cells-spec §14), restricted to the empty face:
    `unglue [.bot ↦ f] (glueIn [.bot ↦ t] a) = a`.

    Derivation:
      · `glueIn .bot t a` evaluates to `a` (by `eval_glueIn_bot`).
      · `unglue .bot f a` evaluates to `a` (by `eval_unglue_bot`).

    Under the `.bot` face the glue type is definitionally `A`, so glue-
    formation and elimination are both identity — the β-rule holds
    *definitionally* on this face. -/
theorem glue_beta_bot (env : CEnv) (f t a : CTerm) :
    eval env (.unglue .bot f (.glueIn .bot t a)) = eval env a := by
  -- We can't rewrite under the `.glueIn` literal inside `eval` without
  -- unfolding `eval`, so we work via the axiom set directly: the two
  -- operations combine at the value level, not the term level.
  -- But: the outer `.unglue .bot f (.glueIn .bot t a)` evaluates via
  -- `eval_unglue_bot`, which produces `eval env (.glueIn .bot t a)`,
  -- which then reduces via `eval_glueIn_bot` to `eval env a`.
  rw [eval_unglue_bot env f (.glueIn .bot t a),
      eval_glueIn_bot env t a]

-- ── §7. glue η on the empty face ─────────────────────────────────────────────

/-- `glue_eta` (cells-spec §14), restricted to the empty face:
    `glueIn [.bot ↦ t] (unglue [.bot ↦ f] g) = g`.

    Derivation:
      · `glueIn .bot t (unglue .bot f g)` evaluates via `eval_glueIn_bot`
        to `eval env (.unglue .bot f g)`.
      · That reduces via `eval_unglue_bot` to `eval env g`.

    The η rule holds definitionally on `.bot`: glue and unglue are both
    identity there, so their composition is identity. -/
theorem glue_eta_bot (env : CEnv) (t f g : CTerm) :
    eval env (.glueIn .bot t (.unglue .bot f g)) = eval env g := by
  rw [eval_glueIn_bot env t (.unglue .bot f g),
      eval_unglue_bot env f g]

-- ── §8. Outstanding proof obligations ────────────────────────────────────────

/-!
### Proof obligations awaiting later work

The remaining theorems from cells-spec §14 cannot be discharged from the
current axiom base.  Each is stated here as an **axiom** with a
documented discharge path; later modules will prove them by providing
the missing rule and rewriting the axiom statement as a theorem.

-/

/-- `transp_ua` (cells-spec §14, Critical): transport along the univalence
    line at the empty face computes as the forward map of the equivalence.

    **Now discharged as a theorem.**  Proof chain:
      1. Unfold `uaLine e A B (.var i)` to
         `.glue (.eq0 i) A e.f e.fInv e.sec e.ret e.coh B`.
      2. Observe `(.eq0 i).substDim i .one = dimExprEq0 .one = .bot`, so the
         restricted-form Glue-transport axiom applies.
      3. Apply `eval_transp_glue_const_at_bot` to reduce the transport to
         `.transp i B .bot (.unglue ((.eq0 i).substDim i .zero) e.f t)`.
      4. Observe `(.eq0 i).substDim i .zero = dimExprEq0 .zero = .top`, so
         the inner unglue is `unglue .top e.f t`.
      5. `B` is dim-absent from `i` (hypothesis), so the outer transport
         reduces to the identity via T2 (`eval_transp_const`).
      6. `unglue .top e.f t` evaluates to `vApp (eval e.f) (eval t)` via
         `eval_unglue_top`.

    The dim-absence hypotheses formalise the well-scopedness assumption
    that `e`, `A`, `B` are supplied from outside the transport binder. -/
theorem transp_ua {ℓ : ULevel} (env : CEnv) (i : DimVar) (e : EquivData) (A B : CType ℓ)
    (t : CTerm)
    (hA : A.dimAbsent i = true)
    (hB : B.dimAbsent i = true)
    (hf : e.f.dimAbsent i = true)
    (hfInv : e.fInv.dimAbsent i = true)
    (hsec : e.sec.dimAbsent i = true)
    (hret : e.ret.dimAbsent i = true)
    (hcoh : e.coh.dimAbsent i = true) :
    eval env (.transp i (uaLine e A B (.var i)) .bot t) =
    vApp (eval env e.f) (eval env t) := by
  -- Step 1: unfold `uaLine` / `toGlueType` / `dimExprEq0 (.var i)` — all rfl.
  show eval env (.transp i
      (.glue (FaceFormula.eq0 i) A e.f e.fInv e.sec e.ret e.coh B) .bot t) = _
  -- Step 2: compute the substDim facts about the inner face.
  have hφ1 : (FaceFormula.eq0 i).substDim i .one = .bot := by
    show (if i = i then FaceFormula.dimExprEq0 DimExpr.one else FaceFormula.eq0 i) = .bot
    simp [FaceFormula.dimExprEq0]
  have hφ0 : (FaceFormula.eq0 i).substDim i .zero = .top := by
    show (if i = i then FaceFormula.dimExprEq0 DimExpr.zero else FaceFormula.eq0 i) = .top
    simp [FaceFormula.dimExprEq0]
  -- Step 3: apply the restricted-form Glue-transport axiom.
  rw [eval_transp_glue_const_at_bot env i (FaceFormula.eq0 i) A
        e.f e.fInv e.sec e.ret e.coh B .bot t
        (by intro h; nomatch h)
        hA hB hf hfInv hsec hret hcoh hφ1]
  -- Step 4: simplify the inner face at `i = 0` to `.top`.
  rw [hφ0]
  -- Step 5: T2 on the constant `B` line, at `.bot ≠ .top`.
  rw [eval_transp_const env i B .bot _ (by intro h; nomatch h) hB]
  -- Step 6: `unglue .top` is forward-map application.
  exact eval_unglue_top env e.f t

/-- `transp_ua_inverse` (companion to `transp_ua`): transport along the
    "reversed" univalence line at the empty face computes as the inverse
    map of the equivalence.

    Construction: `uaLine e A B (.inv (.var i))` carries the inner glue
    face `dimExprEq0 (.inv (.var i)) = dimExprEq1 (.var i) = .eq1 i`
    (rather than `.eq0 i` for the forward `(.var i)` direction).  At
    `i := 1` this collapses to `.top`, triggering
    `eval_transp_glue_const_at_top` and producing the T-side witness via
    `e.fInv`.  At `i := 0` the inner face is `.bot`, so the inner
    `unglue` is identity; `B` is constant in `i`, so the outer transport
    is identity (T2); the result is `e.fInv` applied to the input.

    Together with `transp_ua`, this exhibits the two principal directions
    of the equivalence as the computational content of Glue transport at
    the constant-component sub-cases. -/
theorem transp_ua_inverse {ℓ : ULevel} (env : CEnv) (i : DimVar) (e : EquivData) (A B : CType ℓ)
    (t : CTerm)
    (hA : A.dimAbsent i = true)
    (hB : B.dimAbsent i = true)
    (hf : e.f.dimAbsent i = true)
    (hfInv : e.fInv.dimAbsent i = true)
    (hsec : e.sec.dimAbsent i = true)
    (hret : e.ret.dimAbsent i = true)
    (hcoh : e.coh.dimAbsent i = true) :
    eval env (.transp i (uaLine e A B (.inv (.var i))) .bot t) =
    vApp (eval env e.fInv) (eval env t) := by
  -- Step 1: unfold `uaLine` / `toGlueType` / `dimExprEq0 (.inv (.var i))`.
  -- `dimExprEq0 (.inv r) = dimExprEq1 r` and `dimExprEq1 (.var i) = .eq1 i`,
  -- both by rfl on the case-splits in `Face.lean`.
  show eval env (.transp i
      (.glue (FaceFormula.eq1 i) A e.f e.fInv e.sec e.ret e.coh B) .bot t) = _
  -- Step 2: compute the substDim facts about the inner face.
  have hφ1 : (FaceFormula.eq1 i).substDim i .one = .top := by
    show (if i = i then FaceFormula.dimExprEq1 DimExpr.one else FaceFormula.eq1 i) = .top
    simp [FaceFormula.dimExprEq1]
  have hφ0 : (FaceFormula.eq1 i).substDim i .zero = .bot := by
    show (if i = i then FaceFormula.dimExprEq1 DimExpr.zero else FaceFormula.eq1 i) = .bot
    simp [FaceFormula.dimExprEq1]
  -- Step 3: apply the `_at_top` axiom.
  rw [eval_transp_glue_const_at_top env i (FaceFormula.eq1 i) A
        e.f e.fInv e.sec e.ret e.coh B .bot t
        (by intro h; nomatch h)
        hA hB hf hfInv hsec hret hcoh hφ1]
  -- Step 4: simplify the inner face at `i = 0` to `.bot`.
  rw [hφ0]
  -- Step 5: peel the outer `.app` so we can rewrite under it.
  rw [eval_app env e.fInv
        (.transp i B .bot (.unglue .bot e.f t))]
  -- Step 6: T2 on the constant `B` line.
  rw [eval_transp_const env i B .bot _ (by intro h; nomatch h) hB]
  -- Step 7: `unglue .bot` is identity.
  rw [eval_unglue_bot env e.f t]

/-- `glue_beta` (cells-spec §14, full statement): on any face, `unglue` of
    `glueIn` returns the A-side, provided the equivalence's overlap
    condition `e.f t = a` holds (implicit in glueIn's well-typedness).

    **Discharged via `eval_unglue_of_glueIn`** (Eval.lean, Stage 1.3,
    2026-04-23).  The eval-level β-rule recognises the redex shape
    and short-circuits under the `h_overlap` hypothesis.  This is no
    longer an axiom at the Soundness layer — the axiom provenance is
    now a single eval-level Rust-discharge rule. -/
theorem glue_beta (env : CEnv) (φ : FaceFormula) (f t a : CTerm)
    (h_overlap :
        eval env (.app f t) = eval env a) :
    eval env (.unglue φ f (.glueIn φ t a)) = eval env a :=
  eval_unglue_of_glueIn env φ f t a h_overlap

/-- `glue_eta` (cells-spec §14, full statement): on any face, `glueIn`
    of `unglue` returns the original term, under the overlap condition
    `t = e.f g`.

    **Discharged via `eval_glueIn_of_unglue`** (Eval.lean, Stage 1.3,
    2026-04-23).  Dual to `glue_beta`; same discipline. -/
theorem glue_eta (env : CEnv) (φ : FaceFormula) (f t g : CTerm)
    (h_overlap :
        eval env t = eval env (.app f g)) :
    eval env (.glueIn φ t (.unglue φ f g)) = eval env g :=
  eval_glueIn_of_unglue env φ f t g h_overlap

/-!
### Phase 2 cells-layer laws (deferred)

The cell-layer laws (`cell_left_unit`, `cell_right_unit`, `cell_assoc`,
`cell_inv_left`, `par_seq_interchange`) are Phase 2 material — they
require a `Cell` structure with composition operations, which we haven't
built.  The cells-spec §14 Cell Layer rows are therefore neither proved
nor stated as axioms in this module; they will arise as theorems (not
axioms) in `Cell/Basic.lean` and `Cell/Compose.lean` once those exist,
with the cell structure itself being defined in terms of the cubical
primitives proved here.
-/

end Soundness