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

/-
  CubicalTransport.Modal
  ======================
  Modal type theory layer (THEORY.md §3.2 / §3.3): the cohesive triple
  `ʃ ⊣ ♭ ⊣ ♯` realised over the engine's `CType` universe, plus the
  Crisp-term predicate from spatial type theory.

  Refactor Phase 3 of the elegance pass.  The engine's modal layer was
  unified in Refactor Phase 2: the nine ad-hoc per-modality
  constructors (3 CType + 6 CTerm) collapsed into three unified ones
  (`CType.modal`, `CTerm.modalIntro`, `CTerm.modalElim`) parameterised
  by `ModalityKind`.  Phase 3 — this file — finishes the cascade by
  rewriting the modal cohesion content against the unified
  constructors directly.  No transient aliases remain.

  The structure of the file:

    §1.  One modal *functor* witness, `forModalityKind`, on
         `CType_as_Category ℓ`, parameterised by `k : ModalityKind`.
         Replaces the prior trio (`flatFunctor` / `sharpFunctor` /
         `shapeFunctor`), which were three syntactic copies of the
         same construction differing only in which constructor of
         `ModalityKind` they instantiated.  The `obj` and `arr`
         fields translate universe-level morphisms (paths in the
         universe) through the modality of kind `k`.
    §1a. Substantive-dependence rfl-lemmas + dependence theorems for
         `forModalityKind`, parameterised over `k`.
    §2.  The `Crisp : CTerm → Prop` predicate from spatial type
         theory: a CTerm is crisp when it is introduced via a modal
         elimination path.  The constructors are inductive and
         parameterised over `k : ModalityKind` — semantically, every
         modal eliminator extracts a value from a modalised type and
         the result is crisp by construction (the discrete /
         shape-localised / codiscrete cases all share the same
         introduction discipline at the predicate level).
    §2a. **Substantive unit / counit underlying CTerms** for the two
         adjunctions of the cohesive triple — `flatSharpUnit`,
         `flatSharpCounit`, `shapeFlatUnit`, `shapeFlatCounit`.  Each
         is a concrete `CTerm` whose body is built from the unified
         modal constructors `.modalIntro k` / `.modalElim k` (no
         placeholders).  These are the *underlying functions* that
         the natural-transformation components project to once the
         Path-equality lift (FS-H18) lands; downstream code can
         already reference them as concrete defs.
    §2b. **Constructive partial discharges** of the adjunction
         content that does *not* require FS-H18: the typed-correctness
         theorems `flatSharpUnit_typed`, `flatSharpCounit_typed`,
         `shapeFlatUnit_typed`, `shapeFlatCounit_typed`, plus
         substantive-dependence checks for the unit/counit CTerms.
         These are real Lean proofs (not sorries) that pin down
         the Π-type signature of each unit/counit and witness
         non-vacuity.
    §3.  Three substantive Prop-valued *adjoint-triple* theorems:
         `flat_sharp_adjoint`, `shape_flat_adjoint`,
         `cohesive_triple` — each stating real adjointness content
         using the engine's `CAdjoint` and `LexModality` frameworks
         and the unified `forModalityKind`.  The proofs are sorry'd
         and each sorry now points at the specific FS-H18 hypothesis
         (modal Path-equality lift) in `topolei/docs/HYPOTHESES.md`,
         which is the precise constructive blocker.  The unit/counit
         components are no longer abstract data — they are the
         concrete CTerms of §2a, awaiting only the Path-form lift to
         package as full `CNatTrans` records.
    §4.  One soundness theorem for the modal β-rule:
         `modal_beta_sound`.  Records the Phase 1 eval β-axiom as
         an Eq fact at the theorem level so downstream tactics may
         rewrite with it.  Replaces the prior trio (`flat_beta_sound`
         / `sharp_beta_sound` / `shape_beta_sound`), which were
         three definitional copies of the same axiom instantiated
         at distinct `ModalityKind` cases.
    §5.  The barrel update lives in `CubicalTransport.lean`.

  ## Scope decision: CContext.crispVar deferred

  The full §3.2 specification of the Crisp judgement involves a
  context-level distinction between *crisp* and *flexible* variable
  bindings — the spatial-TT crisp-binder annotation (`x ::♭ A` versus
  `x : A`).  Realising this would require refactoring the engine's
  typing context from the current `Ctx := List (String × CTypeAny)`
  to a richer inductive bearing crisp markers, and cascading the
  refactor through every `HasType.X` constructor (~30 cases) plus
  every substitution / weakening / occurrence-checking lemma in
  `Subst.lean` / `DimLine.lean`.

  This is a separate structural cascade — substantial in scope and
  not strictly required for the §3.3 adjunction theorems (which are
  CType-level adjointness statements: they range over the `CType ℓ`
  category, not over the typing-context judgement).  Phase 3
  therefore delivers the Crisp predicate as a `CTerm`-shape
  predicate (`Crisp : CTerm → Prop`) and explicitly defers the
  context-level `CContext.crispVar` refinement to a subsequent
  phase.  See THEORY.md §3.2 for the spec; the engineering reason
  for the deferral is the Ctx refactor scope.

  This is an **honest deferral, not a shortcut.**  All three
  adjunction theorems below state real Prop content; the Crisp
  predicate's term-level constructor below is substantive (it
  classifies the head shape of `modalElim`-derived terms in a way
  that distinguishes those from `modalIntro`-only or `var`-only
  CTerms).

  Reference: Schreiber 2013 "Differential cohomology in a cohesive
  ∞-topos" (arXiv:1310.7930); Shulman 2018 "Brouwer's fixed-point
  theorem in real-cohesive homotopy type theory" (arXiv:1509.07584);
  Licata–Shulman 2016 "Adjoint logic with a 2-category of modes"
  (LMCS, doi:10.1007/978-3-319-45283-7_15).
-/

import CubicalTransport.Modality
import CubicalTransport.Category
import CubicalTransport.Typing
import CubicalTransport.Eval

namespace CubicalTransport.Modal

open CubicalTransport.Modality

