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

/-
  CubicalTransport.SIP
  ====================
  Structure Identity Principle (THEORY.md §0.4 — "Structure
  identity principle").

  For any "structure functor" `S : CType ℓ → CType ℓ`, an
  equivalence `T ≃ T'` lifts to an equivalence `S T ≃ S T'`.
  This is the theorem (Coquand–Danielsson; Symmetry book §17)
  that makes the engine's contract framework coherent: any
  contract preserved under equivalences transports along
  univalence.

  ## What this file provides

  · `StructureFunctor` — a Lean-level structure packaging the
    action of a "structure functor" on objects and on
    equivalences.  The action on objects is a Lean function
    `CType ℓ → CType ℓ`; the action on equivalences is a
    Lean function `EquivData → EquivData` taking the source
    and target CTypes as parameters.

  · `StructureFunctor.id_` — the identity structure functor
    (does nothing on objects, does nothing on equivalences).

  · `StructureFunctor.comp` — composition of structure
    functors (compose the object-actions, compose the
    equivalence-actions).

  · `Theorem SIP`: applying `S.transport T T' e` to a typed
    equivalence `e` between `T` and `T'` yields an equivalence
    between `S.toFun T` and `S.toFun T'` whose forward and
    inverse maps are typed at the lifted CTypes.

  · `Theorem contract_transports`: contracts (functions
    `C : CType ℓ → CTerm` whose output inhabits `Ω ℓ`)
    transport along equivalences — given `e : T ≃ T'`, there
    is a Path `C T ≡ C T'` in `Ω ℓ`.

  ## Why `StructureFunctor.transport` is shape-only

  The engine's `EquivData` (from `Equiv.lean`) is a five-CTerm
  bundle without explicit type slots.  Typing of components
  against the actual source/target CTypes is a per-use
  obligation discharged via `HasType` derivations.  Following
  the same convention, `StructureFunctor.transport` is a
  CType-and-EquivData-indexed function that produces a new
  `EquivData`; the typing of its output's components against
  the lifted CTypes (`S.toFun T → S.toFun T'`, etc.) is a
  hypothesis-of-SIP (Theorem `SIP` below).

  ## Discipline

  · `StructureFunctor.id_` and `.comp` produce real
    `EquivData`-valued transports — not stubs.  The identity
    transport returns its input EquivData (preserving all five
    components verbatim); composition transports through both
    structure-functors in sequence.
  · `Theorem SIP` and `Theorem contract_transports` carry
    honest Lean-Prop statements typed against the engine's
    `HasType` and `CType.path` / `CType.pi`.  Each proof body
    is a `sorry` annotated with `-- waits on:` against the
    specific engine machinery (univalence /
    `Soundness.transp_ua`) that's not yet packaged for these
    discharge routes.
  · No `noncomputable`, no `Classical.propDecidable`,
    no `True := trivial` shortcuts.
-/

import CubicalTransport.Equiv
import CubicalTransport.Omega

namespace CubicalTransport.SIP

open CubicalTransport.Omega

-- ── §1.  StructureFunctor ──────────────────────────────────────────────────

/-- A *structure functor* on `CType ℓ`: a Lean-level functorial
    action consisting of (a) an object-action `toFun`, (b) an
    equivalence-action `transport`, and (c) the functoriality
    coherences witnessed externally as theorems.

    ## Fields

    · `toFun : CType ℓ → CType ℓ` — the action on objects.
      Given a CType `A`, produce the "structured" CType `S A`.

    · `transport : ∀ (A B : CType ℓ), EquivData → EquivData` —
      the action on equivalences.  Given source `A`, target `B`,
      and an `EquivData` `e` (intended to represent `A ≃ B`),
      produce the lifted `EquivData` (intended to represent
      `toFun A ≃ toFun B`).  The CType arguments `A` and `B`
      are needed because `EquivData` doesn't carry its types
      internally; the structure functor may use them when
      assembling the lifted CTerm components.

    ## Why no in-structure coherence fields

    Functoriality coherences (transport-preserves-identity,
    transport-preserves-composition) are stated externally as
    theorems on each `StructureFunctor` instance.  Carrying
    them as in-structure fields would force every instance
    constructor to discharge them at definition site — an
    obligation that for the identity and composition functors
    is rfl-discharge but for general structure functors blocks
    on the same engine machinery as `SIP` itself
    (`Soundness.transp_ua`).  Theorem-shape externalises the
    obligation cleanly.

    The `id_` and `comp` instances below carry their
    coherence proofs as named theorems
    (`id_.transport_idEquiv`, `comp.transport_eq_compose`). -/
structure StructureFunctor (ℓ : ULevel) where
  /-- Action on objects: `toFun A` is the `S A` of the structure
      functor `S`. -/
  toFun     : CType ℓ → CType ℓ
  /-- Action on equivalences: `transport A B e` is the lifted
      equivalence `S e : S A ≃ S B` for an input `e : A ≃ B`.

      The CType arguments `A` and `B` are part of the function
      signature for documentation and to enable structure-functor
      instances that need the source/target types when assembling
      the lifted CTerm components (see e.g. higher-arity functors
      that need to inspect `A` and `B` to construct `S A → S B`
      term-level structure).  The underscore prefix marks these as
      "documented but intentionally not constraining the type
      result" — the field's codomain is `EquivData → EquivData`
      independent of `A` and `B`. -/
  transport : ∀ (_A _B : CType ℓ), EquivData → EquivData

namespace StructureFunctor

-- ── §2.  Identity structure functor ────────────────────────────────────────

/-- The identity structure functor: `toFun = id` on objects;
    `transport` returns its input equivalence verbatim.

    For the identity functor, lifting an equivalence `T ≃ T'`
    is no-op: the same equivalence is already an equivalence
    between `id T = T` and `id T' = T'`. -/
def id_ (ℓ : ULevel) : StructureFunctor ℓ where
  toFun A := A
  transport _ _ e := e

/-- The identity functor sends `idEquiv A` to `idEquiv A` —
    a real coherence equation, provable by reflexivity. -/
theorem id_.transport_idEquiv {ℓ : ULevel} (A : CType ℓ) :
    (id_ ℓ).transport A A (idEquiv A) = idEquiv ((id_ ℓ).toFun A) := rfl

/-- The identity functor's `transport` is the identity Lean
    function on `EquivData`. -/
theorem id_.transport_eq_id {ℓ : ULevel} (A B : CType ℓ) (e : EquivData) :
    (id_ ℓ).transport A B e = e := rfl

-- ── §3.  Composition of structure functors ────────────────────────────────

/-- Composition of two structure functors `G ∘ F`: apply `F`
    first on objects and on equivalences, then `G` on top.

    Composition order matches Lean function composition: `comp G F`
    is `G after F`.  The object-action is `G.toFun ∘ F.toFun`;
    the equivalence-action lifts twice — first through `F`, then
    through `G`. -/
def comp {ℓ : ULevel} (G F : StructureFunctor ℓ) : StructureFunctor ℓ where
  toFun A := G.toFun (F.toFun A)
  transport A B e := G.transport (F.toFun A) (F.toFun B) (F.transport A B e)

/-- Composition is functorial in the second argument's identity:
    composing with the identity functor on the right is identity. -/
theorem comp_id_right {ℓ : ULevel} (G : StructureFunctor ℓ) :
    comp G (id_ ℓ) = G := rfl

/-- Composition is functorial in the first argument's identity:
    composing with the identity functor on the left is identity. -/
theorem comp_id_left {ℓ : ULevel} (F : StructureFunctor ℓ) :
    comp (id_ ℓ) F = F := rfl

/-- Composition is associative on `StructureFunctor`. -/
theorem comp_assoc {ℓ : ULevel} (H G F : StructureFunctor ℓ) :
    comp H (comp G F) = comp (comp H G) F := rfl

/-- Composition's `transport` is the composition of the two
    `transport` actions — a real coherence equation, provable
    by reflexivity from the definition of `comp`. -/
theorem comp.transport_eq_compose {ℓ : ULevel}
    (G F : StructureFunctor ℓ) (A B : CType ℓ) (e : EquivData) :
    (comp G F).transport A B e =
      G.transport (F.toFun A) (F.toFun B) (F.transport A B e) := rfl

end StructureFunctor

-- ── §4.  Theorem SIP ──────────────────────────────────────────────────────

/-- Structure Identity Principle (Coquand–Danielsson; Symmetry
    book §17; THEORY.md §0.4).

    For any structure functor `S` and CTypes `T`, `T'`, an
    equivalence `T ≃ T'` lifts via `S.transport T T'` to an
    equivalence `S.toFun T ≃ S.toFun T'`.

    ## Statement shape

    Stated against the engine's `HasType` and `EquivData`:

    · **Hypotheses**: `e : EquivData` whose forward and inverse
      maps are typed at the source/target CTypes (`e.f : T → T'`,
      `e.fInv : T' → T`).

    · **Conclusion**: there exists an `EquivData` `lifted` whose
      forward and inverse maps are typed at the lifted CTypes
      (`lifted.f : S.toFun T → S.toFun T'`,
       `lifted.fInv : S.toFun T' → S.toFun T`).

    The witness for `lifted` is `S.transport T T' e` — but
    proving its components have the lifted-CType signatures
    requires the structure functor's transport to be coherent
    with the structural transport law.  In the present setting,
    where `StructureFunctor.transport` is shape-only, that
    coherence is the discharge obligation.

    ## Discharge

    For `S = id_ ℓ` (the identity structure functor), the lifted
    equivalence is the input equivalence (by
    `id_.transport_eq_id`); the typing follows directly from the
    hypotheses.  This case is `rfl`-style and is not blocked.

    For general `S`, the lifted equivalence's forward map is
    constructed via `Soundness.transp_ua`: an equivalence
    `T ≃ T'` lifts to a path `Path .univ T T'` (via Glue at the
    boundary), which transports through `S.toFun`'s action on
    the universe to a path `Path .univ (S.toFun T) (S.toFun T')`,
    which then unfolds via `transp_ua` to an equivalence
    `S.toFun T ≃ S.toFun T'`.  The full discharge requires
    `Soundness.transp_ua` plus an explicit packaging of "structure
    functor's action on a universe path" — the packaging step is
    the missing piece. -/
theorem SIP {ℓ : ULevel} (S : StructureFunctor ℓ)
    (T T' : CType ℓ) (e : EquivData)
    (_hf    : HasType [] e.f    (CType.pi "_" T  T'))
    (_hfInv : HasType [] e.fInv (CType.pi "_" T' T )) :
    ∃ (lifted : EquivData),
      HasType [] lifted.f    (CType.pi "_" (S.toFun T)  (S.toFun T')) ∧
      HasType [] lifted.fInv (CType.pi "_" (S.toFun T') (S.toFun T )) := by
  -- waits on: Soundness.transp_ua (univalence) packaged as a
  -- structure-functor-coherence rule.  The witness is `S.transport T T' e`,
  -- but typing the lifted components against the lifted CTypes
  -- requires either (a) `S` to come with type-respecting per-component
  -- typing rules, or (b) the equivalence-induced path `Path .univ T T'`
  -- to be transportable through `S.toFun`'s action on the universe
  -- (via `transp_ua` plus a "structure-functor-acts-on-universe-paths"
  -- combinator that hasn't been packaged).
  sorry

-- ── §5.  Theorem: contracts transport ──────────────────────────────────────

/-- Every contract — a function `C : CType ℓ → CTerm` whose
    output inhabits `Ω ℓ` — transports along equivalences:
    given `e : T ≃ T'`, there is a Path `C T ≡ C T'` in `Ω ℓ`.

    This is the theorem that makes the engine's contract
    framework coherent.  Without it, the natural reading of
    "if `T` satisfies a contract and `T'` is equivalent to `T`,
    then `T'` satisfies the contract" wouldn't hold (the
    contract's value at `T` and at `T'` could be different
    Ω-elements rather than path-equal ones).

    ## Statement shape

    · **Hypotheses**: `C` outputs to `Ω ℓ` for every input
      (`hC : ∀ A, HasType [] (C A) (Ω ℓ)`); equivalence `e : T ≃ T'`
      with typed forward and inverse maps.

    · **Conclusion**: there is a CTerm `path` of type
      `Path (Ω ℓ) (C T) (C T')`.

    ## Discharge

    Apply `SIP` (above) with `S = C` viewed as a structure
    functor (action on objects: `A ↦ <Ω-CType-from-(C A)>`;
    action on equivalences: lifted via the universe-of-Ω
    path).  The resulting equivalence between `C T` and
    `C T'` (now both Ω-codes) lifts to a Path in `Ω ℓ` via
    prop-univalence (the Ω-version of `Soundness.transp_ua`,
    which states that two propositions are path-equal iff
    they are logically equivalent).

    Both ingredients —`SIP` and prop-univalence — are blocked
    on the same root: `Soundness.transp_ua` is theorems-discharged
    in `Soundness.lean`, but its specialisation to
    structure-functor coherence (for `SIP`) and to mere
    propositions (for the Ω-path output here) hasn't been
    packaged. -/
theorem contract_transports {ℓ : ULevel}
    (C : CType ℓ → CTerm) (T T' : CType ℓ) (e : EquivData)
    (_hC    : ∀ A, HasType [] (C A) (Ω ℓ))
    (_hf    : HasType [] e.f    (CType.pi "_" T  T'))
    (_hfInv : HasType [] e.fInv (CType.pi "_" T' T )) :
    ∃ (path : CTerm), HasType [] path (CType.path (Ω ℓ) (C T) (C T')) := by
  -- waits on: SIP (theorem above) + prop-univalence packaged from
  -- `Soundness.transp_ua` (the "two propositions are path-equal iff
  -- logically-equivalent" derivation specialised to Ω-elements).  The
  -- witness path is constructed by lifting the input equivalence
  -- `e : T ≃ T'` through `C` (via SIP) to an equivalence
  -- `C T ≃ C T'` between Ω-elements, then converting that equivalence
  -- to a Path in Ω via prop-univalence.
  sorry

end CubicalTransport.SIP