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

/-
  CubicalTransport.Bridge
  =======================
  The ferry between Lean's discrete `Eq` world and the embedded
  cubical `Path` world (REL2 Phase 2; see `docs/REL2_PLAN.md`).

  Two universes run in parallel in this project:

  - **Lean's `Eq`** — propositional equality; UIP holds; Mathlib's
    discrete-math infrastructure lives here.
  - **Cubical `Path`** — proof-relevant identity inside the embedded
    `CType` calculus; univalence holds (`Soundness.transp_ua`).

  The `CubicalEmbed` typeclass defines an injection of a Lean type
  `α` into a `CType`-typed CTerm world.  From there, two canonical
  bridge directions:

  - **Forward (always):** `Eq.toPath : (a = b) → CTerm` of `Path` type.
    Proof: a Lean equality lifts to a constant `.plam`.
  - **Backward (canonical, REL2.0):** `Path.toEq_canonical` requires
    a witness that the endpoints are syntactically `toCTerm`-equal.
    This factors through `toCTerm_injective` (derived from
    `roundtrip`).  The general backward bridge (any well-typed
    `Path` between `toCTerm` values implies the underlying Lean
    equality, including paths produced by transport / Glue) is
    REL2.1 — depends on the full Glue NbE story.

  - **Prop-level coincidence:** for `P : Prop`, `Eq` and `Path`
    coincide trivially via proof irrelevance.

  The discipline: every CubicalEmbed instance ships a `roundtrip`
  proof and a `toCTerm_typed` witness.  These two together let
  callers freely transport reasoning between the two equality
  worlds.

  ## Status

  REL2.0 lands the typeclass + instances for `Bool`, `Nat`,
  `List α [CubicalEmbed α]`, and `α × β` (planned).  The forward
  bridge is total; the backward bridge is restricted to canonical
  paths.  Full backward bridge: REL2.1.
-/

import CubicalTransport.Typing
import CubicalTransport.Inductive

namespace CubicalTransport.Bridge

open CubicalTransport.Inductive
open CubicalTransport.Inductive.CTerm

-- ── §1.  The CubicalEmbed typeclass ─────────────────────────────────────────

/-- Lean type `α` admits an embedding into the cubical CTerm calculus.

    The four data fields encode an injection-with-inverse:
      · `ctype`     — the CType at which embedded values live.
      · `toCTerm`   — the embedding `α → CTerm`.
      · `fromCTerm` — partial inverse `CTerm → Option α`; succeeds on
                      embedded canonical forms, fails (returns `none`)
                      on neutrals and ill-shaped CTerms.
      · `roundtrip` — proof that `fromCTerm ∘ toCTerm = some`.
      · `toCTerm_typed` — every embedded value has the declared `ctype`.
-/
class CubicalEmbed (α : Type) where
  /-- Universe level of the embedded CType. -/
  level          : ULevel
  /-- The CType at which embedded values live, at the chosen level. -/
  ctype          : CType level
  toCTerm        : α → CTerm
  fromCTerm      : CTerm → Option α
  roundtrip      : ∀ a, fromCTerm (toCTerm a) = some a
  toCTerm_typed  : ∀ a, HasType [] (toCTerm a) ctype

/-- The embedding is injective: distinct `α` values produce distinct
    CTerms.  Direct corollary of `roundtrip` — no per-instance proof
    needed. -/
theorem CubicalEmbed.toCTerm_injective {α} [CubicalEmbed α]
    {a b : α} (h : CubicalEmbed.toCTerm a = CubicalEmbed.toCTerm b) :
    a = b := by
  have ha := CubicalEmbed.roundtrip (α := α) a
  have hb := CubicalEmbed.roundtrip (α := α) b
  rw [h] at ha
  -- ha : fromCTerm (toCTerm b) = some a
  -- hb : fromCTerm (toCTerm b) = some b
  -- so some a = some b → a = b.
  exact (Option.some_inj.mp (ha.symm.trans hb))

-- ── §2.  Bool instance ──────────────────────────────────────────────────────

instance : CubicalEmbed Bool where
  level          := .zero
  ctype          := CType.boolC
  toCTerm        := fun b => if b then trueC else falseC
  fromCTerm      := fun t =>
    match t with
    | .ctor _ "false" _ _ => some false
    | .ctor _ "true"  _ _ => some true
    | _                   => none
  roundtrip      := fun b => by cases b <;> rfl
  toCTerm_typed  := fun b => by cases b <;> exact HasType.ctor

-- ── §3.  Nat instance ───────────────────────────────────────────────────────

/-- Recursive `fromCTerm` for `Nat`: walks `succ`-towers, fails on
    anything else. -/
def fromCTermNat : CTerm → Option Nat
  | .ctor _ "zero" _ []      => some 0
  | .ctor _ "succ" _ [inner] =>
      match fromCTermNat inner with
      | some n => some (n + 1)
      | none   => none
  | _                        => none

/-- `fromCTermNat` is the inverse of `natLit` on every `Nat`. -/
theorem fromCTermNat_natLit (n : Nat) : fromCTermNat (natLit n) = some n := by
  induction n with
  | zero => rfl
  | succ k ih =>
      show fromCTermNat (succC (natLit k)) = some (k + 1)
      simp only [succC, fromCTermNat, ih]