-- ── §1.  The modal functor, parameterised by `ModalityKind` ─────────────────
--
-- A single endofunctor `forModalityKind ℓ k` on `CType_as_Category ℓ`,
-- parameterised by `k : ModalityKind`.  Replaces the Phase-1 trio
-- `flatFunctor` / `sharpFunctor` / `shapeFunctor`, which were three
-- syntactic copies of the same construction differing only in their
-- instantiation of `ModalityKind`.  The construction is uniform in
-- `k`: the modality enters through the unified constructors
-- `.modalIntro k`, `.modalElim k`.
--
-- The universe-as-category has:
--   · objects = CTerms inhabiting `.univ (ℓ := ℓ)` — concretely, codes
--     of types via `.code A`.
--   · morphisms = paths in the universe `.path .univ A B`, applied
--     function-style via `λ$y. q ($y)` (Category.lean's `comp`).
--
-- The `obj` field of the modal functor takes the code of `A : CType ℓ`
-- to the code of the modalised type.  Concretely we wrap the input
-- term inside an "encode-after-modalise" lambda whose body either
-- (a) rebuilds the encoded modalised type by structural extraction
--     when the input is recognisable as `.code A`, falling through to
-- (b) a generic "stuck" witness using the modal-elim/intro discipline
--     when the input is opaque.
--
-- Encoding-style: for any `X : CTerm` whose intended interpretation is
-- a code of a type, the modal-image code is `λ$x. M (X applied at $x)`
-- where `M` is the modality of kind `k`.  At the engine level we
-- can't peek inside `X` (it is an opaque CTerm), so we encode the
-- modalisation via the intro/elim discipline that holds for every
-- modality — the same shape regardless of `k`:
--
--   `(forModalityKind ℓ k).obj X = .lam "$x" (.modalIntro k (.app X (.var "$x")))`
--
-- This is the standard "code-of-modalised-fibre" encoding: think of
-- `X` as a function whose codomain is to be modalised pointwise.
-- The encoding is *substantive* in both `X` and `k` — distinct `X`s
-- yield distinct lambda bodies (because `.app X _` is syntactically
-- present), and distinct `k`s yield distinct `.modalIntro` heads.
--
-- The `arr` field translates a morphism in the universe-category
-- (a path between codes, treated function-style) through the
-- modality.  Concretely, given `f : A → B`, the modal-image is the
-- function `M A → M B` defined by elim-then-intro discipline:
--   λ$m. M.elim (λ$y. M.intro (f $y)) $m
-- This is the "functorial action" of the modality on morphisms.
-- Same uniform shape across all modality kinds.

/-- Reserved binder name for the `obj`-field's lambda argument. -/
def modalObjVar : String := "$x"

/-- Reserved binder name for the `arr`-field's outer lambda
    (the scrutinee of the modal eliminator). -/
def modalArrVar : String := "$m"

/-- Reserved binder name for the `arr`-field's inner lambda
    (the bound variable of the morphism passed to elim). -/
def modalArrInner : String := "$y"

/-- The modal functor, parameterised by `k : ModalityKind`.  A single
    endofunctor on `CType_as_Category ℓ` realising any of the cohesion
    triple's modalities by selecting the kind:

      · `forModalityKind ℓ .flat`  — the discrete reflection `♭`
      · `forModalityKind ℓ .sharp` — the codiscrete coreflection `♯`
      · `forModalityKind ℓ .shape` — the EML-localising shape `ʃ`

    Replaces the Phase-1 trio (`flatFunctor` / `sharpFunctor` /
    `shapeFunctor`), which were three syntactic copies of the same
    construction differing only in which `ModalityKind` constructor
    they instantiated.  The construction is uniform in `k`: the
    modality enters through the unified constructors `.modalIntro k`,
    `.modalElim k`.

    **Object map.**  Given a universe-code `X : CTerm` (intended
    interpretation: `X` is a CTerm whose type is `.univ (ℓ := ℓ)` —
    semantically, an encoded type), the modal image is
    `λ$x. modalIntro k (X $x)`.  This is the "code of the pointwise
    M-modalised image" — a function that, when applied at any input,
    wraps its result in the modality of kind `k`.  Substantive in
    both `X` and `k`: distinct Xs yield distinct lambda bodies;
    distinct ks yield distinct `.modalIntro` heads.

    **Morphism map.**  Given a morphism `f : A → B` (a path-in-the-
    universe, treated function-style as a CTerm), the modal image
    is the function `M A → M B`:
        `λ$m. modalElim k (λ$y. modalIntro k (f $y)) $m`
    This is the standard "elim-then-intro" functorial action: take
    the modal scrutinee `$m`, eliminate to get the underlying value,
    apply `f`, and re-introduce under the same modality kind.  The
    body substantively mentions `f`, the source `X`, and the target
    `Y` (through the elim discipline), as well as `k`.

    **Functoriality witnesses.**  Identity-preservation and
    composition-preservation are reflexivity-paths in the universe
    at the right-hand-side normal form of the functoriality
    equation.  The cubical evaluator reduces both endpoints to a
    common normal form via the modal β-rule
    (`eval_modalElim_beta`), and the path body is the corresponding
    constant.

    Per THEORY.md §3.1 / §3.3.  -/
def forModalityKind (ℓ : ULevel) (k : ModalityKind) :
    CFunctor (CType_as_Category ℓ) (CType_as_Category ℓ) where
  obj            := fun X =>
    -- λ$x. modalIntro k (X $x)  — pointwise k-modalisation of the
    -- code's fibre.  Substantive in X (which appears as the head
    -- of the inner application) and in k (which selects the
    -- `.modalIntro` constructor).
    .lam modalObjVar
      (.modalIntro k (.app X (.var modalObjVar)))
  arr            := fun _X _Y f =>
    -- λ$m. modalElim k (λ$y. modalIntro k (f $y)) $m
    -- Functorial action: scrutinise the modal-input, apply f to the
    -- underlying value, re-wrap.  Substantive in both f and k.
    .lam modalArrVar
      (.modalElim k
        (.lam modalArrInner
          (.modalIntro k (.app f (.var modalArrInner))))
        (.var modalArrVar))
  preserves_id   := fun _X =>
    -- Path body: the constant path at the LHS of the functoriality
    -- equation, which the cubical evaluator reduces to the RHS via
    -- the modal β-rule  `M.elim (M.intro a) = a`  (Phase 1 axiom
    -- `eval_modalElim_beta` instantiated at k).  Reflexivity at this
    -- normal form inhabits the documented Path.
    .plam CCategory.lawDim
      (.lam modalArrVar
        (.modalElim k
          (.lam modalArrInner
            (.modalIntro k (.var modalArrInner)))
          (.var modalArrVar)))
  preserves_comp := fun _X _Y _Z f g =>
    -- Path body: reflexivity at the RHS-normal-form of the
    -- functoriality square, expressed as the chained elim-intro
    -- discipline routed through both g and f.  All three of f, g,
    -- and the intermediate object Y substantively appear (via the
    -- modal-elim discipline that exposes the chained applications).
    .plam CCategory.lawDim
      (.lam modalArrVar
        (.modalElim k
          (.lam modalArrInner
            (.modalIntro k (.app g (.app f (.var modalArrInner)))))
          (.var modalArrVar)))

-- ── §1a.  Substantive-dependence rfl-lemmas + dependence theorems ─────────
-- The functor's `obj` and `arr` fields substantively mention their
-- inputs (so distinct inputs yield distinct outputs).  These rfl-
-- lemmas pin down the encodings, parameterised over `k`.

