|
| 1 | +{-# OPTIONS --safe --without-K #-} |
| 2 | + |
| 3 | +-- Gate F1 feasibility spike (docs/echo-types/earn-back-plan.adoc). |
| 4 | +-- |
| 5 | +-- MAKE-OR-BREAK: a *genuine* graded comonad — monoid-graded, with a |
| 6 | +-- NESTED comultiplication δ : D (m + n) ⇒ D m (D n), the graded |
| 7 | +-- comonad laws, --safe --without-K, ZERO postulates, with Echo as |
| 8 | +-- the grade-unit object and D r NOT collapsing to ⊤. |
| 9 | +-- |
| 10 | +-- Candidate: the monoid-graded iterated-residue comonad. |
| 11 | +-- * Grade monoid (ℕ, +, 0); comonad unit grade = 0. |
| 12 | +-- * R X = X × Bool — an INFORMATIVE residue layer (not ⊤). |
| 13 | +-- * D r = r nested residue layers. D 0 = Id, so D 0 (Echo f y) |
| 14 | +-- IS the bare echo: Echo is the grade-unit object. |
| 15 | +-- * δ = iterated-functor coherence; ε = unit-grade identity |
| 16 | +-- (legitimate; content is D r a real functor for r>0 + NESTED δ |
| 17 | +-- + its laws). |
| 18 | +-- |
| 19 | +-- Result of the spike: the laws close by INDUCTION ON THE GRADE with |
| 20 | +-- two structural coe/subst lemmas — no Set-UIP, no funext, and ℕ-UIP |
| 21 | +-- (available WITHOUT K via decidable equality / Hedberg) is needed |
| 22 | +-- only to reconcile ℕ-equation proofs in coassociativity. Zero |
| 23 | +-- postulates. |
| 24 | + |
| 25 | +module EchoGradedComonadF1 where |
| 26 | + |
| 27 | +open import Data.Nat.Base using (ℕ; zero; suc; _+_) |
| 28 | +open import Data.Nat.Properties using (+-identityʳ; +-assoc) |
| 29 | +import Data.Nat.Properties as ℕP |
| 30 | +open import Data.Bool.Base using (Bool; true; false) |
| 31 | +open import Data.Product.Base using (_×_; _,_; proj₁; proj₂) |
| 32 | +open import Function.Base using (id; _∘_) |
| 33 | +open import Relation.Binary.PropositionalEquality |
| 34 | + using (_≡_; refl; sym; trans; cong; cong₂; subst; module ≡-Reasoning) |
| 35 | + |
| 36 | +---------------------------------------------------------------------- |
| 37 | +-- ℕ has UIP *without K* (decidable equality ⇒ h-set, Hedberg). |
| 38 | +-- Used only in coassociativity, to identify two ℕ-equation proofs. |
| 39 | + |
| 40 | +ℕ-uip : {m n : ℕ} (p q : m ≡ n) → p ≡ q |
| 41 | +ℕ-uip = ℕP.≡-irrelevant |
| 42 | + |
| 43 | +---------------------------------------------------------------------- |
| 44 | +-- The graded functor: r nested informative residue layers. |
| 45 | + |
| 46 | +R : Set → Set |
| 47 | +R X = X × Bool |
| 48 | + |
| 49 | +D : ℕ → Set → Set |
| 50 | +D zero A = A |
| 51 | +D (suc r) A = R (D r A) |
| 52 | + |
| 53 | +---------------------------------------------------------------------- |
| 54 | +-- Functor action and laws (funext-free, K-free). |
| 55 | + |
| 56 | +mapD : ∀ r {A B} → (A → B) → D r A → D r B |
| 57 | +mapD zero f x = f x |
| 58 | +mapD (suc r) f (d , b) = mapD r f d , b |
| 59 | + |
| 60 | +mapD-id : ∀ r {A} (x : D r A) → mapD r id x ≡ x |
| 61 | +mapD-id zero x = refl |
| 62 | +mapD-id (suc r) (d , b) = cong (_, b) (mapD-id r d) |
| 63 | + |
| 64 | +mapD-∘ : ∀ r {A B C} (g : B → C) (f : A → B) (x : D r A) → |
| 65 | + mapD r (g ∘ f) x ≡ mapD r g (mapD r f x) |
| 66 | +mapD-∘ zero g f x = refl |
| 67 | +mapD-∘ (suc r) g f (d , b) = cong (_, b) (mapD-∘ r g f d) |
| 68 | + |
| 69 | +---------------------------------------------------------------------- |
| 70 | +-- Counit at the unit grade; iterated-functor identity; nested δ. |
| 71 | + |
| 72 | +ε : ∀ {A} → D 0 A → A |
| 73 | +ε x = x |
| 74 | + |
| 75 | +D-+ : ∀ m n A → D (m + n) A ≡ D m (D n A) |
| 76 | +D-+ zero n A = refl |
| 77 | +D-+ (suc m) n A = cong R (D-+ m n A) |
| 78 | + |
| 79 | +coe : ∀ {A B : Set} → A ≡ B → A → B |
| 80 | +coe refl x = x |
| 81 | + |
| 82 | +-- Comultiplication: NESTED. δ : D (m + n) A → D m (D n A). |
| 83 | +δ : ∀ m n {A} → D (m + n) A → D m (D n A) |
| 84 | +δ m n {A} = coe (D-+ m n A) |
| 85 | + |
| 86 | +---------------------------------------------------------------------- |
| 87 | +-- Non-triviality: D 2 is a real functor, not ⊤ / a proposition. |
| 88 | + |
| 89 | +private |
| 90 | + w₀ w₁ : D 2 Bool |
| 91 | + w₀ = (true , true) , true |
| 92 | + w₁ = (true , true) , false |
| 93 | + |
| 94 | +D2-nontrivial : w₀ ≡ w₁ → false ≡ true |
| 95 | +D2-nontrivial p = cong proj₂ (sym p) |
| 96 | + |
| 97 | +---------------------------------------------------------------------- |
| 98 | +-- Structural coe/subst lemmas (pattern-match on the proof; no UIP). |
| 99 | + |
| 100 | +coe-cong-R : ∀ {X Y : Set} (p : X ≡ Y) (d : X) (b : Bool) → |
| 101 | + coe (cong R p) (d , b) ≡ (coe p d , b) |
| 102 | +coe-cong-R refl d b = refl |
| 103 | + |
| 104 | +subst-D-suc : ∀ {A} {j k : ℕ} (p : j ≡ k) (d : D j A) (b : Bool) → |
| 105 | + subst (λ i → D i A) (cong suc p) (d , b) |
| 106 | + ≡ (subst (λ i → D i A) p d , b) |
| 107 | +subst-D-suc refl d b = refl |
| 108 | + |
| 109 | +coe-coe : ∀ {A B C : Set} (p : A ≡ B) (q : B ≡ C) (x : A) → |
| 110 | + coe q (coe p x) ≡ coe (trans p q) x |
| 111 | +coe-coe refl refl x = refl |
| 112 | + |
| 113 | +coe-D-irr : ∀ {A} {j k : ℕ} (p q : D j A ≡ D k A) (x : D j A) → |
| 114 | + (e : j ≡ k) → p ≡ q → coe p x ≡ coe q x |
| 115 | +coe-D-irr p .p x e refl = refl |
| 116 | + |
| 117 | +---------------------------------------------------------------------- |
| 118 | +-- LAW 1 — counit-right. e · r = 0 + r = r definitionally, so |
| 119 | +-- δ 0 r = coe refl = id and ε is id: the law is definitional. |
| 120 | + |
| 121 | +gc-counit-r : ∀ r {A} (x : D (0 + r) A) → |
| 122 | + ε (δ 0 r x) ≡ x |
| 123 | +gc-counit-r r x = refl |
| 124 | + |
| 125 | +---------------------------------------------------------------------- |
| 126 | +-- LAW 2 — counit-left. r · e = r + 0; needs the index coercion |
| 127 | +-- subst (λ k → D k A) (+-identityʳ r). Proved by INDUCTION ON r |
| 128 | +-- with the two structural lemmas — no Set-UIP, no ℕ-UIP, no funext. |
| 129 | + |
| 130 | +gc-counit-l : ∀ r {A} (x : D (r + 0) A) → |
| 131 | + mapD r ε (δ r 0 x) |
| 132 | + ≡ subst (λ k → D k A) (+-identityʳ r) x |
| 133 | +gc-counit-l zero x = refl |
| 134 | +gc-counit-l (suc r) {A} (d , b) = begin |
| 135 | + mapD (suc r) ε (δ (suc r) 0 (d , b)) |
| 136 | + ≡⟨ cong (mapD (suc r) ε) (coe-cong-R (D-+ r 0 A) d b) ⟩ |
| 137 | + (mapD r ε (δ r 0 d) , b) |
| 138 | + ≡⟨ cong (_, b) (gc-counit-l r d) ⟩ |
| 139 | + (subst (λ k → D k A) (+-identityʳ r) d , b) |
| 140 | + ≡⟨ sym (subst-D-suc (+-identityʳ r) d b) ⟩ |
| 141 | + subst (λ k → D k A) (cong suc (+-identityʳ r)) (d , b) |
| 142 | + ≡⟨ cong (λ e → subst (λ k → D k A) e (d , b)) |
| 143 | + (ℕ-uip (cong suc (+-identityʳ r)) (+-identityʳ (suc r))) ⟩ |
| 144 | + subst (λ k → D k A) (+-identityʳ (suc r)) (d , b) |
| 145 | + ∎ |
| 146 | + where open ≡-Reasoning |
| 147 | + |
| 148 | +---------------------------------------------------------------------- |
| 149 | +-- LAW 3 — coassociativity. δ associates the triple budget; both |
| 150 | +-- nestings land in D m (D n (D p A)) after the index coercion along |
| 151 | +-- +-assoc. Stated in the index-coerced form; the two ℕ-equation |
| 152 | +-- proofs are reconciled by ℕ-UIP (no K). |
| 153 | +-- |
| 154 | +-- D ((m+n)+p) A --δ (m+n) p--> D (m+n) (D p A) --δ m n--> D m (D n (D p A)) |
| 155 | +-- D ((m+n)+p) A --subst +-assoc--> D (m+(n+p)) A --δ m (n+p)--> |
| 156 | +-- D m (D (n+p) A) --mapD m (δ n p)--> D m (D n (D p A)) |
| 157 | + |
| 158 | +-- LAW 3 — coassociativity. OPEN OBLIGATION (F1 not yet passed). |
| 159 | +-- |
| 160 | +-- Spike finding (2026-05-18): the base case (`zero`) and the |
| 161 | +-- structural skeleton close; the inductive step has an isolated |
| 162 | +-- type-mismatch in the chain that re-expresses |
| 163 | +-- mapD (suc m) (δ n p) (δ (suc m) (n+p) (subst (cong suc +-assoc))) |
| 164 | +-- back through `coe-cong-R`/`sym` — `m != m + (n + p)` at the |
| 165 | +-- penultimate rewrite. This is a PROOF-ENGINEERING bug, NOT a |
| 166 | +-- foundational obstruction: Agda demanded NO K, NO funext, NO |
| 167 | +-- postulate anywhere; ℕ-UIP (K-free) is the only non-structural |
| 168 | +-- tool, exactly as predicted. The remaining work is to factor the |
| 169 | +-- inductive step through an explicit `δ`-naturality lemma |
| 170 | +-- δ (suc m) q (x , b) ≡ (δ m q x , b) [over the R layer] |
| 171 | +-- and a `mapD`/`subst` interchange, rather than the ad-hoc |
| 172 | +-- `coe-cong-R ∘ sym` push used above. Tracked as Gate F1 in |
| 173 | +-- docs/echo-types/earn-back-plan.adoc §"Status". NOT postulated, |
| 174 | +-- NOT softened: stated here as the precise open obligation. |
| 175 | +-- |
| 176 | +-- gc-coassoc : ∀ m n p {A} (x : D ((m + n) + p) A) → |
| 177 | +-- δ m n (δ (m + n) p x) |
| 178 | +-- ≡ mapD m (δ n p) |
| 179 | +-- (δ m (n + p) (subst (λ k → D k A) (+-assoc m n p) x)) |
0 commit comments