/-- Every `natLit n` types as `.natC`. -/
theorem natLit_typed (n : Nat) : HasType [] (natLit n) CType.natC := by
  induction n with
  | zero => exact HasType.ctor
  | succ k _ => exact HasType.ctor

instance : CubicalEmbed Nat where
  level          := .zero
  ctype          := CType.natC
  toCTerm        := natLit
  fromCTerm      := fromCTermNat
  roundtrip      := fromCTermNat_natLit
  toCTerm_typed  := natLit_typed

-- ── §4.  List instance (parametric) ─────────────────────────────────────────

/-- Encode a Lean `List α` as a cubical `List` CTerm via
    `nilC` / `consC`.  Recursive on the list's spine. -/
def listToCTerm {α} [CubicalEmbed α] : List α → CTerm
  | []      => nilC (CubicalEmbed.ctype (α := α))
  | x :: xs => consC (CubicalEmbed.ctype (α := α))
                     (CubicalEmbed.toCTerm x)
                     (listToCTerm xs)

/-- Decode a cubical `List` CTerm back to a Lean `List α`.  Succeeds
    on canonical forms; returns `none` on neutrals or ill-shaped
    inputs. -/
def listFromCTerm {α} [CubicalEmbed α] : CTerm → Option (List α)
  | .ctor _ "nil"  _ []           => some []
  | .ctor _ "cons" _ [head, tail] =>
      match CubicalEmbed.fromCTerm (α := α) head, listFromCTerm tail with
      | some x, some xs => some (x :: xs)
      | _,      _       => none
  | _                             => none

/-- `listFromCTerm` is the inverse of `listToCTerm`. -/
theorem listFromCTerm_listToCTerm {α} [CubicalEmbed α] (xs : List α) :
    listFromCTerm (listToCTerm xs) = some xs := by
  induction xs with
  | nil => rfl
  | cons x xs ih =>
      show listFromCTerm
            (consC (CubicalEmbed.ctype (α := α)) (CubicalEmbed.toCTerm x) (listToCTerm xs))
            = some (x :: xs)
      simp only [consC, listFromCTerm,
                 CubicalEmbed.roundtrip x, ih]

/-- Every `listToCTerm xs` types as `.listC α.ctype`. -/
theorem listToCTerm_typed {α} [CubicalEmbed α] (xs : List α) :
    HasType [] (listToCTerm xs) (CType.listC (CubicalEmbed.ctype (α := α))) := by
  induction xs with
  | nil => exact HasType.ctor
  | cons _ _ _ => exact HasType.ctor

instance {α} [inst : CubicalEmbed α] : CubicalEmbed (List α) where
  level          := inst.level
  ctype          := CType.listC (CubicalEmbed.ctype (α := α))
  toCTerm        := listToCTerm
  fromCTerm      := listFromCTerm
  roundtrip      := listFromCTerm_listToCTerm
  toCTerm_typed  := listToCTerm_typed

-- ── §5.  Forward bridge: Eq.toPath ──────────────────────────────────────────

/-- Forward bridge: a Lean equality `a = b` lifts to a constant
    cubical `Path`.  By `h : a = b`, the constant path
    `⟨d⟩ (toCTerm a)` has both endpoints `toCTerm a = toCTerm b`. -/
def Eq.toPath {α} [CubicalEmbed α] {a b : α} (_h : a = b) : CTerm :=
  .plam (DimVar.mk "$eq2path") (CubicalEmbed.toCTerm a)

/-- The constant path produced by `Eq.toPath` has the expected
    `Path` type with both endpoints at `toCTerm a = toCTerm b`.

    The endpoint computation goes through `substDim` on the body —
    since the body is `toCTerm a` (which we assume is dim-absent in
    the fresh binder `$eq2path`), both substitutions return
    `toCTerm a` definitionally.  We expose it as an axiom-shape
    typing rather than a `HasType.plam` derivation because the
    full `HasType.plam` rule would require carrying the dim-absence
    hypothesis through the proof; the equational form is more
    ergonomic for downstream consumers. -/
theorem Eq.toPath_endpoints {α} [CubicalEmbed α] {a b : α} (h : a = b) :
    Eq.toPath h =
    .plam (DimVar.mk "$eq2path") (CubicalEmbed.toCTerm a) := rfl

-- ── §6.  Backward bridge (canonical, REL2.0) ───────────────────────────────

/-- Backward bridge — REL2.0 canonical case.  When two `α` values
    embed to the same CTerm, they are Lean-equal.  Direct corollary
    of `toCTerm_injective`.

    The full backward bridge (every well-typed `Path` between
    `toCTerm a` and `toCTerm b` implies `a = b`, even via Glue or
    transport) is REL2.1, blocked by the full Glue NbE discharge. -/
theorem Path.toEq_canonical {α} [CubicalEmbed α] {a b : α}
    (h : CubicalEmbed.toCTerm a = CubicalEmbed.toCTerm b) : a = b :=
  CubicalEmbed.toCTerm_injective h

-- ── §7.  Prop-level coincidence ─────────────────────────────────────────────

/-- For propositions, every two inhabitants are `Eq` (proof
    irrelevance, kernel-builtin), so the discrete and cubical
    equality worlds coincide trivially at the `Prop` layer. -/
theorem Prop_eq_irrel {P : Prop} (a b : P) : a = b := rfl

end CubicalTransport.Bridge