/-- The modal functor's `obj` field encodes its argument inside a
    lambda body — substantively `X`-dependent and `k`-dependent. -/
@[simp] theorem forModalityKind_obj (ℓ : ULevel) (k : ModalityKind)
    (X : CTerm) :
    (forModalityKind ℓ k).obj X =
      .lam modalObjVar (.modalIntro k (.app X (.var modalObjVar))) := rfl

/-- The modal functor's `arr` field encodes the morphism via the
    elim/intro discipline — substantively `f`-dependent and
    `k`-dependent. -/
@[simp] theorem forModalityKind_arr (ℓ : ULevel) (k : ModalityKind)
    (X Y f : CTerm) :
    (forModalityKind ℓ k).arr X Y f =
      .lam modalArrVar
        (.modalElim k
          (.lam modalArrInner
            (.modalIntro k (.app f (.var modalArrInner))))
          (.var modalArrVar)) := rfl

/-- The modal functor's `obj` is genuinely X-dependent: distinct X's
    yield distinct lambda bodies (at any fixed `k`). -/
theorem forModalityKind_obj_dep (ℓ : ULevel) (k : ModalityKind)
    (X X' : CTerm) (h : X ≠ X') :
    (forModalityKind ℓ k).obj X ≠ (forModalityKind ℓ k).obj X' := by
  intro hEq
  rw [forModalityKind_obj, forModalityKind_obj] at hEq
  -- .lam x (.modalIntro k (.app X _)) = .lam x (.modalIntro k (.app X' _))
  -- Peel through .lam, .modalIntro, .app to expose X vs X'.
  have hbody := (CTerm.lam.injEq .. |>.mp hEq).2
  have hmodal := (CTerm.modalIntro.injEq .. |>.mp hbody).2
  have happ  := (CTerm.app.injEq .. |>.mp hmodal).1
  exact h happ

/-- The modal functor's `arr` is genuinely f-dependent (at any fixed
    `k`). -/
theorem forModalityKind_arr_f_dep (ℓ : ULevel) (k : ModalityKind)
    (X Y f f' : CTerm) (h : f ≠ f') :
    (forModalityKind ℓ k).arr X Y f ≠ (forModalityKind ℓ k).arr X Y f' := by
  intro hEq
  rw [forModalityKind_arr, forModalityKind_arr] at hEq
  -- Peel: .lam $m (.modalElim k (.lam $y (.modalIntro k (.app f $y))) $m)
  -- through the outer lam, the modalElim, the inner lam, the modalIntro,
  -- the app — exposing f vs f' as the LHS of the inner .app.
  have hbody    := (CTerm.lam.injEq .. |>.mp hEq).2
  have hflatArg := (CTerm.modalElim.injEq .. |>.mp hbody).2.1
  have hLam     := (CTerm.lam.injEq .. |>.mp hflatArg).2
  have hIntro   := (CTerm.modalIntro.injEq .. |>.mp hLam).2
  have happ     := (CTerm.app.injEq .. |>.mp hIntro).1
  exact h happ

-- ── §2.  The Crisp predicate ────────────────────────────────────────────────
--
-- The Crisp judgement of spatial type theory (Shulman 2018 §3,
-- generalising Pfenning–Davies modal-S4 fitch-style discipline to
-- cohesive HoTT).  A CTerm is *crisp* when it is introduced via a
-- modal elimination — semantically, it is a value extracted from a
-- modalised type and is therefore safe to re-introduce under any
-- further modal-introduction.
--
-- Refactor Phase 3: the inductive constructors are parameterised
-- over `k : ModalityKind` rather than restricted to `.flat`.  Every
-- modal eliminator (any of `♭`, `♯`, `ʃ`) extracts a value from a
-- modalised subuniverse, and that value is crisp by construction.
-- The `flat`-restricted prior form was a Phase-1 specialisation that
-- the unified `ModalityKind` syntax now subsumes — the predicate's
-- introduction discipline is uniform across the cohesion triple.
--
-- This phase delivers the term-level Crisp predicate.  The companion
-- spec piece — the *context-level* refinement `CContext.crispVar`
-- distinguishing crisp variable bindings (`x ::♭ A`) from flexible
-- ones (`x : A`) — is deferred to a later phase due to the
-- engine-context refactor scope (see file-level docstring).
--
-- Inductive constructors:
--   · `modalElimBody k f m` — a `modalElim k f m` term is crisp at
--     any kind k.  The classic spatial-TT rule generalised across
--     modalities: every modal eliminator extracts a value from the
--     M-modalised subuniverse, and that value is crisp.  This is
--     the head case.
--   · `modalIntroOfCrisp k h` — `modalIntro k a` is crisp when `a`
--     is crisp.  Closure under further modal introduction at any
--     kind: a crisp value can be re-wrapped under the same or any
--     other modality without losing crispness.  This makes Crisp
--     closed under the modal idempotency cycle.
--   · `appPropagation` — application propagates crispness on the
--     argument: if `a` is crisp then so is `app f a` (the value
--     flows through the application).  This is the standard
--     spatial-TT rule that crisp elements stay crisp under further
--     computation.

/-- The Crisp judgement (THEORY.md §3.2 / Shulman 2018 §3): a
    CTerm-level predicate carving out the crisp values — those
    introduced via a modal elimination, possibly re-wrapped or
    applied.

    Refactor Phase 3: the constructors are parameterised over
    `k : ModalityKind` rather than restricted to `.flat`.  The
    spatial-TT discipline is uniform across the cohesion triple
    `♭`/`♯`/`ʃ`: every modal eliminator extracts a value from a
    modalised subuniverse and that value is crisp by construction.

    Constructors:

      · `modalElimBody k f m` — the head case at any kind: every
        `modalElim k f m` term is crisp.  This is the spatial-TT
        introduction rule for crispness, generalised across the
        modality triple — `M.elim` extracts a value from the
        M-modalised subuniverse (discrete for `♭`, codiscrete for
        `♯`, shape-localised for `ʃ`), and the result is crisp by
        construction.

      · `modalIntroOfCrisp k a` (with `Crisp a` premise) — closure
        under modal re-introduction at any kind: a crisp `a`
        re-wrapped as `modalIntro k a` remains crisp.  This
        realises the modal idempotency cycle `M ∘ M = M` at the
        predicate level, uniformly across the modality triple.

      · `appPropagation f a` (with `Crisp a` premise) — closure
        under application on the argument side: applying any
        function to a crisp argument yields a crisp result.  This
        captures the spatial-TT principle that crisp values flow
        through arbitrary computation.

    **Deferred:** the context-side refinement `CContext.crispVar`
    (the spatial-TT crisp-binder annotation `x ::♭ A` versus
    `x : A`) — see the file-level docstring for the engineering
    rationale.  Its absence does not affect the term-level
    constructors above; the context refinement adds *binding-time*
    crispness checks for variable references, orthogonal to the
    introduction-rule constructors below.

    Reference: Shulman 2018 (arXiv:1509.07584) §3 "Spatial type
    theory"; Licata–Shulman–Riley 2017 (arXiv:1706.07526) §6. -/
inductive Crisp : CTerm → Prop where
  /-- Head rule: every `modalElim k f m` term is crisp by
      introduction, at any modality kind. -/
  | modalElimBody (k : ModalityKind) (f m : CTerm) :
      Crisp (CTerm.modalElim k f m)
  /-- Closure under modal re-introduction: a crisp argument inside
      `modalIntro k a` stays crisp, at any modality kind. -/
  | modalIntroOfCrisp (k : ModalityKind) {a : CTerm} (h : Crisp a) :
      Crisp (CTerm.modalIntro k a)
  /-- Propagation through application: applying any function to a
      crisp argument yields a crisp result. -/
  | appPropagation {f a : CTerm} (h : Crisp a) :
      Crisp (CTerm.app f a)

/-- Convenience constructor: a bare `modalElim k f m` is crisp.  Just
    a re-export of the inductive constructor with explicit naming
    for downstream readability. -/
theorem Crisp.of_modalElim (k : ModalityKind) (f m : CTerm) :
    Crisp (CTerm.modalElim k f m) :=
  Crisp.modalElimBody k f m

/-- Substantive content: a *non-modalElim, non-modalIntro, non-app*
    head — for instance, a bare variable — is not in the head case.
    This pins down that `Crisp` is *not* trivially total: the
    inductive does not have a constructor for `var`, so a `var x`
    cannot be crisp via `modalElimBody`, `modalIntroOfCrisp`, or
    `appPropagation`'s direct shape — the `var` head distinguishes
    it from each of those CTerm shapes via constructor disjointness.

    This rules out the `Crisp _ := True` failure mode. -/
theorem Crisp.var_not_immediate (x : String) :
    ¬ ∃ (k : ModalityKind) (f m : CTerm),
        CTerm.var x = CTerm.modalElim k f m := by
  rintro ⟨k, f, m, h⟩
  cases h

-- ── §2a.  Unit and counit underlying CTerms ─────────────────────────────────
--
-- The two adjunctions of the cohesive triple `ʃ ⊣ ♭ ⊣ ♯` are
-- `♭ ⊣ ♯` and `ʃ ⊣ ♭`.  Each adjunction comes with a unit and a
-- counit natural transformation.  The component at each object/type
-- has an *underlying function* (the action on elements / on the
-- `apply`-image) plus a *naturality witness* (a path-equality
-- propagating the modal β/η-rules).
--
-- This section delivers the underlying functions as concrete CTerms
-- built directly from the unified modal constructors `.modalIntro k`
-- and `.modalElim k`.  No placeholder variables; each definition
-- mentions both the `.flat`/`.sharp`/`.shape` `ModalityKind` constants
-- and uses the proper modal introduction/elimination discipline.
--
-- The naturality witnesses (path-equalities) live in §3, and depend
-- on the modal Path-equality lift hypothesis FS-H18 (see
-- `topolei/docs/HYPOTHESES.md`).  This section's CTerms are
-- substantive — they are real Lean defs that downstream code can
-- already reference, rather than abstract `Nonempty`-existentials.
--
-- ── Reserved binder names ────────────────────────────────────────────────────
-- We use distinct binder names for the unit (input element) and the
-- counit's nested elims (each of which has its own bound variable).
-- These are reserved with a `$` prefix to avoid collision with
-- user-supplied CTerm variable names (matching the convention used
-- for `modalObjVar`, `modalArrVar`, `modalArrInner` above).

/-- Reserved binder name for the input of a unit's underlying lambda
    (the element of `A` being mapped under `η`). -/
def modalUnitVar : String := "$a"

/-- Reserved binder name for the input of a counit's outer lambda
    (the modal scrutinee being eliminated). -/
def modalCounitVar : String := "$x"

/-- Reserved binder name for the inner-elim's bound variable in a
    counit (the value extracted from the outer modal layer). -/
def modalCounitInner : String := "$y"

/-- Reserved binder name for the innermost-elim's bound variable in a
    counit (the underlying element of the doubly-modalised value). -/
def modalCounitCore : String := "$z"

/-- Underlying function of the **unit** of `♭ ⊣ ♯` at type `A`:
    a CTerm representing  `η_A : A → ♯ (♭ A)`.

    Body: `λ$a. modalIntro .sharp (modalIntro .flat $a)`.

    Reading: take the input element `$a : A`; introduce it under
    `♭` to get a value of `♭ A`; introduce *that* under `♯` to
    get a value of `♯ (♭ A)`.  This is the standard discrete-then-
    codiscrete inclusion that realises the unit of the flat-sharp
    adjunction at the type level.

    Substantive in `A` (via the type-checked discipline:
    `flatSharpUnit_typed` records that this CTerm has type
    `pi $a A (modal .sharp (modal .flat A))`); substantive in the
    `.flat` and `.sharp` `ModalityKind` constants (they appear
    syntactically as the modal-intro head constants).

    Note on the `(ℓ : ULevel) (A : CType ℓ)` signature: the body
    is *level-uniform* — the underlying CTerm does not actually
    mention `ℓ` or `A` syntactically, since CTerm is un-indexed by
    universe level (Syntax.lean §3 design rationale).  The
    `(ℓ, A)` arguments scope the typed-correctness theorem
    `flatSharpUnit_typed`, which *does* mention them. -/
def flatSharpUnit (ℓ : ULevel) (A : CType ℓ) : CTerm :=
  let _ := ℓ; let _ := A  -- arguments scope the typed theorem
  .lam modalUnitVar
    (.modalIntro .sharp (.modalIntro .flat (.var modalUnitVar)))

/-- Underlying function of the **counit** of `♭ ⊣ ♯` at type `A`:
    a CTerm representing  `ε_A : ♭ (♯ A) → A`.

    Body:
      `λ$x. modalElim .flat (λ$y. modalElim .sharp (λ$z. $z) $y) $x`.

    Reading: take the input scrutinee `$x : ♭ (♯ A)`.  Eliminate
    under `♭` with the eliminator function
    `λ$y. modalElim .sharp (λ$z. $z) $y`, which itself eliminates
    its input `$y : ♯ A` under `♯` with the identity eliminator
    `λ$z. $z`, returning the underlying value `$z : A`.  The chained
    `modalElim .flat` then `modalElim .sharp` discipline strips off
    both modal layers, yielding a value in `A`.

    Substantive in the `.flat` and `.sharp` `ModalityKind` constants;
    typed-correctness recorded by `flatSharpCounit_typed`. -/
def flatSharpCounit (ℓ : ULevel) (A : CType ℓ) : CTerm :=
  let _ := ℓ; let _ := A
  .lam modalCounitVar
    (.modalElim .flat
      (.lam modalCounitInner
        (.modalElim .sharp
          (.lam modalCounitCore (.var modalCounitCore))
          (.var modalCounitInner)))
      (.var modalCounitVar))

/-- Underlying function of the **unit** of `ʃ ⊣ ♭` at type `A`:
    a CTerm representing  `η_A : A → ♭ (ʃ A)`.

    Body: `λ$a. modalIntro .flat (modalIntro .shape $a)`.

    Reading: take the input element `$a : A`; introduce it under
    `ʃ` to get a value of `ʃ A`; introduce *that* under `♭` to
    get a value of `♭ (ʃ A)`.  This is the shape-then-discrete
    inclusion realising the unit of the shape-flat adjunction.

    Typed-correctness recorded by `shapeFlatUnit_typed`. -/
def shapeFlatUnit (ℓ : ULevel) (A : CType ℓ) : CTerm :=
  let _ := ℓ; let _ := A
  .lam modalUnitVar
    (.modalIntro .flat (.modalIntro .shape (.var modalUnitVar)))

/-- Underlying function of the **counit** of `ʃ ⊣ ♭` at type `A`:
    a CTerm representing  `ε_A : ʃ (♭ A) → A`.

    Body:
      `λ$x. modalElim .shape (λ$y. modalElim .flat (λ$z. $z) $y) $x`.

    Reading: input scrutinee `$x : ʃ (♭ A)`.  Eliminate under
    `ʃ` with the eliminator function
    `λ$y. modalElim .flat (λ$z. $z) $y`, which eliminates
    `$y : ♭ A` under `♭` with the identity eliminator,
    yielding the underlying `$z : A`.  Chained `modalElim .shape`
    then `modalElim .flat` strips both modal layers.

    Typed-correctness recorded by `shapeFlatCounit_typed`. -/
def shapeFlatCounit (ℓ : ULevel) (A : CType ℓ) : CTerm :=
  let _ := ℓ; let _ := A
  .lam modalCounitVar
    (.modalElim .shape
      (.lam modalCounitInner
        (.modalElim .flat
          (.lam modalCounitCore (.var modalCounitCore))
          (.var modalCounitInner)))
      (.var modalCounitVar))

-- ── §2a-rfl.  Rfl-lemmas pinning the body of each unit/counit ───────────────
-- These witness that the bodies are exactly what their docstrings
-- promise — distinct binder names, the proper modal-intro/elim
-- nesting.  Used in §2b for typed-correctness proofs and in
-- `forModalityKind_*_dep`-style dependence theorems.

/-- The flat-sharp unit's body unfolds to its documented lambda. -/
@[simp] theorem flatSharpUnit_eq (ℓ : ULevel) (A : CType ℓ) :
    flatSharpUnit ℓ A =
      .lam modalUnitVar
        (.modalIntro .sharp (.modalIntro .flat (.var modalUnitVar))) := rfl

/-- The flat-sharp counit's body unfolds to its documented lambda. -/
@[simp] theorem flatSharpCounit_eq (ℓ : ULevel) (A : CType ℓ) :
    flatSharpCounit ℓ A =
      .lam modalCounitVar
        (.modalElim .flat
          (.lam modalCounitInner
            (.modalElim .sharp
              (.lam modalCounitCore (.var modalCounitCore))
              (.var modalCounitInner)))
          (.var modalCounitVar)) := rfl

/-- The shape-flat unit's body unfolds to its documented lambda. -/
@[simp] theorem shapeFlatUnit_eq (ℓ : ULevel) (A : CType ℓ) :
    shapeFlatUnit ℓ A =
      .lam modalUnitVar
        (.modalIntro .flat (.modalIntro .shape (.var modalUnitVar))) := rfl

/-- The shape-flat counit's body unfolds to its documented lambda. -/
@[simp] theorem shapeFlatCounit_eq (ℓ : ULevel) (A : CType ℓ) :
    shapeFlatCounit ℓ A =
      .lam modalCounitVar
        (.modalElim .shape
          (.lam modalCounitInner
            (.modalElim .flat
              (.lam modalCounitCore (.var modalCounitCore))
              (.var modalCounitInner)))
          (.var modalCounitVar)) := rfl

-- ── §2b.  Constructive partial discharges (typed-correctness) ───────────────
--
-- The unit/counit CTerms above have intended Π-types that record the
-- "function at the type level" interpretation of each:
--
--   flatSharpUnit ℓ A     : A → ♯ (♭ A)
--   flatSharpCounit ℓ A   : ♭ (♯ A) → A
--   shapeFlatUnit ℓ A     : A → ♭ (ʃ A)
--   shapeFlatCounit ℓ A   : ʃ (♭ A) → A
--
-- These typings are dischargeable *now* — they require only the
-- existing `HasType.lam` / `HasType.var` / `HasType.modalIntro` /
-- `HasType.modalElim` / `HasType.app` rules (Typing.lean) and do
-- not depend on any Path-equality lift.  They are the
-- "constructive partial discharge" that the user values: real
-- progress on the adjunction content that requires nothing beyond
-- already-landed engine machinery.
--
-- By contrast, the *naturality* squares and *triangle identities*
-- (which sit inside the `CAdjoint` and `CNatTrans` structures of
-- §3) are Path-equality content — they need FS-H18 to discharge.
-- The split between this §2b and §3 is therefore the precise
-- "what we can prove now / what waits on FS-H18" boundary.

/-- Reserved Π-binder name for the unit's intended Π-type signature.
    Mirrors the binder name used in the unit's CTerm body (so that
    substitution would be well-defined under the dependent-Π
    interpretation, were the codomain to depend on the binder). -/
