|
| 1 | +{-# OPTIONS --safe #-} |
| 2 | +-- SPDX-License-Identifier: MPL-2.0 |
| 3 | +-- Copyright (c) 2026 Jonathan D.A. Jewell (hyperpolymath) <j.d.a.jewell@open.ac.uk> |
| 4 | +-- |
| 5 | +-- =========================================================================== |
| 6 | +-- KRL port-arity proof — machine-checked under `agda --safe` (no unproven axioms) |
| 7 | +-- =========================================================================== |
| 8 | +-- |
| 9 | +-- Discharges two obligations from PROOF-NEEDS.md / PROOF-NARRATIVE.md: |
| 10 | +-- |
| 11 | +-- KR-1 `lower` is total on parseable programs |
| 12 | +-- (a parseable program never gets "stuck" in lowering; the only |
| 13 | +-- failure is a genuine arity mismatch reported cleanly as `nothing`). |
| 14 | +-- |
| 15 | +-- KR-2 `lower` preserves port arity |
| 16 | +-- (every sub-expression `(compose a b)` is lowered only when |
| 17 | +-- out-ports(a) = in-ports(b), and the lowered TangleIR object has |
| 18 | +-- exactly the surface arity). |
| 19 | +-- |
| 20 | +-- Modelled fragment — the CONSTRUCT + TRANSFORM + RESOLVE(close) fragment of |
| 21 | +-- KRL v0.1.0 (spec/grammar.ebnf): generators sigma / sigma_inv / cup / cap, |
| 22 | +-- sequential composition `;`, tensor `|`, the arity-preserving transforms |
| 23 | +-- mirror / simplify / normalise, and `close` (trace / closure). |
| 24 | +-- |
| 25 | +-- Arity model — a *precise* refinement of ASSUMPTIONS A-KR-2.1 / A-KR-2.2. |
| 26 | +-- The narrative prose for `sigma` ("in=i, out=i+1 (and same arity in/out)") |
| 27 | +-- is internally contradictory and cannot be encoded as written; we take the |
| 28 | +-- standard PROP / oriented-Temperley-Lieb model, which honours the |
| 29 | +-- *consistent* part of the assumption (cup/cap exact; sigma arity-preserving): |
| 30 | +-- |
| 31 | +-- sigma i, sigma_inv i : 2 → 2 (a crossing; in = out, per A-KR-2.1) |
| 32 | +-- cup i : 0 → 2 (exactly A-KR-2.1) |
| 33 | +-- cap i : 2 → 0 (exactly A-KR-2.1) |
| 34 | +-- a ; b (compose) : m → n requires out(a) = in(b) |
| 35 | +-- a | b (tensor) : (mₐ+m_b) → (nₐ+n_b) (exactly A-KR-2.2) |
| 36 | +-- mirror/simplify/normalise : arity-preserving |
| 37 | +-- close : n → n ↦ 0 → 0 (trace; requires square) |
| 38 | +-- |
| 39 | +-- Validated against the canonical example from spec/grammar-overview.md, |
| 40 | +-- close (sigma 1 ; sigma 1 ; sigma 1) -- the trefoil |
| 41 | +-- which is well-formed with closed arity 0 → 0 (see `trefoil-lowers` below). |
| 42 | +-- The strand index `i` is retained as data; KRL v0.1.0 has no strand-count |
| 43 | +-- parameterisation (grammar-overview "Known gaps" #3), so locally it does not |
| 44 | +-- constrain arity. A future strand-indexed refinement is left open. |
| 45 | +-- |
| 46 | +-- The RETRIEVE family (`find … where …` queries) and `classify` produce |
| 47 | +-- non-tangle results and are out of scope for the port-arity theorem. |
| 48 | + |
| 49 | +module PortArity where |
| 50 | + |
| 51 | +open import Data.Nat using (ℕ; zero; suc; _+_) |
| 52 | +open import Data.Nat.Properties using (_≟_; ≟-diag) |
| 53 | +open import Data.Maybe using (Maybe; just; nothing) |
| 54 | +open import Data.Product using (Σ; Σ-syntax; _×_; _,_; proj₁; proj₂) |
| 55 | +open import Data.Empty using (⊥-elim) |
| 56 | +open import Relation.Nullary using (yes; no) |
| 57 | +open import Relation.Binary.PropositionalEquality |
| 58 | + using (_≡_; _≢_; refl; cong) |
| 59 | + |
| 60 | +-- ─────────────────────────────────────────────────────────────────────────── |
| 61 | +-- Surface syntax: a *parseable* KRL tangle expression (untyped). |
| 62 | +-- ─────────────────────────────────────────────────────────────────────────── |
| 63 | + |
| 64 | +data Expr : Set where |
| 65 | + sigma sigmaInv cup cap : ℕ → Expr |
| 66 | + _⨾_ _⊗_ : Expr → Expr → Expr -- compose ; , tensor | |
| 67 | + mirror simplify normalise close : Expr → Expr |
| 68 | + |
| 69 | +infixl 5 _⨾_ |
| 70 | +infixl 6 _⊗_ |
| 71 | + |
| 72 | +-- ─────────────────────────────────────────────────────────────────────────── |
| 73 | +-- TangleIR: intrinsically port-typed. `Tangle m n` is a tangle with m input |
| 74 | +-- ports and n output ports. The `Kseq` constructor makes an arity-mismatched |
| 75 | +-- composition *unrepresentable* — this is KR-2 baked into the type of the IR. |
| 76 | +-- ─────────────────────────────────────────────────────────────────────────── |
| 77 | + |
| 78 | +data Tangle : ℕ → ℕ → Set where |
| 79 | + Kσ : ℕ → Tangle 2 2 |
| 80 | + Kσ⁻ : ℕ → Tangle 2 2 |
| 81 | + K∪ : ℕ → Tangle 0 2 |
| 82 | + K∩ : ℕ → Tangle 2 0 |
| 83 | + Kseq : ∀ {m k n} → Tangle m k → Tangle k n → Tangle m n |
| 84 | + Kpar : ∀ {m n p q} → Tangle m n → Tangle p q → Tangle (m + p) (n + q) |
| 85 | + Kmir : ∀ {m n} → Tangle m n → Tangle m n |
| 86 | + Ksim : ∀ {m n} → Tangle m n → Tangle m n |
| 87 | + Knrm : ∀ {m n} → Tangle m n → Tangle m n |
| 88 | + Kcls : ∀ {n} → Tangle n n → Tangle 0 0 |
| 89 | + |
| 90 | +-- A lowered object packaged with its (input,output) arity. |
| 91 | +TypedTangle : Set |
| 92 | +TypedTangle = Σ[ mn ∈ ℕ × ℕ ] Tangle (proj₁ mn) (proj₂ mn) |
| 93 | + |
| 94 | +arity : ∀ {m n} → Tangle m n → ℕ × ℕ |
| 95 | +arity {m} {n} _ = m , n |
| 96 | + |
| 97 | +-- ─────────────────────────────────────────────────────────────────────────── |
| 98 | +-- The lowering, in combinator style so the per-constructor equations hold |
| 99 | +-- definitionally (which keeps the proofs below clean). |
| 100 | +-- ─────────────────────────────────────────────────────────────────────────── |
| 101 | + |
| 102 | +-- sequential composition: succeeds iff the middle arities agree |
| 103 | +seqC : TypedTangle → TypedTangle → Maybe TypedTangle |
| 104 | +seqC ((ma , ka) , ta) ((kb , nb) , tb) with ka ≟ kb |
| 105 | +... | yes refl = just ((ma , nb) , Kseq ta tb) |
| 106 | +... | no _ = nothing |
| 107 | + |
| 108 | +-- tensor: always succeeds, arities add |
| 109 | +parC : TypedTangle → TypedTangle → Maybe TypedTangle |
| 110 | +parC ((ma , na) , ta) ((mb , nb) , tb) = |
| 111 | + just ((ma + mb , na + nb) , Kpar ta tb) |
| 112 | + |
| 113 | +-- arity-preserving unary transform |
| 114 | +mapC : (∀ {m n} → Tangle m n → Tangle m n) → TypedTangle → TypedTangle |
| 115 | +mapC f (mn , t) = mn , f t |
| 116 | + |
| 117 | +-- closure / trace: succeeds iff the diagram is square (in = out) |
| 118 | +clsC : TypedTangle → Maybe TypedTangle |
| 119 | +clsC ((m , n) , t) with m ≟ n |
| 120 | +... | yes refl = just ((0 , 0) , Kcls t) |
| 121 | +... | no _ = nothing |
| 122 | + |
| 123 | +-- binary / unary Maybe plumbing (propagates `nothing`) |
| 124 | +bind₂ : Maybe TypedTangle → Maybe TypedTangle → |
| 125 | + (TypedTangle → TypedTangle → Maybe TypedTangle) → Maybe TypedTangle |
| 126 | +bind₂ (just x) (just y) f = f x y |
| 127 | +bind₂ _ _ _ = nothing |
| 128 | + |
| 129 | +mapMaybe : (TypedTangle → TypedTangle) → Maybe TypedTangle → Maybe TypedTangle |
| 130 | +mapMaybe f (just x) = just (f x) |
| 131 | +mapMaybe _ nothing = nothing |
| 132 | + |
| 133 | +bind₁ : Maybe TypedTangle → (TypedTangle → Maybe TypedTangle) → Maybe TypedTangle |
| 134 | +bind₁ (just x) f = f x |
| 135 | +bind₁ nothing _ = nothing |
| 136 | + |
| 137 | +-- The lowering function. Total: structural recursion accepted by Agda's |
| 138 | +-- own totality checker under `--safe` (no escape hatches): this *is* the |
| 139 | +-- witness for KR-1. |
| 140 | +compile : Expr → Maybe TypedTangle |
| 141 | +compile (sigma i) = just ((2 , 2) , Kσ i) |
| 142 | +compile (sigmaInv i) = just ((2 , 2) , Kσ⁻ i) |
| 143 | +compile (cup i) = just ((0 , 2) , K∪ i) |
| 144 | +compile (cap i) = just ((2 , 0) , K∩ i) |
| 145 | +compile (a ⨾ b) = bind₂ (compile a) (compile b) seqC |
| 146 | +compile (a ⊗ b) = bind₂ (compile a) (compile b) parC |
| 147 | +compile (mirror e) = mapMaybe (mapC Kmir) (compile e) |
| 148 | +compile (simplify e) = mapMaybe (mapC Ksim) (compile e) |
| 149 | +compile (normalise e) = mapMaybe (mapC Knrm) (compile e) |
| 150 | +compile (close e) = bind₁ (compile e) clsC |
| 151 | + |
| 152 | +-- alias under the obligation's name |
| 153 | +lower : Expr → Maybe TypedTangle |
| 154 | +lower = compile |
| 155 | + |
| 156 | +-- =========================================================================== |
| 157 | +-- KR-2 — port-arity preservation |
| 158 | +-- =========================================================================== |
| 159 | + |
| 160 | +-- (definitional) the lowered IR has exactly the arity `compile` reports. |
| 161 | +lower-preserves-arity : |
| 162 | + ∀ e {mn} {t : Tangle (proj₁ mn) (proj₂ mn)} → |
| 163 | + compile e ≡ just (mn , t) → arity t ≡ mn |
| 164 | +lower-preserves-arity _ _ = refl |
| 165 | + |
| 166 | +-- helper: `seqC` only fires when the middle arities are equal … |
| 167 | +seqC-nomatch : |
| 168 | + ∀ {ma ka kb nb} (ta : Tangle ma ka) (tb : Tangle kb nb) → |
| 169 | + ka ≢ kb → seqC ((ma , ka) , ta) ((kb , nb) , tb) ≡ nothing |
| 170 | +seqC-nomatch {_} {ka} {kb} ta tb ne with ka ≟ kb |
| 171 | +... | yes p = ⊥-elim (ne p) |
| 172 | +... | no _ = refl |
| 173 | + |
| 174 | +-- (general) a composition is lowered only when out-ports(a) = in-ports(b); |
| 175 | +-- a genuine mismatch is rejected cleanly as `nothing`. |
| 176 | +compose-mismatch-rejected : |
| 177 | + ∀ {a b ma ka kb nb} {ta : Tangle ma ka} {tb : Tangle kb nb} → |
| 178 | + compile a ≡ just ((ma , ka) , ta) → |
| 179 | + compile b ≡ just ((kb , nb) , tb) → |
| 180 | + ka ≢ kb → |
| 181 | + compile (a ⨾ b) ≡ nothing |
| 182 | +compose-mismatch-rejected pa pb ne |
| 183 | + rewrite pa | pb = seqC-nomatch _ _ ne |
| 184 | + |
| 185 | +-- helper: `seqC` fires when the middle arities agree. |
| 186 | +seqC-match : |
| 187 | + ∀ {ma k n} (ta : Tangle ma k) (tb : Tangle k n) → |
| 188 | + seqC ((ma , k) , ta) ((k , n) , tb) ≡ just ((ma , n) , Kseq ta tb) |
| 189 | +seqC-match {_} {k} ta tb rewrite ≟-diag {k} {k} refl = refl |
| 190 | + |
| 191 | +-- =========================================================================== |
| 192 | +-- KR-1 — lowering is total on parseable programs (no "stuck" states) |
| 193 | +-- =========================================================================== |
| 194 | + |
| 195 | +-- (general, positive) matching arities ⇒ the composition lowers, and the |
| 196 | +-- lowered IR is exactly the sequential composition of the parts. |
| 197 | +compose-succeeds-on-match : |
| 198 | + ∀ {a b ma k n} (ta : Tangle ma k) (tb : Tangle k n) → |
| 199 | + compile a ≡ just ((ma , k) , ta) → |
| 200 | + compile b ≡ just ((k , n) , tb) → |
| 201 | + compile (a ⨾ b) ≡ just ((ma , n) , Kseq ta tb) |
| 202 | +compose-succeeds-on-match ta tb pa pb |
| 203 | + rewrite pa | pb = seqC-match ta tb |
| 204 | + |
| 205 | +-- =========================================================================== |
| 206 | +-- Concrete computational evidence (each is `refl` — `compile` actually runs) |
| 207 | +-- =========================================================================== |
| 208 | + |
| 209 | +-- the canonical trefoil close (sigma 1 ; sigma 1 ; sigma 1) lowers, |
| 210 | +-- with closed arity 0 → 0. |
| 211 | +trefoil : Expr |
| 212 | +trefoil = close ((sigma 1 ⨾ sigma 1) ⨾ sigma 1) |
| 213 | + |
| 214 | +trefoil-lowers : |
| 215 | + compile trefoil |
| 216 | + ≡ just ((0 , 0) , Kcls (Kseq (Kseq (Kσ 1) (Kσ 1)) (Kσ 1))) |
| 217 | +trefoil-lowers = refl |
| 218 | + |
| 219 | +-- tensor of two cups: (0→2) | (0→2) = 0 → 4 |
| 220 | +two-cups : compile (cup 1 ⊗ cup 2) ≡ just ((0 , 4) , Kpar (K∪ 1) (K∪ 2)) |
| 221 | +two-cups = refl |
| 222 | + |
| 223 | +-- a genuine arity mismatch — sigma (2→2) then cup (0→2), 2 ≠ 0 — is rejected |
| 224 | +-- as `nothing` (a clean error), never "stuck". |
| 225 | +mismatch-rejected : compile (sigma 1 ⨾ cup 1) ≡ nothing |
| 226 | +mismatch-rejected = refl |
| 227 | + |
| 228 | +-- a non-square diagram cannot be closed: cup (0→2) has 0 ≠ 2, so `close` fails. |
| 229 | +close-needs-square : compile (close (cup 1)) ≡ nothing |
| 230 | +close-needs-square = refl |
0 commit comments