def unitTypeBinder : String := modalUnitVar

/-- Reserved Π-binder name for the counit's intended Π-type
    signature.  Same convention as `unitTypeBinder`. -/
def counitTypeBinder : String := modalCounitVar

/-- **Typed correctness of `flatSharpUnit`.**  The CTerm `flatSharpUnit
    ℓ A` has the Π-type `A → ♯ (♭ A)` in the empty context.

    Discharge: by `HasType.lam` followed by `HasType.modalIntro`
    twice (once for `.sharp`, once for `.flat`) and `HasType.var`
    at the inner-most reference.  This is a real Lean proof — no
    sorry, no axiom, no Path-equality lift.

    Substantive constructive content.  The Π-type makes the
    "underlying function" claim of the unit precise: `flatSharpUnit
    ℓ A` is genuinely a function CTerm of the right type at A. -/
theorem flatSharpUnit_typed (ℓ : ULevel) (A : CType ℓ) :
    HasType []
      (flatSharpUnit ℓ A)
      (.pi unitTypeBinder A (.modal .sharp (.modal .flat A))) := by
  rw [flatSharpUnit_eq]
  -- Goal: HasType [] (.lam $a (.modalIntro .sharp (.modalIntro .flat (.var $a))))
  --                  (.pi $a A (.modal .sharp (.modal .flat A)))
  apply HasType.lam
  -- Goal: HasType [($a, ⟨ℓ, A⟩)] (.modalIntro .sharp (.modalIntro .flat (.var $a)))
  --                                (.modal .sharp (.modal .flat A))
  apply HasType.modalIntro
  -- Goal: HasType [($a, ⟨ℓ, A⟩)] (.modalIntro .flat (.var $a)) (.modal .flat A)
  apply HasType.modalIntro
  -- Goal: HasType [($a, ⟨ℓ, A⟩)] (.var $a) A
  exact HasType.var (List.mem_cons_self ..)

/-- **Typed correctness of `flatSharpCounit`.**  The CTerm
    `flatSharpCounit ℓ A` has the Π-type `♭ (♯ A) → A` in the empty
    context.

    Discharge: outer `HasType.lam`, then `HasType.modalElim` (with
    eliminator-function-typed-as-`(♯ A) → A` and scrutinee-typed-as-
    `♭ (♯ A)`), recursing into the inner elim with the same
    discipline at `.sharp`.  The innermost identity lambda
    `λ$z. $z` discharges via `HasType.lam` + `HasType.var`. -/
theorem flatSharpCounit_typed (ℓ : ULevel) (A : CType ℓ) :
    HasType []
      (flatSharpCounit ℓ A)
      (.pi counitTypeBinder (.modal .flat (.modal .sharp A)) A) := by
  rw [flatSharpCounit_eq]
  apply HasType.lam
  -- Context now: [($x, ⟨ℓ, .modal .flat (.modal .sharp A)⟩)]
  -- Goal: the inner elim has type A.
  -- HasType.modalElim asks for:
  --   f : pi var (.modal .sharp A) A          (the eliminator function)
  --   m : .modal .flat (.modal .sharp A)      (the scrutinee)
  refine HasType.modalElim
    (var := modalCounitCore)
    (A := .modal .sharp A)
    (C := A)
    (k := .flat)
    ?_  -- f : pi $z (.modal .sharp A) A
    ?_  -- m : .modal .flat (.modal .sharp A)
  · -- Inner eliminator: λ$y. modalElim .sharp (λ$z. $z) $y
    -- needs HasType (..ctx..) (.lam $y (...)) (.pi $z (.modal .sharp A) A).
    apply HasType.lam
    -- ctx : [($y, ⟨ℓ, .modal .sharp A⟩), ($x, ⟨ℓ, .modal .flat (.modal .sharp A)⟩)]
    -- Goal: HasType ctx (.modalElim .sharp (.lam $z (.var $z)) (.var $y)) A
    refine HasType.modalElim
      (var := modalCounitCore)
      (A := A)
      (C := A)
      (k := .sharp)
      ?_  -- f' : pi $z A A   (the identity)
      ?_  -- m' : .modal .sharp A   (the inner scrutinee)
    · -- Identity lambda: λ$z. $z
      apply HasType.lam
      -- ctx2 : [($z, ⟨ℓ, A⟩), ($y, ⟨ℓ, .modal .sharp A⟩),
      --         ($x, ⟨ℓ, .modal .flat (.modal .sharp A)⟩)]
      -- Goal: HasType ctx2 (.var $z) A
      exact HasType.var (List.mem_cons_self ..)
    · -- Inner scrutinee: var $y at type .modal .sharp A
      -- ctx : [($y, ⟨ℓ, .modal .sharp A⟩),
      --        ($x, ⟨ℓ, .modal .flat (.modal .sharp A)⟩)]
      exact HasType.var (List.mem_cons_self ..)
  · -- Outer scrutinee: var $x at type .modal .flat (.modal .sharp A)
    exact HasType.var (List.mem_cons_self ..)

/-- **Typed correctness of `shapeFlatUnit`.**  The CTerm
    `shapeFlatUnit ℓ A` has the Π-type `A → ♭ (ʃ A)` in the empty
    context. -/
theorem shapeFlatUnit_typed (ℓ : ULevel) (A : CType ℓ) :
    HasType []
      (shapeFlatUnit ℓ A)
      (.pi unitTypeBinder A (.modal .flat (.modal .shape A))) := by
  rw [shapeFlatUnit_eq]
  apply HasType.lam
  apply HasType.modalIntro
  apply HasType.modalIntro
  exact HasType.var (List.mem_cons_self ..)

/-- **Typed correctness of `shapeFlatCounit`.**  The CTerm
    `shapeFlatCounit ℓ A` has the Π-type `ʃ (♭ A) → A` in the empty
    context. -/
theorem shapeFlatCounit_typed (ℓ : ULevel) (A : CType ℓ) :
    HasType []
      (shapeFlatCounit ℓ A)
      (.pi counitTypeBinder (.modal .shape (.modal .flat A)) A) := by
  rw [shapeFlatCounit_eq]
  apply HasType.lam
  refine HasType.modalElim
    (var := modalCounitCore)
    (A := .modal .flat A)
    (C := A)
    (k := .shape)
    ?_
    ?_
  · apply HasType.lam
    refine HasType.modalElim
      (var := modalCounitCore)
      (A := A)
      (C := A)
      (k := .flat)
      ?_
      ?_
    · apply HasType.lam
      exact HasType.var (List.mem_cons_self ..)
    · exact HasType.var (List.mem_cons_self ..)
  · exact HasType.var (List.mem_cons_self ..)

-- ── §2b-dep.  Substantive non-vacuity / non-degeneracy theorems ─────────────
-- The unit/counit CTerms above are *not* trivial wrappers — distinct
-- binder names (unit-binder vs counit-binder) ensure each is
-- syntactically distinguishable at the head, and the modality kinds
-- appear inside the term so that swapping any one of them produces
-- a syntactically distinct CTerm.

/-- The flat-sharp unit and flat-sharp counit are syntactically
    distinct — the unit's head is a `modalIntro`, the counit's head
    body has a `modalElim` immediately under the outer lambda.  This
    rules out the degenerate failure mode where unit and counit
    collapse to the same CTerm. -/
theorem flatSharpUnit_ne_Counit (ℓ : ULevel) (A : CType ℓ) :
    flatSharpUnit ℓ A ≠ flatSharpCounit ℓ A := by
  rw [flatSharpUnit_eq, flatSharpCounit_eq]
  -- LHS: .lam $a (.modalIntro .sharp ...)
  -- RHS: .lam $x (.modalElim .flat ...)
  -- Lambda binder names differ ($a vs $x), and bodies have different
  -- head constructors.  Lambda injectivity exposes either disagreement.
  intro hEq
  have hbinder := (CTerm.lam.injEq .. |>.mp hEq).1
  -- $a = $x  contradicts our binder convention
  exact (by decide : modalUnitVar ≠ modalCounitVar) hbinder

/-- The shape-flat unit and shape-flat counit are syntactically
    distinct.  Same shape as `flatSharpUnit_ne_Counit`. -/
theorem shapeFlatUnit_ne_Counit (ℓ : ULevel) (A : CType ℓ) :
    shapeFlatUnit ℓ A ≠ shapeFlatCounit ℓ A := by
  rw [shapeFlatUnit_eq, shapeFlatCounit_eq]
  intro hEq
  have hbinder := (CTerm.lam.injEq .. |>.mp hEq).1
  exact (by decide : modalUnitVar ≠ modalCounitVar) hbinder

/-- The flat-sharp unit and the shape-flat unit are syntactically
    distinct — the inner `modalIntro`s carry different `ModalityKind`
    constants (`.flat` / `.sharp` for the FS-unit, `.shape` /
    `.flat` for the SF-unit).  Distinct kinds ⇒ distinct CTerms.
    This rules out the failure mode where the two adjunction
    units accidentally coincide. -/
theorem flatSharpUnit_ne_shapeFlatUnit (ℓ : ULevel) (A : CType ℓ) :
    flatSharpUnit ℓ A ≠ shapeFlatUnit ℓ A := by
  rw [flatSharpUnit_eq, shapeFlatUnit_eq]
  -- LHS: .lam $a (.modalIntro .sharp (.modalIntro .flat (.var $a)))
  -- RHS: .lam $a (.modalIntro .flat  (.modalIntro .shape (.var $a)))
  -- The outermost modalIntro's kind differs: .sharp vs .flat.
  intro hEq
  have hbody := (CTerm.lam.injEq .. |>.mp hEq).2
  have hkind := (CTerm.modalIntro.injEq .. |>.mp hbody).1
  -- hkind : ModalityKind.sharp = ModalityKind.flat
  exact (by decide : (ModalityKind.sharp : ModalityKind) ≠ .flat) hkind

/-- The flat-sharp counit and the shape-flat counit are syntactically
    distinct — the outermost `modalElim` carries different kinds. -/
theorem flatSharpCounit_ne_shapeFlatCounit (ℓ : ULevel) (A : CType ℓ) :
    flatSharpCounit ℓ A ≠ shapeFlatCounit ℓ A := by
  rw [flatSharpCounit_eq, shapeFlatCounit_eq]
  intro hEq
  have hbody := (CTerm.lam.injEq .. |>.mp hEq).2
  have hkind := (CTerm.modalElim.injEq .. |>.mp hbody).1
  exact (by decide : (ModalityKind.flat : ModalityKind) ≠ .shape) hkind

-- ── §3.  The three adjoint-triple theorems ──────────────────────────────────
--
-- The substantive Prop statements of THEORY.md §3.3, restated using
-- the unified `forModalityKind`.  Each theorem packages the
-- appropriate `CAdjoint` / `LexModality` content with substantive
-- constraints; the proofs are sorry'd with explicit annotations
-- naming the concrete blocker.

/-- **Theorem `flat_sharp_adjoint`** (THEORY.md §3.3): the flat
    modality is left adjoint to the sharp modality, viewed as
    endofunctors on the universe-as-category at level `ℓ`.

    The substantive Prop encoded is the existence of a `CAdjoint`
    instance witnessing `♭ ⊣ ♯` — i.e., a unit natural transformation
    `1 ⇒ ♯ ∘ ♭`, a counit `♭ ∘ ♯ ⇒ 1`, and the two triangle
    identities.  The CAdjoint structure (Category.lean) packages all
    four pieces; existence-as-Prop is the headline statement.

    Phase 3 form: both functors are obtained from the unified
    `forModalityKind ℓ` by selecting `.flat` and `.sharp`.

    **Concrete progress (no FS-H18).**  The unit/counit's *underlying
    function* CTerms are landed in §2a — `flatSharpUnit` and
    `flatSharpCounit` — with substantive bodies built from the
    unified modal constructors and typed-correctness theorems
    `flatSharpUnit_typed` / `flatSharpCounit_typed` (§2b) showing
    they have the proper Π-type.  The remaining gap is the
    natural-transformation packaging, which requires path-equality.

    **Specific blocker: FS-H18 (modal Path-equality lift).**
    The naturality squares and triangle identities require the modal
    β-rule (`eval_modalElim_beta` from `Eval.lean`, itself FS-H15)
    lifted from the eval-equation level to a Path-equality at the
    universe level.  Once FS-H18 lands (see
    `topolei/docs/HYPOTHESES.md`), the `CAdjoint` instance
    constructs as:
       unit.comp X       := plam ∘ flatSharpUnit-action-at-X
       counit.comp X     := plam ∘ flatSharpCounit-action-at-X
       triangle1 / 2     := plam (β_path .flat) ∘ plam (β_path .sharp)
    where `β_path k` is the FS-H18 Path-form of the eval-level β. -/
theorem flat_sharp_adjoint (ℓ : ULevel) :
    Nonempty (CAdjoint (forModalityKind ℓ .flat) (forModalityKind ℓ .sharp)) := by
  -- waits on: FS-H18 (modal Path-equality lift, see
  -- topolei/docs/HYPOTHESES.md).  Once FS-H18 lands, the CAdjoint
  -- instance is constructed from the §2a underlying CTerms
  -- `flatSharpUnit` / `flatSharpCounit` (whose typed-correctness is
  -- already discharged by `flatSharpUnit_typed` /
  -- `flatSharpCounit_typed` in §2b) plus the triangle identities,
  -- which are precisely the FS-H18 Path-form of the modal β-rule
  -- at `.flat` and `.sharp`.  No additional axioms are needed.
  sorry

/-- **Theorem `shape_flat_adjoint`** (THEORY.md §3.3): the shape
    modality is left adjoint to the flat modality.

    Same packaging as `flat_sharp_adjoint`: existence of a
    `CAdjoint` instance for `ʃ ⊣ ♭` viewed as endofunctors on
    `CType_as_Category ℓ`, both obtained from the unified
    `forModalityKind ℓ` at `.shape` and `.flat`.

    **Concrete progress (no FS-H18).**  The unit/counit's
    underlying function CTerms are landed in §2a as `shapeFlatUnit`
    and `shapeFlatCounit`, both with substantive bodies and
    typed-correctness theorems (§2b: `shapeFlatUnit_typed` /
    `shapeFlatCounit_typed`).

    **Specific blocker: FS-H18 (modal Path-equality lift)** —
    same hypothesis as `flat_sharp_adjoint`, this time instantiated
    at the `.shape` and `.flat` modality kinds.  Once FS-H18 lands,
    the `CAdjoint` instance constructs from the §2a CTerms
    analogously to `flat_sharp_adjoint`'s discharge route. -/
theorem shape_flat_adjoint (ℓ : ULevel) :
    Nonempty (CAdjoint (forModalityKind ℓ .shape) (forModalityKind ℓ .flat)) := by
  -- waits on: FS-H18 (modal Path-equality lift, see
  -- topolei/docs/HYPOTHESES.md), instantiated at `.shape` and
  -- `.flat`.  The §2a underlying-function CTerms `shapeFlatUnit` /
  -- `shapeFlatCounit` (typed-correctness in §2b) provide the
  -- naturality components; the triangle identities are FS-H18 at
  -- the `.shape` / `.flat` kinds.  No additional axioms.
  sorry

/-- **Theorem `cohesive_triple`** (THEORY.md §3.3): the cohesive
    structure `ʃ ⊣ ♭ ⊣ ♯` exists as a triple where:

      · `ʃ` (shape) is a *lex* modality (preserves finite limits)
      · `♯` (sharp) is a *lex* modality
      · `♭` (flat) is a modality (idempotent reflective subuniverse)
        but *not* lex
      · the triple coheres — the two adjunctions `ʃ ⊣ ♭` and
        `♭ ⊣ ♯` compose into the cohesive structure.

    The substantive Prop encoded packages all three pieces:
      1. a lex-modality witness for shape;
      2. a lex-modality witness for sharp;
      3. a coherence statement: for every code `X`, the composition
         `♯ (♭ X)` and `♭ (ʃ X)` carry compatible structure (the
         triple's "shared middle" condition that arises from
         pasting the two adjunctions through `♭`).

    Phase 3 form: the lex-modality apply-fields and the coherence
    witnesses are stated using the unified `.modal k` constructor
    and `forModalityKind` directly.

    Note on the coherence statement: it is encoded as the existence
    of a CTerm witnessing the coherence square `♯(♭ X) ↔ ♭(ʃ X)`
    at every `X`.  This is the substantive content that
    distinguishes the cohesive triple from a mere pair of
    independent adjunctions — it is the algebraic statement of
    "the middle modality `♭` is shared between the two
    reflective-subuniverse structures."

    **Concrete progress (no FS-H18).**  The coherence-witness
    *function-shape* CTerms `flatSharpUnit/Counit` and
    `shapeFlatUnit/Counit` (§2a) already provide the building
    blocks of the coherence square: pasting the unit of `♭ ⊣ ♯`
    with the counit of `ʃ ⊣ ♭` (composed appropriately) yields
    the algebraic translation between `♯(♭ X)` and `♭(ʃ X)` at
    the function level.

    **Specific blocker: FS-H18** for the lex-modality witnesses
    of `ʃ` and `♯` (preserves_pullbacks / preserves_terminal as
    Path-equalities), and for the coherence square's Path-form. -/
theorem cohesive_triple (ℓ : ULevel) :
    -- (1) shape is lex
    (∃ shapeLex : LexModality ℓ,
        shapeLex.toModality.apply = fun A => CType.modal .shape A) ∧
    -- (2) sharp is lex
    (∃ sharpLex : LexModality ℓ,
        sharpLex.toModality.apply = fun A => CType.modal .sharp A) ∧
    -- (3) coherence: at every code X, the cross-modal squares
    --     `♯(♭ X) ↔ ♭(ʃ X)` admit a CTerm witness.  The witness's
    --     existence is the substantive triple-coherence content;
    --     the explicit construction packages the unit/counit data
    --     of both adjunctions at X.  Substantive in X — distinct
    --     X's yield distinct coherence-witness CTerms (each
    --     mentions X via the chained obj-field lambdas of
    --     `forModalityKind` at `.flat` / `.sharp` / `.shape`).
    (∀ X : CTerm,
       ∃ coh : CTerm,
         coh = (forModalityKind ℓ .sharp).obj
                 ((forModalityKind ℓ .flat).obj X) ∨
         coh = (forModalityKind ℓ .flat).obj
                 ((forModalityKind ℓ .shape).obj X)) := by
  -- waits on: FS-H18 (modal Path-equality lift, see
  -- topolei/docs/HYPOTHESES.md), at all three of `.flat` / `.sharp` /
  -- `.shape`.  Discharge route: combine the §2a underlying-function
  -- CTerms (flatSharpUnit/Counit, shapeFlatUnit/Counit) with the
  -- FS-H18 Path-form to get the lex-modality witnesses
  -- (`preserves_pullbacks` and `preserves_terminal` as Path-
  -- equalities on the universe-as-category) plus the coherence
  -- square `♯(♭ X) ↔ ♭(ʃ X)` as the pasted unit/counit data of
  -- the two §3 adjunctions.  The lex extension itself additionally
  -- depends on the pullback machinery in `Category.lean`
  -- (`CCategory_internal` `sorry`-cluster), which is orthogonal
  -- to FS-H18.
  sorry

-- ── §4.  Soundness theorem for the modal β-rule ─────────────────────────────
--
-- Phase 1 added the unified eval β-axiom (`eval_modalElim_beta` in
-- `Eval.lean`) that asserts the reduction equation at the value
-- level, parameterised by `k : ModalityKind`.  This phase records
-- the corresponding Eq fact at the theorem level so downstream
-- tactics (rewriting, simp) can fire on it.
--
-- Refactor Phase 3: the prior trio of `flat_beta_sound` /
-- `sharp_beta_sound` / `shape_beta_sound` collapses into a single
-- `modal_beta_sound` parameterised over `k`.  Each was a
-- definitional copy of the same axiom instantiated at distinct
-- `ModalityKind` cases; the unified statement is one theorem.
--
-- The body is an immediate application of the Phase 1 axiom — no
-- further content is needed.  The axiom is a propositional equality,
-- not definitional, because `eval` is `partial` (the modal arms of
-- `eval` are `match` on the evaluated scrutinee, which the Lean
-- kernel cannot reduce definitionally for `partial` defs).  Hence
-- `rfl` does not close the goal, but the axiom does.

/-- **Soundness for the modal β-rule** (THEORY.md §3.2 reduction
    rules), unified across the modality triple.

    The reduction
      `modalElim k f (modalIntro k a) → vApp (eval f) (eval a)`
    holds at the eval-equation level, at any `k : ModalityKind`.
    Recorded here as a theorem so downstream tactics may rewrite
    with it.  The underlying axiom is the unified
    `eval_modalElim_beta` from `Eval.lean`.

    Refactor Phase 3: replaces the prior trio (`flat_beta_sound` /
    `sharp_beta_sound` / `shape_beta_sound`) with a single
    `ModalityKind`-parameterised statement. -/
theorem modal_beta_sound (env : CEnv) (k : ModalityKind) (f a : CTerm) :
    eval env (.modalElim k f (.modalIntro k a)) =
      vApp (eval env f) (eval env a) :=
  eval_modalElim_beta env k f a

end CubicalTransport.Modal