diff --git a/.gitignore b/.gitignore
index 8ae4409e..1ac69914 100644
--- a/.gitignore
+++ b/.gitignore
@@ -9,6 +9,14 @@
 *.out
 *.fdb_latexmk
 *.fls
+*.loc
+*.soc
 *.pdf
 *.zip
 *.DS_Store
+*.fdb_latexmk
+*.fls
+
+# Claude Code local state (memory, transcripts, and git worktrees it manages)
+/.claude/
+agda/_build/
diff --git a/Makefile b/Makefile
index 63eb1228..3a3f57e2 100644
--- a/Makefile
+++ b/Makefile
@@ -1,9 +1,10 @@
-.PHONY: main notes clean submit arXiv # otherwise confused by folders with the same name
+.PHONY: main notes mu-types clean submit arXiv # otherwise confused by folders with the same name
 
 default: main
 
 main: main.pdf
 notes: notes.pdf
+mu-types: mu-types.pdf
 
 # -out2dir unsupported on default Mac installation
 LATEXMK_OPTS:=-output-format=pdf -outdir=_latex
@@ -18,6 +19,15 @@ main.pdf: main.tex $(MAIN_DEPS)
 	cp _latex/main.pdf .
 	@! grep -qE "LaTeX Warning: There were undefined references\.|natbib Warning: There were undefined citations\." _latex/main.log
 
+MU_TYPES_DEPS:=$(wildcard mu-types/*.tex) $(wildcard fig/*.tex) macros.tex bib.bib
+
+mu-types.pdf: mu-types.tex $(MU_TYPES_DEPS)
+	latexmk $(LATEXMK_OPTS) mu-types
+	cd _latex && bibtex mu-types
+	latexmk $(LATEXMK_OPTS) -g mu-types
+	cp _latex/mu-types.pdf .
+	@! grep -qE "LaTeX Warning: There were undefined references\.|natbib Warning: There were undefined citations\." _latex/mu-types.log
+
 NOTES_DEPS:=$(wildcard notes/*.tex) $(wildcard fig/*.tex) macros.tex bib.bib
 
 notes.pdf: notes.tex $(NOTES_DEPS)
@@ -66,3 +76,4 @@ clean:
 	rm -f suppl-submit.zip
 	rm -f arXiv.zip
 	rm -f notes.pdf
+	rm -f mu-types.pdf
diff --git a/agda/src/approx-numbers.agda b/agda/src/approx-numbers.agda
index dde3ddda..bdf5458d 100644
--- a/agda/src/approx-numbers.agda
+++ b/agda/src/approx-numbers.agda
@@ -17,7 +17,7 @@ open import categories using (HasTerminal; Category)
 
 import fam
 
-open import Data.Rational using (ℚ; _≤_; _⊔_; _⊓_; _+_; _-_; 0ℚ; -_; Positive; _*_; _÷_; NonZero)
+open import Data.Rational using (ℚ; _≤_; _⊔_; _⊓_; _+_; _-_; 0ℚ; 1ℚ; -_; Positive; _*_; _÷_; NonZero)
 open import Data.Rational.Properties
   using (
     ≤-refl; ≤-trans; ⊓-glb; ⊔-lub; p⊓q≤p; p⊓q≤q; +-mono-≤; module ≤-Reasoning; +-comm; ≤-reflexive; +-assoc;
@@ -335,6 +335,20 @@ module Galois where
   zero-mor .famf .transf _ ._⇒g_.left⊣right {tt} {< x >} .proj₂ _ = x .l≤q , x .q≤u
   zero-mor .famf .natural e .right-eq .eqfun _ = (liftS ≤-refl , liftS ≤-refl) , liftS ≤-refl , liftS ≤-refl
 
+  one-mor : Fam.Mor 𝟙 ℚ-intv
+  one-mor .idxf .prop-setoid._⇒_.func _ = 1ℚ
+  one-mor .idxf .prop-setoid._⇒_.func-resp-≈ _ = liftS ≡-refl
+  one-mor .famf .transf _ ._⇒g_.right ._=>_.fun _ =
+    < record { lower = 1ℚ ; upper = 1ℚ ; l≤q = liftS ≤-refl ; q≤u = liftS ≤-refl } >
+  one-mor .famf .transf _ ._⇒g_.right ._=>_.mono _ = liftS ≤-refl , liftS ≤-refl
+  one-mor .famf .transf _ ._⇒g_.left ._=>_.fun _ = tt
+  one-mor .famf .transf _ ._⇒g_.left ._=>_.mono _ = tt
+  one-mor .famf .transf _ ._⇒g_.left⊣right {tt} {y} .proj₁ _ = tt
+  one-mor .famf .transf _ ._⇒g_.left⊣right {tt} {bottom} .proj₂ _ = tt
+  one-mor .famf .transf _ ._⇒g_.left⊣right {tt} {< x >} .proj₂ _ = x .l≤q , x .q≤u
+  one-mor .famf .natural e .right-eq .eqfun _ = (liftS ≤-refl , liftS ≤-refl) , liftS ≤-refl , liftS ≤-refl
+  one-mor .famf .natural e .left-eq .eqfun _ = tt , tt
+
 ------------------------------------------------------------------------------
 -- Conjugate (forward) interpretation
 module Conjugate where
@@ -628,6 +642,24 @@ module Conjugate where
   zero-mor .famf .natural e ._≃c_.left-eq ._≃J_.eqfunc ._≃m_.eqfun bottom = tt , tt
   zero-mor .famf .natural e ._≃c_.left-eq ._≃J_.eqfunc ._≃m_.eqfun < x > = tt , tt
 
+  one-mor : Fam.Mor 𝟙 ℚ-intv
+  one-mor .idxf .prop-setoid._⇒_.func _ = 1ℚ
+  one-mor .idxf .prop-setoid._⇒_.func-resp-≈ _ = liftS ≡-refl
+  one-mor .famf .transf _ ._⇒c_.right ._=>J_.func ._=>_.fun tt = bottom
+  one-mor .famf .transf _ ._⇒c_.right ._=>J_.func ._=>_.mono {tt} {tt} _ = tt
+  one-mor .famf .transf _ ._⇒c_.right ._=>J_.∨-preserving = tt
+  one-mor .famf .transf _ ._⇒c_.right ._=>J_.⊥-preserving = tt
+  one-mor .famf .transf _ ._⇒c_.left ._=>J_.func ._=>_.fun _ = tt
+  one-mor .famf .transf _ ._⇒c_.left ._=>J_.func ._=>_.mono _ = tt
+  one-mor .famf .transf _ ._⇒c_.left ._=>J_.∨-preserving = tt
+  one-mor .famf .transf _ ._⇒c_.left ._=>J_.⊥-preserving = tt
+  one-mor .famf .transf _ ._⇒c_.conjugate .proj₁ _ = tt
+  one-mor .famf .transf _ ._⇒c_.conjugate {x = tt} {y = bottom} .proj₂ _ = tt
+  one-mor .famf .transf _ ._⇒c_.conjugate {x = tt} {y = < _ >} .proj₂ _ = tt
+  one-mor .famf .natural e ._≃c_.right-eq ._≃J_.eqfunc ._≃m_.eqfun tt = tt , tt
+  one-mor .famf .natural e ._≃c_.left-eq ._≃J_.eqfunc ._≃m_.eqfun bottom = tt , tt
+  one-mor .famf .natural e ._≃c_.left-eq ._≃J_.eqfunc ._≃m_.eqfun < x > = tt , tt
+
   add-mor : Fam.Mor (ℚ-intv ⊗ ℚ-intv) ℚ-intv
   add-mor .idxf .prop-setoid._⇒_.func (q₁ , q₂) = q₁ + q₂
   add-mor .idxf .prop-setoid._⇒_.func-resp-≈ (liftS ≡-refl , liftS ≡-refl) = liftS ≡-refl
diff --git a/agda/src/cartesian-monoidal.agda b/agda/src/cartesian-monoidal.agda
index 499b0010..a6a12b7d 100644
--- a/agda/src/cartesian-monoidal.agda
+++ b/agda/src/cartesian-monoidal.agda
@@ -33,7 +33,7 @@ _×m_ = prod-m
 ×m-comp : ∀ {x₁ x₂ y₁ y₂ z₁ z₂}
           (f₁ : y₁ ⇒ z₁) (f₂ : y₂ ⇒ z₂) (g₁ : x₁ ⇒ y₁) (g₂ : x₂ ⇒ y₂) →
           ((f₁ ∘ g₁) ×m (f₂ ∘ g₂)) ≈ ((f₁ ×m f₂) ∘ (g₁ ×m g₂))
-×m-comp = pair-functorial
+×m-comp = prod-m-comp
 
 -- Associativity
 ×-assoc : ∀ {x y z} → ((x × y) × z) ⇒ (x × (y × z))
diff --git a/agda/src/categories.agda b/agda/src/categories.agda
index 230ce39d..7c93871c 100644
--- a/agda/src/categories.agda
+++ b/agda/src/categories.agda
@@ -2,7 +2,8 @@
 
 module categories where
 
-open import Level using (suc; _⊔_; Lift; lift)
+open import Level using (Level; suc; _⊔_; 0ℓ; Lift; lift)
+open import Data.Nat using (ℕ) renaming (zero to nzero; suc to nsuc)
 open import Data.Product using (_,_)
 open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)
 open import prop using (LiftP; Prf; ⊤; ⟪_⟫; tt; lift)
@@ -56,6 +57,14 @@ record Category o m e : Set (suc (o ⊔ m ⊔ e)) where
   ≡-to-≈ : ∀ {x y} {f g : x ⇒ y} → f ≡ g → f ≈ g
   ≡-to-≈ ≡.refl = ≈-refl
 
+  -- An object equality as a (cast) morphism: the transport of the identity.
+  ≡-to-⇒ : ∀ {x y} → x ≡ y → x ⇒ y
+  ≡-to-⇒ ≡.refl = id _
+
+  -- A cast and its inverse compose to the identity.
+  ≡-to-⇒-sym-l : ∀ {x y} (e : x ≡ y) → (≡-to-⇒ (≡.sym e) ∘ ≡-to-⇒ e) ≈ id x
+  ≡-to-⇒-sym-l ≡.refl = id-left
+
   id-swap : ∀ {x y}{f : x ⇒ y} → (id y ∘ f) ≈ (f ∘ id x)
   id-swap = isEquiv .trans id-left (≈-sym id-right)
 
@@ -86,6 +95,14 @@ record Category o m e : Set (suc (o ⊔ m ⊔ e)) where
       f∘inverse≈id : (f ∘ inverse) ≈ id y
       inverse∘f≈id : (inverse ∘ f) ≈ id x
 
+  -- Being an isomorphism respects equality of morphisms.
+  IsIso-cong : ∀ {x y} {f g : x ⇒ y} → f ≈ g → IsIso f → IsIso g
+  IsIso-cong e i .IsIso.inverse = i .IsIso.inverse
+  IsIso-cong e i .IsIso.f∘inverse≈id =
+    isEquiv .trans (∘-cong (isEquiv .sym e) (isEquiv .refl)) (i .IsIso.f∘inverse≈id)
+  IsIso-cong e i .IsIso.inverse∘f≈id =
+    isEquiv .trans (∘-cong (isEquiv .refl) (isEquiv .sym e)) (i .IsIso.inverse∘f≈id)
+
   record Iso (x y : obj) : Set (m ⊔ e) where
     field
       fwd : x ⇒ y
@@ -324,6 +341,35 @@ record HasCoproducts {o m e} (𝒞 : Category o m e) : Set (o ⊔ m ⊔ e) where
       id _
     ∎ where open ≈-Reasoning isEquiv
 
+-- Two coproduct structures on the same category give isomorphic coproducts.
+coproducts-canonical-iso : ∀ {o m e} {𝒞 : Category o m e}
+  (CP₁ CP₂ : HasCoproducts 𝒞) →
+  ∀ x y → Category.Iso 𝒞 (HasCoproducts.coprod CP₁ x y) (HasCoproducts.coprod CP₂ x y)
+coproducts-canonical-iso {𝒞 = 𝒞} CP₁ CP₂ x y = iso
+  where
+    open Category 𝒞
+    open Iso
+    module P = HasCoproducts CP₁
+    module Q = HasCoproducts CP₂
+
+    iso : Iso (P.coprod x y) (Q.coprod x y)
+    iso .fwd = P.copair Q.in₁ Q.in₂
+    iso .bwd = Q.copair P.in₁ P.in₂
+    iso .fwd∘bwd≈id =
+      isEquiv .trans (isEquiv .sym (Q.copair-ext _))
+        (isEquiv .trans
+          (Q.copair-cong
+            (isEquiv .trans (assoc _ _ _) (isEquiv .trans (∘-cong ≈-refl (Q.copair-in₁ _ _)) (isEquiv .trans (P.copair-in₁ _ _) (isEquiv .sym id-left))))
+            (isEquiv .trans (assoc _ _ _) (isEquiv .trans (∘-cong ≈-refl (Q.copair-in₂ _ _)) (isEquiv .trans (P.copair-in₂ _ _) (isEquiv .sym id-left)))))
+          (Q.copair-ext _))
+    iso .bwd∘fwd≈id =
+      isEquiv .trans (isEquiv .sym (P.copair-ext _))
+        (isEquiv .trans
+          (P.copair-cong
+            (isEquiv .trans (assoc _ _ _) (isEquiv .trans (∘-cong ≈-refl (P.copair-in₁ _ _)) (isEquiv .trans (Q.copair-in₁ _ _) (isEquiv .sym id-left))))
+            (isEquiv .trans (assoc _ _ _) (isEquiv .trans (∘-cong ≈-refl (P.copair-in₂ _ _)) (isEquiv .trans (Q.copair-in₂ _ _) (isEquiv .sym id-left)))))
+          (P.copair-ext _))
+
 
 module _ {o m e} (𝒞 : Category o m e) where
 
@@ -416,6 +462,12 @@ record HasProducts {o m e} (𝒞 : Category o m e) : Set (o ⊔ m ⊔ e) where
     pair-p₂ : ∀ {x y z} (f : x ⇒ y) (g : x ⇒ z) → (p₂ ∘ pair f g) ≈ g
     pair-ext : ∀ {x y z} (f : x ⇒ prod y z) → pair (p₁ ∘ f) (p₂ ∘ f) ≈ f
 
+  pair-cong₁ : ∀ {x y z} {f₁ f₂ : x ⇒ y} {g : x ⇒ z} → f₁ ≈ f₂ → pair f₁ g ≈ pair f₂ g
+  pair-cong₁ f≈ = pair-cong f≈ ≈-refl
+
+  pair-cong₂ : ∀ {x y z} {f : x ⇒ y} {g₁ g₂ : x ⇒ z} → g₁ ≈ g₂ → pair f g₁ ≈ pair f g₂
+  pair-cong₂ g≈ = pair-cong ≈-refl g≈
+
   pair-natural : ∀ {w x y z} (h : w ⇒ x) (f : x ⇒ y) (g : x ⇒ z) → (pair f g ∘ h) ≈ pair (f ∘ h) (g ∘ h)
   pair-natural h f g =
     begin
@@ -432,6 +484,38 @@ record HasProducts {o m e} (𝒞 : Category o m e) : Set (o ⊔ m ⊔ e) where
   prod-m : ∀ {x₁ x₂ y₁ y₂} → x₁ ⇒ y₁ → x₂ ⇒ y₂ → prod x₁ x₂ ⇒ prod y₁ y₂
   prod-m f₁ f₂ = pair (f₁ ∘ p₁) (f₂ ∘ p₂)
 
+  swap : ∀ {x y} → prod x y ⇒ prod y x
+  swap = pair p₂ p₁
+
+  swap-involutive : ∀ {x y} → (swap {y} {x} ∘ swap {x} {y}) ≈ id _
+  swap-involutive = begin
+      pair p₂ p₁ ∘ pair p₂ p₁
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₂ ∘ pair p₂ p₁) (p₁ ∘ pair p₂ p₁)
+    ≈⟨ pair-cong (pair-p₂ _ _) (pair-p₁ _ _) ⟩
+      pair p₁ p₂
+    ≈˘⟨ pair-cong id-right id-right ⟩
+      pair (p₁ ∘ id _) (p₂ ∘ id _)
+    ≈⟨ pair-ext (id _) ⟩
+      id _
+    ∎ where open ≈-Reasoning isEquiv
+
+  swap-natural : ∀ {x₁ x₂ y₁ y₂} (f : x₁ ⇒ y₁) (g : x₂ ⇒ y₂) →
+                 (swap ∘ prod-m f g) ≈ (prod-m g f ∘ swap)
+  swap-natural f g = begin
+      swap ∘ prod-m f g
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₂ ∘ prod-m f g) (p₁ ∘ prod-m f g)
+    ≈⟨ pair-cong (pair-p₂ _ _) (pair-p₁ _ _) ⟩
+      pair (g ∘ p₂) (f ∘ p₁)
+    ≈˘⟨ pair-cong (∘-cong ≈-refl (pair-p₁ _ _)) (∘-cong ≈-refl (pair-p₂ _ _)) ⟩
+      pair (g ∘ (p₁ ∘ swap)) (f ∘ (p₂ ∘ swap))
+    ≈˘⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+      pair ((g ∘ p₁) ∘ swap) ((f ∘ p₂) ∘ swap)
+    ≈˘⟨ pair-natural _ _ _ ⟩
+      prod-m g f ∘ swap
+    ∎ where open ≈-Reasoning isEquiv
+
   pair-compose : ∀ {x y₁ y₂ z₁ z₂} (f₁ : y₁ ⇒ z₁) (f₂ : y₂ ⇒ z₂) (g₁ : x ⇒ y₁) (g₂ : x ⇒ y₂) →
     (prod-m f₁ f₂ ∘ pair g₁ g₂) ≈ pair (f₁ ∘ g₁) (f₂ ∘ g₂)
   pair-compose f₁ f₂ g₁ g₂ =
@@ -445,21 +529,16 @@ record HasProducts {o m e} (𝒞 : Category o m e) : Set (o ⊔ m ⊔ e) where
       pair (f₁ ∘ g₁) (f₂ ∘ g₂)
     ∎ where open ≈-Reasoning isEquiv
 
-  pair-functorial : ∀ {x₁ x₂ y₁ y₂ z₁ z₂} (f₁ : y₁ ⇒ z₁) (f₂ : y₂ ⇒ z₂) (g₁ : x₁ ⇒ y₁) (g₂ : x₂ ⇒ y₂) →
+  prod-m-comp : ∀ {x₁ x₂ y₁ y₂ z₁ z₂} (f₁ : y₁ ⇒ z₁) (f₂ : y₂ ⇒ z₂) (g₁ : x₁ ⇒ y₁) (g₂ : x₂ ⇒ y₂) →
     prod-m (f₁ ∘ g₁) (f₂ ∘ g₂) ≈ (prod-m f₁ f₂ ∘ prod-m g₁ g₂)
-  pair-functorial f₁ f₂ g₁ g₂ =
+  prod-m-comp f₁ f₂ g₁ g₂ =
     begin
       pair ((f₁ ∘ g₁) ∘ p₁) ((f₂ ∘ g₂) ∘ p₂)
     ≈⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
       pair (f₁ ∘ (g₁ ∘ p₁)) (f₂ ∘ (g₂ ∘ p₂))
-    ≈⟨ ≈-sym (pair-cong (∘-cong ≈-refl (pair-p₁ _ _)) (∘-cong ≈-refl (pair-p₂ _ _))) ⟩
-      pair (f₁ ∘ (p₁ ∘ pair (g₁ ∘ p₁) (g₂ ∘ p₂))) (f₂ ∘ (p₂ ∘ pair (g₁ ∘ p₁) (g₂ ∘ p₂)))
-    ≈⟨ ≈-sym (pair-cong (assoc _ _ _) (assoc _ _ _)) ⟩
-      pair ((f₁ ∘ p₁) ∘ pair (g₁ ∘ p₁) (g₂ ∘ p₂)) ((f₂ ∘ p₂) ∘ pair (g₁ ∘ p₁) (g₂ ∘ p₂))
-    ≈⟨ ≈-sym (pair-natural _ _ _) ⟩
-      pair (f₁ ∘ p₁) (f₂ ∘ p₂) ∘ pair (g₁ ∘ p₁) (g₂ ∘ p₂)
-    ∎
-    where open ≈-Reasoning isEquiv
+    ≈˘⟨ pair-compose _ _ _ _ ⟩
+      prod-m f₁ f₂ ∘ pair (g₁ ∘ p₁) (g₂ ∘ p₂)
+    ∎ where open ≈-Reasoning isEquiv
 
   prod-m-cong : ∀ {x₁ x₂ y₁ y₂} {f₁ f₂ : x₁ ⇒ y₁} {g₁ g₂ : x₂ ⇒ y₂} →
                 f₁ ≈ f₂ → g₁ ≈ g₂ → prod-m f₁ g₁ ≈ prod-m f₂ g₂
@@ -474,6 +553,21 @@ record HasProducts {o m e} (𝒞 : Category o m e) : Set (o ⊔ m ⊔ e) where
                     id _ ∎
     where open ≈-Reasoning isEquiv
 
+  prodm-pair-interchange : ∀ {w w' x y} (u : w ⇒ w') (v : x ⇒ y) →
+                           (prod-m u (id _) ∘ pair p₁ (v ∘ p₂)) ≈ (pair p₁ (v ∘ p₂) ∘ prod-m u (id _))
+  prodm-pair-interchange u v = begin
+      prod-m u (id _) ∘ pair p₁ (v ∘ p₂)
+    ≈⟨ pair-compose _ _ _ _ ⟩
+      pair (u ∘ p₁) (id _ ∘ (v ∘ p₂))
+    ≈⟨ pair-cong ≈-refl id-left ⟩
+      pair (u ∘ p₁) (v ∘ p₂)
+    ≈˘⟨ pair-cong (pair-p₁ _ _) (≈-trans (assoc _ _ _) (∘-cong ≈-refl (≈-trans (pair-p₂ _ _) id-left))) ⟩
+      pair (p₁ ∘ prod-m u (id _)) ((v ∘ p₂) ∘ prod-m u (id _))
+    ≈˘⟨ pair-natural _ _ _ ⟩
+      pair p₁ (v ∘ p₂) ∘ prod-m u (id _)
+    ∎ where open ≈-Reasoning isEquiv
+
+
   prod-m-id : ∀ {x y} → prod-m (id x) (id y) ≈ id (prod x y)
   prod-m-id =
     begin
@@ -483,8 +577,158 @@ record HasProducts {o m e} (𝒞 : Category o m e) : Set (o ⊔ m ⊔ e) where
     ≈⟨ pair-ext0 ⟩
       id _
     ∎
+
     where open ≈-Reasoning isEquiv
 
+  -- Strong (w-threading) projections and product action: the counterparts of
+  -- p₁/p₂/prod-m in the co-Kleisli category for the (prod w ⋅) comonad.
+  strong-p₁ : ∀ {w x₁ x₂} → prod w (prod x₁ x₂) ⇒ prod w x₁
+  strong-p₁ = pair p₁ (p₁ ∘ p₂)
+
+  strong-p₂ : ∀ {w x₁ x₂} → prod w (prod x₁ x₂) ⇒ prod w x₂
+  strong-p₂ = pair p₁ (p₂ ∘ p₂)
+
+  strong-prod-m : ∀ {w x₁ x₂ y₁ y₂} → prod w x₁ ⇒ y₁ → prod w x₂ ⇒ y₂ → prod w (prod x₁ x₂) ⇒ prod y₁ y₂
+  strong-prod-m f g = pair (f ∘ strong-p₁) (g ∘ strong-p₂)
+
+  strong-prod-m-cong : ∀ {w x₁ x₂ y₁ y₂} {f₁ f₂ : prod w x₁ ⇒ y₁} {g₁ g₂ : prod w x₂ ⇒ y₂} →
+                       f₁ ≈ f₂ → g₁ ≈ g₂ → strong-prod-m f₁ g₁ ≈ strong-prod-m f₂ g₂
+  strong-prod-m-cong f≈ g≈ = pair-cong (∘-cong f≈ ≈-refl) (∘-cong g≈ ≈-refl)
+
+  strong-p₁-natural : ∀ {w w' x₁ x₂ y₁ y₂} (u : w ⇒ w') (v₁ : x₁ ⇒ y₁) (v₂ : x₂ ⇒ y₂) →
+                      (strong-p₁ ∘ prod-m u (prod-m v₁ v₂)) ≈ (prod-m u v₁ ∘ strong-p₁)
+  strong-p₁-natural u v₁ v₂ =
+    begin
+      strong-p₁ ∘ prod-m u (prod-m v₁ v₂)
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₁ ∘ prod-m u (prod-m v₁ v₂)) ((p₁ ∘ p₂) ∘ prod-m u (prod-m v₁ v₂))
+    ≈⟨ pair-cong (pair-p₁ _ _) (assoc _ _ _) ⟩
+      pair (u ∘ p₁) (p₁ ∘ (p₂ ∘ prod-m u (prod-m v₁ v₂)))
+    ≈⟨ pair-cong₂ (∘-cong ≈-refl (pair-p₂ _ _)) ⟩
+      pair (u ∘ p₁) (p₁ ∘ (prod-m v₁ v₂ ∘ p₂))
+    ≈˘⟨ pair-cong₂ (assoc _ _ _) ⟩
+      pair (u ∘ p₁) ((p₁ ∘ prod-m v₁ v₂) ∘ p₂)
+    ≈⟨ pair-cong₂ (∘-cong (pair-p₁ _ _) ≈-refl) ⟩
+      pair (u ∘ p₁) ((v₁ ∘ p₁) ∘ p₂)
+    ≈⟨ pair-cong₂ (assoc _ _ _) ⟩
+      pair (u ∘ p₁) (v₁ ∘ (p₁ ∘ p₂))
+    ≈˘⟨ pair-compose _ _ _ _ ⟩
+      prod-m u v₁ ∘ strong-p₁
+    ∎ where open ≈-Reasoning isEquiv
+
+  strong-p₂-natural : ∀ {w w' x₁ x₂ y₁ y₂} (u : w ⇒ w') (v₁ : x₁ ⇒ y₁) (v₂ : x₂ ⇒ y₂) →
+                      (strong-p₂ ∘ prod-m u (prod-m v₁ v₂)) ≈ (prod-m u v₂ ∘ strong-p₂)
+  strong-p₂-natural u v₁ v₂ =
+    begin
+      strong-p₂ ∘ prod-m u (prod-m v₁ v₂)
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₁ ∘ prod-m u (prod-m v₁ v₂)) ((p₂ ∘ p₂) ∘ prod-m u (prod-m v₁ v₂))
+    ≈⟨ pair-cong (pair-p₁ _ _) (assoc _ _ _) ⟩
+      pair (u ∘ p₁) (p₂ ∘ (p₂ ∘ prod-m u (prod-m v₁ v₂)))
+    ≈⟨ pair-cong₂ (∘-cong ≈-refl (pair-p₂ _ _)) ⟩
+      pair (u ∘ p₁) (p₂ ∘ (prod-m v₁ v₂ ∘ p₂))
+    ≈˘⟨ pair-cong₂ (assoc _ _ _) ⟩
+      pair (u ∘ p₁) ((p₂ ∘ prod-m v₁ v₂) ∘ p₂)
+    ≈⟨ pair-cong₂ (∘-cong (pair-p₂ _ _) ≈-refl) ⟩
+      pair (u ∘ p₁) ((v₂ ∘ p₂) ∘ p₂)
+    ≈⟨ pair-cong₂ (assoc _ _ _) ⟩
+      pair (u ∘ p₁) (v₂ ∘ (p₂ ∘ p₂))
+    ≈˘⟨ pair-compose _ _ _ _ ⟩
+      prod-m u v₂ ∘ strong-p₂
+    ∎ where open ≈-Reasoning isEquiv
+
+  strong-prod-m-post : ∀ {w x₁ x₂ y₁ y₂ z₁ z₂} (s₁ : y₁ ⇒ z₁) (s₂ : y₂ ⇒ z₂)
+                       (f : prod w x₁ ⇒ y₁) (g : prod w x₂ ⇒ y₂) →
+                       (prod-m s₁ s₂ ∘ strong-prod-m f g) ≈ strong-prod-m (s₁ ∘ f) (s₂ ∘ g)
+  strong-prod-m-post s₁ s₂ f g =
+    begin
+      prod-m s₁ s₂ ∘ strong-prod-m f g
+    ≈⟨ pair-compose _ _ _ _ ⟩
+      pair (s₁ ∘ (f ∘ strong-p₁)) (s₂ ∘ (g ∘ strong-p₂))
+    ≈˘⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+      strong-prod-m (s₁ ∘ f) (s₂ ∘ g)
+    ∎ where open ≈-Reasoning isEquiv
+
+  strong-prod-m-pre : ∀ {w w' x₁ x₂ y₁ y₂ z₁ z₂} (f : prod w' x₁ ⇒ y₁) (g : prod w' x₂ ⇒ y₂)
+                      (u : w ⇒ w') (v₁ : z₁ ⇒ x₁) (v₂ : z₂ ⇒ x₂) →
+                      (strong-prod-m f g ∘ prod-m u (prod-m v₁ v₂)) ≈ strong-prod-m (f ∘ prod-m u v₁) (g ∘ prod-m u v₂)
+  strong-prod-m-pre f g u v₁ v₂ =
+    begin
+      strong-prod-m f g ∘ prod-m u (prod-m v₁ v₂)
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair ((f ∘ strong-p₁) ∘ prod-m u (prod-m v₁ v₂)) ((g ∘ strong-p₂) ∘ prod-m u (prod-m v₁ v₂))
+    ≈⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+      pair (f ∘ (strong-p₁ ∘ prod-m u (prod-m v₁ v₂))) (g ∘ (strong-p₂ ∘ prod-m u (prod-m v₁ v₂)))
+    ≈⟨ pair-cong (∘-cong ≈-refl (strong-p₁-natural _ _ _)) (∘-cong ≈-refl (strong-p₂-natural _ _ _)) ⟩
+      pair (f ∘ (prod-m u v₁ ∘ strong-p₁)) (g ∘ (prod-m u v₂ ∘ strong-p₂))
+    ≈˘⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+      strong-prod-m (f ∘ prod-m u v₁) (g ∘ prod-m u v₂)
+    ∎ where open ≈-Reasoning isEquiv
+
+  -- Componentwise naturality squares against prod-m actions assemble to a square
+  -- for the strong product action.
+  strong-prod-m-natural : ∀ {w w' x₁ x₂ y₁ y₂ x₁' x₂' y₁' y₂'}
+                          {f : prod w x₁ ⇒ y₁} {g : prod w x₂ ⇒ y₂}
+                          {f' : prod w' x₁' ⇒ y₁'} {g' : prod w' x₂' ⇒ y₂'}
+                          {u : w ⇒ w'} {v₁ : x₁ ⇒ x₁'} {v₂ : x₂ ⇒ x₂'} {s₁ : y₁ ⇒ y₁'} {s₂ : y₂ ⇒ y₂'} →
+                          (f' ∘ prod-m u v₁) ≈ (s₁ ∘ f) → (g' ∘ prod-m u v₂) ≈ (s₂ ∘ g) →
+                          (strong-prod-m f' g' ∘ prod-m u (prod-m v₁ v₂)) ≈ (prod-m s₁ s₂ ∘ strong-prod-m f g)
+  strong-prod-m-natural sq₁ sq₂ =
+    ≈-trans (strong-prod-m-pre _ _ _ _ _)
+      (≈-trans (strong-prod-m-cong sq₁ sq₂) (≈-sym (strong-prod-m-post _ _ _ _)))
+
+  strong-p₁-absorb : ∀ {w x₁ x₂ y₁ y₂} (h : prod w x₁ ⇒ y₁) (k : prod w x₂ ⇒ y₂) →
+                     (strong-p₁ ∘ pair p₁ (strong-prod-m h k)) ≈ pair p₁ (h ∘ strong-p₁)
+  strong-p₁-absorb h k =
+    begin
+      strong-p₁ ∘ pair p₁ (strong-prod-m h k)
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₁ ∘ pair p₁ (strong-prod-m h k)) ((p₁ ∘ p₂) ∘ pair p₁ (strong-prod-m h k))
+    ≈⟨ pair-cong (pair-p₁ _ _) (assoc _ _ _) ⟩
+      pair p₁ (p₁ ∘ (p₂ ∘ pair p₁ (strong-prod-m h k)))
+    ≈⟨ pair-cong₂ (∘-cong ≈-refl (pair-p₂ _ _)) ⟩
+      pair p₁ (p₁ ∘ strong-prod-m h k)
+    ≈⟨ pair-cong₂ (pair-p₁ _ _) ⟩
+      pair p₁ (h ∘ strong-p₁)
+    ∎ where open ≈-Reasoning isEquiv
+
+  strong-p₂-absorb : ∀ {w x₁ x₂ y₁ y₂} (h : prod w x₁ ⇒ y₁) (k : prod w x₂ ⇒ y₂) →
+                     (strong-p₂ ∘ pair p₁ (strong-prod-m h k)) ≈ pair p₁ (k ∘ strong-p₂)
+  strong-p₂-absorb h k =
+    begin
+      strong-p₂ ∘ pair p₁ (strong-prod-m h k)
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₁ ∘ pair p₁ (strong-prod-m h k)) ((p₂ ∘ p₂) ∘ pair p₁ (strong-prod-m h k))
+    ≈⟨ pair-cong (pair-p₁ _ _) (assoc _ _ _) ⟩
+      pair p₁ (p₂ ∘ (p₂ ∘ pair p₁ (strong-prod-m h k)))
+    ≈⟨ pair-cong₂ (∘-cong ≈-refl (pair-p₂ _ _)) ⟩
+      pair p₁ (p₂ ∘ strong-prod-m h k)
+    ≈⟨ pair-cong₂ (pair-p₂ _ _) ⟩
+      pair p₁ (k ∘ strong-p₂)
+    ∎ where open ≈-Reasoning isEquiv
+
+  -- The strong product action is functorial for co-Kleisli composition f ∘ pair p₁ g.
+  strong-prod-m-comp : ∀ {w x₁ x₂ y₁ y₂ z₁ z₂} (f : prod w y₁ ⇒ z₁) (g : prod w y₂ ⇒ z₂)
+                          (h : prod w x₁ ⇒ y₁) (k : prod w x₂ ⇒ y₂) →
+                          (strong-prod-m f g ∘ pair p₁ (strong-prod-m h k))
+                            ≈ strong-prod-m (f ∘ pair p₁ h) (g ∘ pair p₁ k)
+  strong-prod-m-comp f g h k =
+    begin
+      strong-prod-m f g ∘ pair p₁ (strong-prod-m h k)
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair ((f ∘ strong-p₁) ∘ pair p₁ (strong-prod-m h k)) ((g ∘ strong-p₂) ∘ pair p₁ (strong-prod-m h k))
+    ≈⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+      pair (f ∘ (strong-p₁ ∘ pair p₁ (strong-prod-m h k))) (g ∘ (strong-p₂ ∘ pair p₁ (strong-prod-m h k)))
+    ≈⟨ pair-cong (∘-cong ≈-refl (strong-p₁-absorb _ _)) (∘-cong ≈-refl (strong-p₂-absorb _ _)) ⟩
+      pair (f ∘ pair p₁ (h ∘ strong-p₁)) (g ∘ pair p₁ (k ∘ strong-p₂))
+    ≈˘⟨ pair-cong (∘-cong ≈-refl (pair-cong₁ (pair-p₁ _ _))) (∘-cong ≈-refl (pair-cong₁ (pair-p₁ _ _))) ⟩
+      pair (f ∘ pair (p₁ ∘ strong-p₁) (h ∘ strong-p₁)) (g ∘ pair (p₁ ∘ strong-p₂) (k ∘ strong-p₂))
+    ≈˘⟨ pair-cong (∘-cong ≈-refl (pair-natural _ _ _)) (∘-cong ≈-refl (pair-natural _ _ _)) ⟩
+      pair (f ∘ (pair p₁ h ∘ strong-p₁)) (g ∘ (pair p₁ k ∘ strong-p₂))
+    ≈˘⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+      strong-prod-m (f ∘ pair p₁ h) (g ∘ pair p₁ k)
+    ∎ where open ≈-Reasoning isEquiv
+
   -- functors preserve isomorphisms
   product-preserves-iso : ∀ {x₁ x₂ y₁ y₂} → Iso x₁ x₂ → Iso y₁ y₂ → Iso (prod x₁ y₁) (prod x₂ y₂)
   product-preserves-iso x₁≅x₂ y₁≅y₂ .Iso.fwd = prod-m (x₁≅x₂ .Iso.fwd) (y₁≅y₂ .Iso.fwd)
@@ -544,6 +788,38 @@ op-coproducts→products cp .HasProducts.pair-p₁ = HasCoproducts.copair-in₁
 op-coproducts→products cp .HasProducts.pair-p₂ = HasCoproducts.copair-in₂ cp
 op-coproducts→products cp .HasProducts.pair-ext = HasCoproducts.copair-ext cp
 
+-- coKleisli category for the (prod w ⋅) comonad: morphisms X → Y are prod w X ⇒ Y in 𝒞.
+-- Identity is p₂; composition is f ∘ pair p₁ g.
+module _ {o m e} {𝒞 : Category o m e} (P : HasProducts 𝒞) (w : Category.obj 𝒞) where
+  open Category 𝒞
+  open HasProducts P
+
+  coKleisli-prod : Category o m e
+  coKleisli-prod .Category.obj              = obj
+  coKleisli-prod .Category._⇒_ X Y          = prod w X ⇒ Y
+  coKleisli-prod .Category._≈_              = _≈_
+  coKleisli-prod .Category.isEquiv          = isEquiv
+  coKleisli-prod .Category.id _             = p₂
+  coKleisli-prod .Category._∘_ f g          = f ∘ pair p₁ g
+  coKleisli-prod .Category.∘-cong f≈ g≈     = ∘-cong f≈ (pair-cong ≈-refl g≈)
+  coKleisli-prod .Category.id-left          = pair-p₂ _ _
+  coKleisli-prod .Category.id-right {f = f} = begin
+      f ∘ pair p₁ p₂
+    ≈⟨ ∘-cong ≈-refl pair-ext0 ⟩
+      f ∘ id _
+    ≈⟨ id-right ⟩
+      f
+    ∎ where open ≈-Reasoning isEquiv
+  coKleisli-prod .Category.assoc f g h      = begin
+      (f ∘ pair p₁ g) ∘ pair p₁ h
+    ≈⟨ assoc _ _ _ ⟩
+      f ∘ (pair p₁ g ∘ pair p₁ h)
+    ≈⟨ ∘-cong ≈-refl (pair-natural _ _ _) ⟩
+      f ∘ pair (p₁ ∘ pair p₁ h) (g ∘ pair p₁ h)
+    ≈⟨ ∘-cong ≈-refl (pair-cong (pair-p₁ _ _) ≈-refl) ⟩
+      f ∘ pair p₁ (g ∘ pair p₁ h)
+    ∎ where open ≈-Reasoning isEquiv
+
 record HasStrongCoproducts {o m e} (𝒞 : Category o m e) (P : HasProducts 𝒞) : Set (o ⊔ m ⊔ e) where
   open Category 𝒞
   open HasProducts P
@@ -552,7 +828,195 @@ record HasStrongCoproducts {o m e} (𝒞 : Category o m e) (P : HasProducts 𝒞
     in₁    : ∀ {x y} → x ⇒ coprod x y
     in₂    : ∀ {x y} → y ⇒ coprod x y
     copair : ∀ {w x y z} → prod w x ⇒ z → prod w y ⇒ z → prod w (coprod x y) ⇒ z
-    -- FIXME: equations
+
+    copair-cong : ∀ {w x y z} {f₁ f₂ : prod w x ⇒ z} {g₁ g₂ : prod w y ⇒ z} →
+                  f₁ ≈ f₂ → g₁ ≈ g₂ → copair f₁ g₁ ≈ copair f₂ g₂
+    copair-in₁  : ∀ {w x y z} (f : prod w x ⇒ z) (g : prod w y ⇒ z) → (copair f g ∘ pair p₁ (in₁ ∘ p₂)) ≈ f
+    copair-in₂  : ∀ {w x y z} (f : prod w x ⇒ z) (g : prod w y ⇒ z) → (copair f g ∘ pair p₁ (in₂ ∘ p₂)) ≈ g
+    copair-ext  : ∀ {w x y z} (h : prod w (coprod x y) ⇒ z) →
+                  copair (h ∘ pair p₁ (in₁ ∘ p₂)) (h ∘ pair p₁ (in₂ ∘ p₂)) ≈ h
+
+  copair-cong₁ : ∀ {w x y z} {f₁ f₂ : prod w x ⇒ z} {g : prod w y ⇒ z} →
+                 f₁ ≈ f₂ → copair f₁ g ≈ copair f₂ g
+  copair-cong₁ f≈ = copair-cong f≈ ≈-refl
+
+  copair-cong₂ : ∀ {w x y z} {f : prod w x ⇒ z} {g₁ g₂ : prod w y ⇒ z} →
+                 g₁ ≈ g₂ → copair f g₁ ≈ copair f g₂
+  copair-cong₂ g≈ = copair-cong ≈-refl g≈
+
+  copair-ext0 : ∀ {w x y} → copair (in₁ ∘ p₂ {w} {x}) (in₂ ∘ p₂ {w} {y}) ≈ p₂
+  copair-ext0 = ≈-trans (copair-cong (≈-sym (pair-p₂ _ _)) (≈-sym (pair-p₂ _ _)))
+                        (copair-ext p₂)
+
+  copair-reindex : ∀ {w w' x y z} (u : w ⇒ w') (f : prod w' x ⇒ z) (g : prod w' y ⇒ z) →
+                   (copair f g ∘ prod-m u (id _)) ≈ copair (f ∘ prod-m u (id _)) (g ∘ prod-m u (id _))
+  copair-reindex u f g =
+    ≈-trans (≈-sym (copair-ext _)) (copair-cong c₁ c₂)
+    where
+      c₁ : ((copair f g ∘ prod-m u (id _)) ∘ pair p₁ (in₁ ∘ p₂)) ≈ (f ∘ prod-m u (id _))
+      c₁ = begin
+          (copair f g ∘ prod-m u (id _)) ∘ pair p₁ (in₁ ∘ p₂)
+        ≈⟨ assoc _ _ _ ⟩
+          copair f g ∘ (prod-m u (id _) ∘ pair p₁ (in₁ ∘ p₂))
+        ≈⟨ ∘-cong ≈-refl (prodm-pair-interchange u in₁) ⟩
+          copair f g ∘ (pair p₁ (in₁ ∘ p₂) ∘ prod-m u (id _))
+        ≈˘⟨ assoc _ _ _ ⟩
+          (copair f g ∘ pair p₁ (in₁ ∘ p₂)) ∘ prod-m u (id _)
+        ≈⟨ ∘-cong (copair-in₁ f g) ≈-refl ⟩
+          f ∘ prod-m u (id _)
+        ∎ where open ≈-Reasoning isEquiv
+
+      c₂ : ((copair f g ∘ prod-m u (id _)) ∘ pair p₁ (in₂ ∘ p₂)) ≈ (g ∘ prod-m u (id _))
+      c₂ = begin
+          (copair f g ∘ prod-m u (id _)) ∘ pair p₁ (in₂ ∘ p₂)
+        ≈⟨ assoc _ _ _ ⟩
+          copair f g ∘ (prod-m u (id _) ∘ pair p₁ (in₂ ∘ p₂))
+        ≈⟨ ∘-cong ≈-refl (prodm-pair-interchange u in₂) ⟩
+          copair f g ∘ (pair p₁ (in₂ ∘ p₂) ∘ prod-m u (id _))
+        ≈˘⟨ assoc _ _ _ ⟩
+          (copair f g ∘ pair p₁ (in₂ ∘ p₂)) ∘ prod-m u (id _)
+        ≈⟨ ∘-cong (copair-in₂ f g) ≈-refl ⟩
+          g ∘ prod-m u (id _)
+        ∎ where open ≈-Reasoning isEquiv
+
+  copair-natural : ∀ {w x y z z'} (h : z ⇒ z') (f : prod w x ⇒ z) (g : prod w y ⇒ z) →
+                   (h ∘ copair f g) ≈ copair (h ∘ f) (h ∘ g)
+  copair-natural h f g = begin
+      h ∘ copair f g
+    ≈˘⟨ copair-ext _ ⟩
+      copair ((h ∘ copair f g) ∘ pair p₁ (in₁ ∘ p₂)) ((h ∘ copair f g) ∘ pair p₁ (in₂ ∘ p₂))
+    ≈⟨ copair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+      copair (h ∘ (copair f g ∘ pair p₁ (in₁ ∘ p₂))) (h ∘ (copair f g ∘ pair p₁ (in₂ ∘ p₂)))
+    ≈⟨ copair-cong (∘-cong ≈-refl (copair-in₁ f g)) (∘-cong ≈-refl (copair-in₂ f g)) ⟩
+      copair (h ∘ f) (h ∘ g)
+    ∎ where open ≈-Reasoning isEquiv
+
+-- The section sect = pair to-terminal (id _) : X ⇒ witness × X of p₂ (witness terminal),
+-- i.e. the unitor X ≅ witness × X, and how it interacts with composition.
+module Unitor {o m e} {𝒞 : Category o m e} (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+  open Category 𝒞
+  open HasTerminal T
+  open HasProducts P
+
+  sect : ∀ {X} → X ⇒ prod witness X
+  sect = pair to-terminal (id _)
+
+  -- sect ∘ f and (witness × g) ∘ sect both have the unique terminal map as first component.
+  sect-pre : ∀ {X Y} (f : X ⇒ Y) → (sect ∘ f) ≈ pair to-terminal f
+  sect-pre f = ≈-trans (pair-natural _ _ _) (pair-cong (≈-sym (to-terminal-ext _)) id-left)
+
+  sect-post : ∀ {X Y} (g : X ⇒ Y) → (pair p₁ (g ∘ p₂) ∘ sect) ≈ pair to-terminal g
+  sect-post g = begin
+      pair p₁ (g ∘ p₂) ∘ sect
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₁ ∘ sect) ((g ∘ p₂) ∘ sect)
+    ≈⟨ pair-cong (pair-p₁ _ _) (assoc _ _ _) ⟩
+      pair to-terminal (g ∘ (p₂ ∘ sect))
+    ≈⟨ pair-cong ≈-refl (∘-cong₂ (pair-p₂ _ _)) ⟩
+      pair to-terminal (g ∘ id _)
+    ≈⟨ pair-cong ≈-refl id-right ⟩
+      pair to-terminal g
+    ∎ where open ≈-Reasoning isEquiv
+
+  -- Naturality of sect : Id ⇒ witness × -.
+  sect-natural : ∀ {X Y} (f : X ⇒ Y) → (sect ∘ f) ≈ (pair p₁ (f ∘ p₂) ∘ sect)
+  sect-natural f = ≈-trans (sect-pre f) (≈-sym (sect-post f))
+
+  -- When the domain is already witness × X, the terminal component collapses to p₁.
+  unitor-natural : ∀ {X Y} (h : prod witness X ⇒ Y) → (sect ∘ h) ≈ pair p₁ h
+  unitor-natural h = ≈-trans (sect-pre h) (pair-cong (to-terminal-unique _ _) ≈-refl)
+
+  -- Composing two sect-embedded maps is the embedded co-Kleisli composite.
+  unitor-comp : ∀ {X Y Z} (f : prod witness Y ⇒ Z) (g : prod witness X ⇒ Y) →
+                ((f ∘ sect) ∘ (g ∘ sect)) ≈ ((f ∘ pair p₁ g) ∘ sect)
+  unitor-comp f g = begin
+      (f ∘ sect) ∘ (g ∘ sect)
+    ≈⟨ assoc _ _ _ ⟩
+      f ∘ (sect ∘ (g ∘ sect))
+    ≈⟨ ∘-cong₂ (≈-sym (assoc _ _ _)) ⟩
+      f ∘ ((sect ∘ g) ∘ sect)
+    ≈⟨ ∘-cong₂ (∘-cong₁ (unitor-natural g)) ⟩
+      f ∘ (pair p₁ g ∘ sect)
+    ≈⟨ ≈-sym (assoc _ _ _) ⟩
+      (f ∘ pair p₁ g) ∘ sect
+    ∎ where open ≈-Reasoning isEquiv
+
+-- Given a terminal, every HasStrongCoproducts gives a plain HasCoproducts:
+-- copair f g := strong-copair (f ∘ p₂) (g ∘ p₂) ∘ pair to-terminal (id _).
+strong-coproducts→coproducts : ∀ {o m e} {𝒞 : Category o m e} {P : HasProducts 𝒞}
+                               → HasTerminal 𝒞 → HasStrongCoproducts 𝒞 P → HasCoproducts 𝒞
+strong-coproducts→coproducts {𝒞 = 𝒞} {P = P} T SCP = result
+  where
+    open Category 𝒞
+    open HasProducts P
+    open HasTerminal T renaming (witness to 𝟙)
+    open HasStrongCoproducts SCP
+      using (in₁; in₂)
+      renaming (coprod to scoprod; copair to scopair;
+                copair-cong to scopair-cong; copair-in₁ to scopair-in₁;
+                copair-in₂ to scopair-in₂; copair-ext to scopair-ext)
+
+    -- Convert plain → strong-shaped via the unitor section sect : a ⇒ 𝟙 × a.
+    open Unitor T P
+
+    result : HasCoproducts 𝒞
+    result .HasCoproducts.coprod = scoprod
+    result .HasCoproducts.in₁ = in₁
+    result .HasCoproducts.in₂ = in₂
+    result .HasCoproducts.copair f g = scopair (f ∘ p₂) (g ∘ p₂) ∘ sect
+    result .HasCoproducts.copair-cong f₁≈f₂ g₁≈g₂ =
+      ∘-cong (scopair-cong (∘-cong f₁≈f₂ ≈-refl) (∘-cong g₁≈g₂ ≈-refl)) ≈-refl
+    result .HasCoproducts.copair-in₁ f g = begin
+        (scopair (f ∘ p₂) (g ∘ p₂) ∘ sect) ∘ in₁
+      ≈⟨ assoc _ _ _ ⟩
+        scopair (f ∘ p₂) (g ∘ p₂) ∘ (sect ∘ in₁)
+      ≈⟨ ∘-cong ≈-refl (sect-natural in₁) ⟩
+        scopair (f ∘ p₂) (g ∘ p₂) ∘ (pair p₁ (in₁ ∘ p₂) ∘ sect)
+      ≈˘⟨ assoc _ _ _ ⟩
+        (scopair (f ∘ p₂) (g ∘ p₂) ∘ pair p₁ (in₁ ∘ p₂)) ∘ sect
+      ≈⟨ ∘-cong (scopair-in₁ _ _) ≈-refl ⟩
+        (f ∘ p₂) ∘ sect
+      ≈⟨ assoc _ _ _ ⟩
+        f ∘ (p₂ ∘ sect)
+      ≈⟨ ∘-cong ≈-refl (pair-p₂ _ _) ⟩
+        f ∘ id _
+      ≈⟨ id-right ⟩
+        f
+      ∎ where open ≈-Reasoning isEquiv
+    result .HasCoproducts.copair-in₂ f g = begin
+        (scopair (f ∘ p₂) (g ∘ p₂) ∘ sect) ∘ in₂
+      ≈⟨ assoc _ _ _ ⟩
+        scopair (f ∘ p₂) (g ∘ p₂) ∘ (sect ∘ in₂)
+      ≈⟨ ∘-cong ≈-refl (sect-natural in₂) ⟩
+        scopair (f ∘ p₂) (g ∘ p₂) ∘ (pair p₁ (in₂ ∘ p₂) ∘ sect)
+      ≈˘⟨ assoc _ _ _ ⟩
+        (scopair (f ∘ p₂) (g ∘ p₂) ∘ pair p₁ (in₂ ∘ p₂)) ∘ sect
+      ≈⟨ ∘-cong (scopair-in₂ _ _) ≈-refl ⟩
+        (g ∘ p₂) ∘ sect
+      ≈⟨ assoc _ _ _ ⟩
+        g ∘ (p₂ ∘ sect)
+      ≈⟨ ∘-cong ≈-refl (pair-p₂ _ _) ⟩
+        g ∘ id _
+      ≈⟨ id-right ⟩
+        g
+      ∎ where open ≈-Reasoning isEquiv
+    result .HasCoproducts.copair-ext {x} {y} {z} h = begin
+        scopair ((h ∘ in₁) ∘ p₂) ((h ∘ in₂) ∘ p₂) ∘ sect
+      ≈⟨ ∘-cong (scopair-cong (assoc _ _ _) (assoc _ _ _)) ≈-refl ⟩
+        scopair (h ∘ (in₁ ∘ p₂)) (h ∘ (in₂ ∘ p₂)) ∘ sect
+      ≈˘⟨ ∘-cong (scopair-cong (∘-cong ≈-refl (pair-p₂ _ _)) (∘-cong ≈-refl (pair-p₂ _ _))) ≈-refl ⟩
+        scopair (h ∘ (p₂ ∘ pair p₁ (in₁ ∘ p₂))) (h ∘ (p₂ ∘ pair p₁ (in₂ ∘ p₂))) ∘ sect
+      ≈˘⟨ ∘-cong (scopair-cong (assoc _ _ _) (assoc _ _ _)) ≈-refl ⟩
+        scopair ((h ∘ p₂) ∘ pair p₁ (in₁ ∘ p₂)) ((h ∘ p₂) ∘ pair p₁ (in₂ ∘ p₂)) ∘ sect
+      ≈⟨ ∘-cong (scopair-ext (h ∘ p₂)) ≈-refl ⟩
+        (h ∘ p₂) ∘ sect
+      ≈⟨ assoc _ _ _ ⟩
+        h ∘ (p₂ ∘ sect)
+      ≈⟨ ∘-cong ≈-refl (pair-p₂ _ _) ⟩
+        h ∘ id _
+      ≈⟨ id-right ⟩
+        h
+      ∎ where open ≈-Reasoning isEquiv
 
 record HasExponentials {o m e} (𝒞 : Category o m e) (P : HasProducts 𝒞) : Set (o ⊔ m ⊔ e) where
   open Category 𝒞
@@ -576,7 +1040,7 @@ record HasExponentials {o m e} (𝒞 : Category o m e) (P : HasProducts 𝒞) :
       lambda (eval ∘ prod-m (lambda g ∘ f) (id _))
     ≈˘⟨ lambda-cong (∘-cong ≈-refl (prod-m-cong ≈-refl id-left)) ⟩
       lambda (eval ∘ prod-m (lambda g ∘ f) (id _ ∘ id _))
-    ≈⟨ lambda-cong (∘-cong ≈-refl (pair-functorial (lambda g) (id _) f (id _))) ⟩
+    ≈⟨ lambda-cong (∘-cong ≈-refl (prod-m-comp (lambda g) (id _) f (id _))) ⟩
       lambda (eval ∘ (prod-m (lambda g) (id _) ∘ prod-m f (id _)))
     ≈˘⟨ lambda-cong (assoc _ _ _) ⟩
       lambda ((eval ∘ prod-m (lambda g) (id _)) ∘ prod-m f (id _))
@@ -610,7 +1074,7 @@ record HasExponentials {o m e} (𝒞 : Category o m e) (P : HasProducts 𝒞) :
       lambda ((g₁ ∘ g₂) ∘ (eval ∘ (prod-m (id _) (f₁ ∘ f₂))))
     ≈˘⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-cong id-left ≈-refl))) ⟩
       lambda ((g₁ ∘ g₂) ∘ (eval ∘ (prod-m (id _ ∘ id _) (f₁ ∘ f₂))))
-    ≈⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (pair-functorial _ _ _ _))) ⟩
+    ≈⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-comp _ _ _ _))) ⟩
       lambda ((g₁ ∘ g₂) ∘ (eval ∘ (prod-m (id _) f₁ ∘ prod-m (id _) f₂)))
     ≈⟨ lambda-cong (assoc _ _ _) ⟩
       lambda (g₁ ∘ (g₂ ∘ (eval ∘ (prod-m (id _) f₁ ∘ prod-m (id _) f₂))))
@@ -622,11 +1086,11 @@ record HasExponentials {o m e} (𝒞 : Category o m e) (P : HasProducts 𝒞) :
       lambda (g₁ ∘ ((eval ∘ prod-m (lambda (g₂ ∘ (eval ∘ prod-m (id _) f₁))) (id _)) ∘ prod-m (id _) f₂))
     ≈⟨ lambda-cong (∘-cong ≈-refl (assoc _ _ _)) ⟩
       lambda (g₁ ∘ (eval ∘ (prod-m (lambda (g₂ ∘ (eval ∘ prod-m (id _) f₁))) (id _) ∘ prod-m (id _) f₂)))
-    ≈˘⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (pair-functorial _ _ _ _))) ⟩
+    ≈˘⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-comp _ _ _ _))) ⟩
       lambda (g₁ ∘ (eval ∘ (prod-m (lambda (g₂ ∘ (eval ∘ prod-m (id _) f₁)) ∘ id _) (id _ ∘ f₂))))
     ≈⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-cong id-swap' id-swap))) ⟩
       lambda (g₁ ∘ (eval ∘ (prod-m (id _ ∘ lambda (g₂ ∘ (eval ∘ prod-m (id _) f₁))) (f₂ ∘ id _))))
-    ≈⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (pair-functorial _ _ _ _))) ⟩
+    ≈⟨ lambda-cong (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-comp _ _ _ _))) ⟩
       lambda (g₁ ∘ (eval ∘ (prod-m (id _) f₂ ∘ prod-m (lambda (g₂ ∘ (eval ∘ prod-m (id _) f₁))) (id _))))
     ≈˘⟨ lambda-cong (∘-cong ≈-refl (assoc _ _ _)) ⟩
       lambda (g₁ ∘ ((eval ∘ prod-m (id _) f₂) ∘ prod-m (lambda (g₂ ∘ (eval ∘ prod-m (id _) f₁))) (id _)))
@@ -719,3 +1183,167 @@ record HasLists {o m e} (𝒞 : Category o m e) (T : HasTerminal 𝒞) (P : HasP
            prod (prod x y) z ⇒ z →
            prod x (list y) ⇒ z
   -- FIXME: equations
+
+-- Any CCC has strong coproducts.
+ccc→strong-coproducts : ∀ {o m e} {𝒞 : Category o m e} {P : HasProducts 𝒞}
+                        → HasCoproducts 𝒞 → HasExponentials 𝒞 P → HasStrongCoproducts 𝒞 P
+ccc→strong-coproducts {𝒞 = 𝒞} {P = P} CP E = strongCoproducts
+  where
+    open Category 𝒞
+    open HasProducts P
+    open HasCoproducts CP
+    open HasExponentials E
+
+    -- Lambda-abstract over the *second* factor of a product (via swap).
+    lambda' : ∀ {w x y} → prod w x ⇒ y → x ⇒ exp w y
+    lambda' f = lambda (f ∘ swap)
+
+    pair-via-swap : ∀ {w x y} (h : x ⇒ y) → (prod-m h (id _) ∘ swap {w} {x}) ≈ pair (h ∘ p₂) p₁
+    pair-via-swap h = begin
+        pair (h ∘ p₁) (id _ ∘ p₂) ∘ pair p₂ p₁
+      ≈⟨ pair-natural _ _ _ ⟩
+        pair ((h ∘ p₁) ∘ pair p₂ p₁) ((id _ ∘ p₂) ∘ pair p₂ p₁)
+      ≈⟨ pair-cong (assoc _ _ _) (assoc _ _ _) ⟩
+        pair (h ∘ (p₁ ∘ pair p₂ p₁)) (id _ ∘ (p₂ ∘ pair p₂ p₁))
+      ≈⟨ pair-cong (∘-cong ≈-refl (pair-p₁ _ _)) (∘-cong ≈-refl (pair-p₂ _ _)) ⟩
+        pair (h ∘ p₂) (id _ ∘ p₁)
+      ≈⟨ pair-cong ≈-refl id-left ⟩
+        pair (h ∘ p₂) p₁
+      ∎ where open ≈-Reasoning isEquiv
+
+    eval-lambda' : ∀ {w x y} (f : prod w x ⇒ y) → eval ∘ pair (lambda' f ∘ p₂) p₁ ≈ f
+    eval-lambda' f = begin
+        eval ∘ pair (lambda (f ∘ swap) ∘ p₂) p₁
+      ≈˘⟨ ∘-cong ≈-refl (pair-via-swap (lambda (f ∘ swap))) ⟩
+        eval ∘ (prod-m (lambda (f ∘ swap)) (id _) ∘ swap)
+      ≈˘⟨ assoc _ _ _ ⟩
+        (eval ∘ prod-m (lambda (f ∘ swap)) (id _)) ∘ swap
+      ≈⟨ ∘-cong (eval-lambda (f ∘ swap)) ≈-refl ⟩
+        (f ∘ swap) ∘ swap
+      ≈⟨ assoc _ _ _ ⟩
+        f ∘ (swap ∘ swap)
+      ≈⟨ ∘-cong ≈-refl swap-involutive ⟩
+        f ∘ id _
+      ≈⟨ id-right ⟩
+        f
+      ∎ where open ≈-Reasoning isEquiv
+
+    lambda'-ext : ∀ {w x y} (f : x ⇒ exp w y) → lambda' (eval ∘ pair (f ∘ p₂) p₁) ≈ f
+    lambda'-ext f = begin
+        lambda ((eval ∘ pair (f ∘ p₂) p₁) ∘ swap)
+      ≈⟨ lambda-cong (assoc _ _ _) ⟩
+        lambda (eval ∘ (pair (f ∘ p₂) p₁ ∘ swap))
+      ≈⟨ lambda-cong (∘-cong ≈-refl (pair-natural _ _ _)) ⟩
+        lambda (eval ∘ pair ((f ∘ p₂) ∘ swap) (p₁ ∘ swap))
+      ≈⟨ lambda-cong (∘-cong ≈-refl (pair-cong (assoc _ _ _) (pair-p₁ _ _))) ⟩
+        lambda (eval ∘ pair (f ∘ (p₂ ∘ swap)) p₂)
+      ≈⟨ lambda-cong (∘-cong ≈-refl (pair-cong (∘-cong ≈-refl (pair-p₂ _ _)) ≈-refl)) ⟩
+        lambda (eval ∘ pair (f ∘ p₁) p₂)
+      ≈˘⟨ lambda-cong (∘-cong ≈-refl (pair-cong ≈-refl id-left)) ⟩
+        lambda (eval ∘ pair (f ∘ p₁) (id _ ∘ p₂))
+      ≈⟨ lambda-ext f ⟩
+        f
+      ∎ where open ≈-Reasoning isEquiv
+
+    swap-shape : ∀ {w x x'} (j : x' ⇒ x) →
+                 pair (p₁ {w} {x'}) (j ∘ p₂) ∘ swap {x'} {w} ≈ swap {x} {w} ∘ prod-m j (id w)
+    swap-shape j = begin
+        pair p₁ (j ∘ p₂) ∘ pair p₂ p₁
+      ≈⟨ pair-natural _ _ _ ⟩
+        pair (p₁ ∘ pair p₂ p₁) ((j ∘ p₂) ∘ pair p₂ p₁)
+      ≈⟨ pair-cong (pair-p₁ _ _) (assoc _ _ _) ⟩
+        pair p₂ (j ∘ (p₂ ∘ pair p₂ p₁))
+      ≈⟨ pair-cong ≈-refl (∘-cong ≈-refl (pair-p₂ _ _)) ⟩
+        pair p₂ (j ∘ p₁)
+      ≈˘⟨ pair-cong id-left ≈-refl ⟩
+        pair (id _ ∘ p₂) (j ∘ p₁)
+      ≈˘⟨ pair-cong (pair-p₂ _ _) (pair-p₁ _ _) ⟩
+        pair (p₂ ∘ pair (j ∘ p₁) (id _ ∘ p₂)) (p₁ ∘ pair (j ∘ p₁) (id _ ∘ p₂))
+      ≈˘⟨ pair-natural _ _ _ ⟩
+        pair p₂ p₁ ∘ pair (j ∘ p₁) (id _ ∘ p₂)
+      ∎ where open ≈-Reasoning isEquiv
+
+    lambda'-natural : ∀ {w x x' y} (j : x' ⇒ x) (h : prod w x ⇒ y) →
+                      lambda' (h ∘ pair p₁ (j ∘ p₂)) ≈ (lambda' h ∘ j)
+    lambda'-natural j h = begin
+        lambda ((h ∘ pair p₁ (j ∘ p₂)) ∘ swap)
+      ≈⟨ lambda-cong (assoc _ _ _) ⟩
+        lambda (h ∘ (pair p₁ (j ∘ p₂) ∘ swap))
+      ≈⟨ lambda-cong (∘-cong ≈-refl (swap-shape j)) ⟩
+        lambda (h ∘ (swap ∘ prod-m j (id _)))
+      ≈˘⟨ lambda-cong (assoc _ _ _) ⟩
+        lambda ((h ∘ swap) ∘ prod-m j (id _))
+      ≈˘⟨ lambda-natural _ _ ⟩
+        lambda (h ∘ swap) ∘ j
+      ∎ where open ≈-Reasoning isEquiv
+
+    strong-copair : ∀ {w x y z} → prod w x ⇒ z → prod w y ⇒ z → prod w (coprod x y) ⇒ z
+    strong-copair f g = eval ∘ pair (copair (lambda' f) (lambda' g) ∘ p₂) p₁
+
+    strong-copair-cong : ∀ {w x y z} {f₁ f₂ : prod w x ⇒ z} {g₁ g₂ : prod w y ⇒ z} →
+                         f₁ ≈ f₂ → g₁ ≈ g₂ → strong-copair f₁ g₁ ≈ strong-copair f₂ g₂
+    strong-copair-cong f₁≈f₂ g₁≈g₂ =
+      ∘-cong ≈-refl (pair-cong (∘-cong (copair-cong (lambda-cong (∘-cong f₁≈f₂ ≈-refl))
+                                                    (lambda-cong (∘-cong g₁≈g₂ ≈-refl))) ≈-refl) ≈-refl)
+
+    strong-copair-in₁ : ∀ {w x y z} (f : prod w x ⇒ z) (g : prod w y ⇒ z) →
+                        (strong-copair f g ∘ pair p₁ (in₁ ∘ p₂)) ≈ f
+    strong-copair-in₁ f g = begin
+        (eval ∘ pair (copair (lambda' f) (lambda' g) ∘ p₂) p₁) ∘ pair p₁ (in₁ ∘ p₂)
+      ≈⟨ assoc _ _ _ ⟩
+        eval ∘ (pair (copair (lambda' f) (lambda' g) ∘ p₂) p₁ ∘ pair p₁ (in₁ ∘ p₂))
+      ≈⟨ ∘-cong ≈-refl (pair-natural _ _ _) ⟩
+        eval ∘ pair ((copair (lambda' f) (lambda' g) ∘ p₂) ∘ pair p₁ (in₁ ∘ p₂)) (p₁ ∘ pair p₁ (in₁ ∘ p₂))
+      ≈⟨ ∘-cong ≈-refl (pair-cong (assoc _ _ _) (pair-p₁ _ _)) ⟩
+        eval ∘ pair (copair (lambda' f) (lambda' g) ∘ (p₂ ∘ pair p₁ (in₁ ∘ p₂))) p₁
+      ≈⟨ ∘-cong ≈-refl (pair-cong (∘-cong ≈-refl (pair-p₂ _ _)) ≈-refl) ⟩
+        eval ∘ pair (copair (lambda' f) (lambda' g) ∘ (in₁ ∘ p₂)) p₁
+      ≈˘⟨ ∘-cong ≈-refl (pair-cong (assoc _ _ _) ≈-refl) ⟩
+        eval ∘ pair ((copair (lambda' f) (lambda' g) ∘ in₁) ∘ p₂) p₁
+      ≈⟨ ∘-cong ≈-refl (pair-cong (∘-cong (copair-in₁ _ _) ≈-refl) ≈-refl) ⟩
+        eval ∘ pair (lambda' f ∘ p₂) p₁
+      ≈⟨ eval-lambda' f ⟩
+        f
+      ∎ where open ≈-Reasoning isEquiv
+
+    strong-copair-in₂ : ∀ {w x y z} (f : prod w x ⇒ z) (g : prod w y ⇒ z) →
+                        (strong-copair f g ∘ pair p₁ (in₂ ∘ p₂)) ≈ g
+    strong-copair-in₂ f g = begin
+        (eval ∘ pair (copair (lambda' f) (lambda' g) ∘ p₂) p₁) ∘ pair p₁ (in₂ ∘ p₂)
+      ≈⟨ assoc _ _ _ ⟩
+        eval ∘ (pair (copair (lambda' f) (lambda' g) ∘ p₂) p₁ ∘ pair p₁ (in₂ ∘ p₂))
+      ≈⟨ ∘-cong ≈-refl (pair-natural _ _ _) ⟩
+        eval ∘ pair ((copair (lambda' f) (lambda' g) ∘ p₂) ∘ pair p₁ (in₂ ∘ p₂)) (p₁ ∘ pair p₁ (in₂ ∘ p₂))
+      ≈⟨ ∘-cong ≈-refl (pair-cong (assoc _ _ _) (pair-p₁ _ _)) ⟩
+        eval ∘ pair (copair (lambda' f) (lambda' g) ∘ (p₂ ∘ pair p₁ (in₂ ∘ p₂))) p₁
+      ≈⟨ ∘-cong ≈-refl (pair-cong (∘-cong ≈-refl (pair-p₂ _ _)) ≈-refl) ⟩
+        eval ∘ pair (copair (lambda' f) (lambda' g) ∘ (in₂ ∘ p₂)) p₁
+      ≈˘⟨ ∘-cong ≈-refl (pair-cong (assoc _ _ _) ≈-refl) ⟩
+        eval ∘ pair ((copair (lambda' f) (lambda' g) ∘ in₂) ∘ p₂) p₁
+      ≈⟨ ∘-cong ≈-refl (pair-cong (∘-cong (copair-in₂ _ _) ≈-refl) ≈-refl) ⟩
+        eval ∘ pair (lambda' g ∘ p₂) p₁
+      ≈⟨ eval-lambda' g ⟩
+        g
+      ∎ where open ≈-Reasoning isEquiv
+
+    strong-copair-ext : ∀ {w x y z} (h : prod w (coprod x y) ⇒ z) →
+                        strong-copair (h ∘ pair p₁ (in₁ ∘ p₂)) (h ∘ pair p₁ (in₂ ∘ p₂)) ≈ h
+    strong-copair-ext h = begin
+        eval ∘ pair (copair (lambda' (h ∘ pair p₁ (in₁ ∘ p₂))) (lambda' (h ∘ pair p₁ (in₂ ∘ p₂))) ∘ p₂) p₁
+      ≈⟨ ∘-cong ≈-refl (pair-cong (∘-cong (copair-cong (lambda'-natural in₁ h) (lambda'-natural in₂ h)) ≈-refl) ≈-refl) ⟩
+        eval ∘ pair (copair (lambda' h ∘ in₁) (lambda' h ∘ in₂) ∘ p₂) p₁
+      ≈⟨ ∘-cong ≈-refl (pair-cong (∘-cong (copair-ext _) ≈-refl) ≈-refl) ⟩
+        eval ∘ pair (lambda' h ∘ p₂) p₁
+      ≈⟨ eval-lambda' h ⟩
+        h
+      ∎ where open ≈-Reasoning isEquiv
+
+    strongCoproducts : HasStrongCoproducts 𝒞 P
+    strongCoproducts .HasStrongCoproducts.coprod = coprod
+    strongCoproducts .HasStrongCoproducts.in₁ = in₁
+    strongCoproducts .HasStrongCoproducts.in₂ = in₂
+    strongCoproducts .HasStrongCoproducts.copair = strong-copair
+    strongCoproducts .HasStrongCoproducts.copair-cong = strong-copair-cong
+    strongCoproducts .HasStrongCoproducts.copair-in₁ = strong-copair-in₁
+    strongCoproducts .HasStrongCoproducts.copair-in₂ = strong-copair-in₂
+    strongCoproducts .HasStrongCoproducts.copair-ext = strong-copair-ext
diff --git a/agda/src/conservativity.agda b/agda/src/conservativity.agda
index 92099c6a..5957f4f7 100644
--- a/agda/src/conservativity.agda
+++ b/agda/src/conservativity.agda
@@ -1,22 +1,30 @@
 {-# OPTIONS --postfix-projections --prop --safe #-}
 
-open import Level using (Lift; lift; lower; _⊔_; 0ℓ)
+open import Level using (Level; Lift; lift; lower; _⊔_; 0ℓ) renaming (suc to lsuc)
 open import Data.Product using (_,_)
-open import prop using (_,_; proj₁; proj₂; ∃; LiftP; lift; lower; liftS; LiftS; inj₁; inj₂)
-open import basics using (module ≤-Reasoning; IsClosureOp; IsJoin; IsMeet)
+open import prop using (_,_; proj₁; proj₂; ∃; ∃ₛ; Prf; ⟪_⟫; LiftP; lift; lower; liftS; LiftS; inj₁; inj₂)
+open import basics using (module ≤-Reasoning; IsClosureOp; IsJoin; IsMeet; IsBigJoin; IsPreorder)
 open import categories
   using (Category; HasBooleans; HasProducts; HasCoproducts; HasExponentials;
-         HasTerminal; IsTerminal; IsProduct; coproducts+exp→booleans; setoid→category)
+         HasTerminal; IsTerminal; IsProduct; coproducts+exp→booleans; setoid→category;
+         HasStrongCoproducts; ccc→strong-coproducts; strong-coproducts→coproducts)
+import Data.Nat
+import Data.Fin
+open import Relation.Binary.PropositionalEquality using (_≡_) renaming (refl to ≡-refl)
+import polynomial-functor
 open import functor
   using (Functor; _∘F_; opF; _∘H_; ∘H-cong; id; _∘_; NatTrans; ≃-NatTrans; ≃-isEquivalence;
          interchange; H-id; NT-id-left;
-         HasColimits; NatIso)
+         HasColimits; Colimit; IsColimit; colambda-unique; constF; NatIso; functor-preserve-iso)
 open import prop-setoid using (module ≈-Reasoning; IsEquivalence; Setoid)
 open import setoid-cat using (SetoidCat)
 open import predicate-system using (PredicateSystem; ClosureOp; FunctorPred; MonadPred)
-open import stable-coproducts using (StableBits; Stable)
+open import stable-coproducts using (StableBits)
+import fam-mu-realisation
 import glueing-simple
 import setoid-predicate
+import stable-coproducts-indexed
+import finite-coproducts-from-indexed
 open import finite-product-functor
   using ( preserve-chosen-products
         ; preserve-chosen-terminal
@@ -40,20 +48,55 @@ open ≃-NatTrans
 
 module conservativity
   {o₁ o₂ m e}
-  -- Category for interpreting first-order things
-  (𝒞 : Category o₁ m e) (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞CP : HasCoproducts 𝒞) (stable : Stable 𝒞CP) (𝒞M : Monad 𝒞)
+  -- Category for interpreting first-order things, with stable set-indexed
+  -- coproducts (the finite coproducts used below are their two-element instance)
+  (𝒞 : Category o₁ m e) (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞M : Monad 𝒞)
+  (𝒞DC : ∀ (S : Setoid 0ℓ 0ℓ) → HasColimits (setoid→category S) 𝒞)
+  (𝒞istable : stable-coproducts-indexed.IdxStable 𝒞DC)
   -- A higher order model
-  (𝒟 : Category o₂ m e) (𝒟T : HasTerminal 𝒟) (𝒟P : HasProducts 𝒟) (𝒟CP : HasCoproducts 𝒟) (𝒟E : HasExponentials 𝒟 𝒟P) (𝒟M : Monad 𝒟)
+  (𝒟 : Category o₂ m e) (𝒟T : HasTerminal 𝒟) (𝒟P : HasProducts 𝒟) (𝒟E : HasExponentials 𝒟 𝒟P) (𝒟M : Monad 𝒟)
   (𝒟DC : ∀ (A : Setoid 0ℓ 0ℓ) → HasColimits (setoid→category A) 𝒟)
-  -- A functor which preserves terminal, products, and coproducts
+  -- A functor which preserves terminal and products
   (F  : Functor 𝒞 𝒟)
   (FT : preserve-chosen-terminal F 𝒞T 𝒟T)
   (FP : preserve-chosen-products F 𝒞P 𝒟P)
-  (FC : preserve-chosen-coproducts F 𝒞CP 𝒟CP)
   (FM : preserve-monad F 𝒞M 𝒟M)
-  (FM-C : preserve-chosen-coproducts (Monad.funct 𝒞M) 𝒞CP 𝒞CP)
+  -- The monad functor preserves set-indexed coproducts (an iso commuting with
+  -- the injections)
+  (FM-DC : ∀ (S : Setoid 0ℓ 0ℓ) (D : Functor (setoid→category S) 𝒞) →
+           ∃ₛ (Category.Iso 𝒞 (Colimit.apex (𝒞DC S (Monad.funct 𝒞M ∘F D)))
+                              (Monad.funct 𝒞M .fobj (Colimit.apex (𝒞DC S D))))
+              (λ i → ∀ s → Category._≈_ 𝒞
+                            (Category._∘_ 𝒞 (Category.Iso.fwd i)
+                               (Colimit.cocone (𝒞DC S (Monad.funct 𝒞M ∘F D)) .transf s))
+                            (Monad.funct 𝒞M .fmor (Colimit.cocone (𝒞DC S D) .transf s))))
+  -- F preserves set-indexed coproducts (an iso commuting with the injections)
+  (F-DC : ∀ (S : Setoid 0ℓ 0ℓ) (D : Functor (setoid→category S) 𝒞) →
+          ∃ₛ (Category.Iso 𝒟 (Colimit.apex (𝒟DC S (F ∘F D)))
+                             (F .fobj (Colimit.apex (𝒞DC S D))))
+             (λ i → ∀ s → Category._≈_ 𝒟
+                           (Category._∘_ 𝒟 (Category.Iso.fwd i)
+                              (Colimit.cocone (𝒟DC S (F ∘F D)) .transf s))
+                           (F .fmor (Colimit.cocone (𝒞DC S D) .transf s))))
+  -- F reflects equality, and picks a definability witness uniformly
+  (F-faithful : ∀ {a b} {g₁ g₂ : Category._⇒_ 𝒞 a b} → Category._≈_ 𝒟 (F .fmor g₁) (F .fmor g₂) → Category._≈_ 𝒞 g₁ g₂)
+  (Fdef : ∀ {a b} (h : Category._⇒_ 𝒟 (F .fobj a) (F .fobj b)) →
+          Prf (∃ (Category._⇒_ 𝒞 a b) λ g → Category._≈_ 𝒟 (F .fmor g) h) →
+          ∃ₛ (Category._⇒_ 𝒞 a b) λ g → Category._≈_ 𝒟 (F .fmor g) h)
   where
 
+-- The finite coproducts and their preservation are the two-element instance of
+-- the set-indexed structure.
+private
+  module 𝒞d = finite-coproducts-from-indexed.derive 𝒞DC
+  module 𝒟d = finite-coproducts-from-indexed.derive 𝒟DC
+
+  𝒞CP = 𝒞d.coproducts-from-indexed
+  𝒟CP = 𝒟d.coproducts-from-indexed
+  stable = 𝒞d.stable-from-indexed 𝒞istable
+  FC = finite-coproducts-from-indexed.preserve.preserve-from-indexed 𝒞DC 𝒟DC F F-DC
+  FM-C = finite-coproducts-from-indexed.preserve.preserve-from-indexed 𝒞DC 𝒞DC (Monad.funct 𝒞M) FM-DC
+
 private
   module 𝒞 = Category 𝒞
   module 𝒞T = HasTerminal 𝒞T
@@ -69,8 +112,8 @@ private
 
 ------------------------------------------------------------------------------
 -- Kripke Predicates “of varying arity”
-open import yoneda (o₁ ⊔ o₂ ⊔ m ⊔ e) 𝒞 renaming (PSh to PSh⟨𝒞⟩; products to PSh⟨𝒞⟩-products) using (module DayMonad; module UnaryDay; Coend; Cowedge)
-open import yoneda (o₁ ⊔ o₂ ⊔ m ⊔ e) 𝒟 renaming (よ to 𝒟よ) using ()
+open import yoneda (o₁ ⊔ o₂ ⊔ m ⊔ e ⊔ lsuc 0ℓ) 𝒞 renaming (PSh to PSh⟨𝒞⟩; products to PSh⟨𝒞⟩-products) using (module DayMonad; module UnaryDay; Coend; Cowedge)
+open import yoneda (o₁ ⊔ o₂ ⊔ m ⊔ e ⊔ lsuc 0ℓ) 𝒟 renaming (よ to 𝒟よ) using ()
 
 open DayMonad 𝒞M using (monad-hat)
 
@@ -138,7 +181,7 @@ module _ where
   open Coend
   open Cowedge
 
-  G-monad-cw : ∀ x y → Cowedge 𝟙 (M-hat-F (𝒟よ .fobj x ∘F opF F) y) (𝒟.hom-setoid-l (o₁ ⊔ o₂ ⊔ m ⊔ e) (o₁ ⊔ o₂ ⊔ m ⊔ e) (F .fobj y) (𝒟M.funct .fobj x))
+  G-monad-cw : ∀ x y → Cowedge 𝟙 (M-hat-F (𝒟よ .fobj x ∘F opF F) y) (𝒟.hom-setoid-l (o₁ ⊔ o₂ ⊔ m ⊔ e ⊔ lsuc 0ℓ) (o₁ ⊔ o₂ ⊔ m ⊔ e ⊔ lsuc 0ℓ) (F .fobj y) (𝒟M.funct .fobj x))
   G-monad-cw x y .dtransf z .func (_ , lift g , lift h) =
     lift (𝒟M.funct .fmor h 𝒟.∘ (FM.transform .transf z 𝒟.∘ F .fmor g))
   G-monad-cw x y .dtransf z .func-resp-≈ (_ , lift g₁≈g₂ , lift h₁≈h₂) =
@@ -245,11 +288,11 @@ module _ where
 
 ------------------------------------------------------------------------------
 -- Presheaf predicates
-open import presheaf-predicate (o₁ ⊔ o₂ ⊔ m ⊔ e) 𝒞
+open import presheaf-predicate (o₁ ⊔ o₂ ⊔ m ⊔ e ⊔ lsuc 0ℓ) 𝒞
   renaming (system to PSh⟨𝒞⟩-system; Predicate to PShPredicate)
-  using (_⊑_; module CoproductMonad;
+  using (_⊑_; module CoverMonad;
          _++_; _⟨_⟩; ⊑-isPreorder; _[_]; []-++; ++-isJoin; _&&_; &&-isMeet; TT; TT-isTop;
-         module Monad-hat-pred)
+         ⋁; module Monad-hat-pred)
 
 module PSh⟨𝒞⟩-system = PredicateSystem PSh⟨𝒞⟩-system
 
@@ -262,7 +305,7 @@ open _⊑_
 
 -- The “𝒞 definability” predicate.
 Definable : ∀ x → PShPredicate (G .fobj (F .fobj x))
-Definable x .pred y .pred (lift f) = LiftP (o₁ ⊔ o₂) (∃ (y 𝒞.⇒ x) λ g → F .fmor g 𝒟.≈ f)
+Definable x .pred y .pred (lift f) = LiftP (o₁ ⊔ o₂ ⊔ lsuc 0ℓ) (∃ (y 𝒞.⇒ x) λ g → F .fmor g 𝒟.≈ f)
 Definable x .pred y .pred-≃ {lift f₁} {lift f₂} (lift f₁≈f₂) (lift (g , eq)) = lift (g , 𝒟.≈-trans eq f₁≈f₂)
 Definable x .pred-mor h .*⊑* (lift f) (lift (g , eq)) =
    lift (g 𝒞.∘ h , 𝒟.≈-trans (F .fmor-comp g h) (𝒟.∘-cong eq 𝒟.≈-refl))
@@ -310,50 +353,233 @@ Definable-products {x} {y} .*⊑* a .*⊑* (lift f) (lift (g₁ , eq₁) , lift
   where open ≈-Reasoning 𝒟.isEquiv
         open preserve-chosen-products-consequences F 𝒞P 𝒟P FP
 
-open CoproductMonad 𝒞CP stable
+------------------------------------------------------------------------------
+-- The coverage generating the closure: coproduct decompositions of the stage,
+-- binary or set-indexed.
+module SI = stable-coproducts-indexed 𝒞DC
+
+private
+  Levℓ : Level
+  Levℓ = o₁ ⊔ o₂ ⊔ m ⊔ e ⊔ lsuc 0ℓ
+
+data Side : Set Levℓ where
+  inl inr : Side
+
+record BinCover (y : 𝒞.obj) : Set Levℓ where
+  field
+    y₁  : 𝒞.obj
+    y₂  : 𝒞.obj
+    iso : 𝒞.Iso (𝒞CP.coprod y₁ y₂) y
+
+record IdxCover (y : 𝒞.obj) : Set Levℓ where
+  field
+    S   : Setoid 0ℓ 0ℓ
+    D   : Functor (setoid→category S) 𝒞
+    iso : 𝒞.Iso (SI.∐ S D) y
+
+data Cover (y : 𝒞.obj) : Set Levℓ where
+  bin : BinCover y → Cover y
+  idx : IdxCover y → Cover y
+
+CIx : ∀ {y} → Cover y → Set Levℓ
+CIx (bin _) = Side
+CIx (idx c) = Lift Levℓ (c .IdxCover.S .Setoid.Carrier)
+
+cDom : ∀ {y} (c : Cover y) → CIx c → 𝒞.obj
+cDom (bin c) inl = c .BinCover.y₁
+cDom (bin c) inr = c .BinCover.y₂
+cDom (idx c) (lift s) = c .IdxCover.D .fobj s
+
+cInj : ∀ {y} (c : Cover y) (s : CIx c) → cDom c s 𝒞.⇒ y
+cInj (bin c) inl = c .BinCover.iso .𝒞.Iso.fwd 𝒞.∘ 𝒞CP.in₁
+cInj (bin c) inr = c .BinCover.iso .𝒞.Iso.fwd 𝒞.∘ 𝒞CP.in₂
+cInj (idx c) (lift s) = c .IdxCover.iso .𝒞.Iso.fwd 𝒞.∘ SI.inj (c .IdxCover.D) s
+
+module CvM = CoverMonad Cover CIx cDom cInj
+
+-- Covers pull back along any morphism: binary by stability of the finite
+-- coproducts, set-indexed by stability of the set-indexed ones.
+covPull : ∀ {x y} (c : Cover x) (g : y 𝒞.⇒ x) → CvM.CoverPullback c g
+covPull (bin c) g = pb
+  where
+    open CvM.CoverPullback
+    stb = stable (c .BinCover.iso) g
+
+    pb : CvM.CoverPullback (bin c) g
+    pb .cover = bin (record { y₁ = stb .StableBits.y₁ ; y₂ = stb .StableBits.y₂ ; iso = stb .StableBits.h })
+    pb .reix s = s
+    pb .leg inl = stb .StableBits.h₁
+    pb .leg inr = stb .StableBits.h₂
+    pb .eq inl = 𝒞.≈-trans (𝒞.assoc _ _ _) (stb .StableBits.eq₁)
+    pb .eq inr = 𝒞.≈-trans (𝒞.assoc _ _ _) (stb .StableBits.eq₂)
+covPull (idx c) g = pb
+  where
+    open CvM.CoverPullback
+    stb = 𝒞istable (c .IdxCover.iso) g
+
+    pb : CvM.CoverPullback (idx c) g
+    pb .cover = idx (record { S = c .IdxCover.S ; D = stb .SI.IdxStableBits.E ; iso = stb .SI.IdxStableBits.h })
+    pb .reix (lift s) = lift s
+    pb .leg (lift s) = stb .SI.IdxStableBits.leg s
+    pb .eq (lift s) = 𝒞.≈-trans (𝒞.assoc _ _ _) (stb .SI.IdxStableBits.eq s)
+
+open CvM
+open CvM.Closure covPull
+
+module MDistrib = Distrib 𝒞M.funct
+
+-- Covers pull back along morphisms into the monad functor's images, using its
+-- preservation of finite and set-indexed coproducts: pull back the functor
+-- image of the cover, and correct the injections.
+FMpull : ∀ {x y} (c : Cover x) (g : y 𝒞.⇒ 𝒞M.funct .fobj x) → MDistrib.FCoverPullback c g
+FMpull (bin c) g = fp
+  where
+    open MDistrib.FCoverPullback
+    open preserve-chosen-coproducts-consequences 𝒞M.funct 𝒞CP 𝒞CP FM-C using (iso)
+
+    Mc : BinCover (𝒞M.funct .fobj _)
+    Mc .BinCover.y₁ = 𝒞M.funct .fobj (c .BinCover.y₁)
+    Mc .BinCover.y₂ = 𝒞M.funct .fobj (c .BinCover.y₂)
+    Mc .BinCover.iso = 𝒞.Iso-trans iso (functor-preserve-iso 𝒞M.funct (c .BinCover.iso))
+
+    pb = covPull (bin Mc) g
+
+    bridge₁ : 𝒞M.funct .fmor (cInj (bin c) inl) 𝒞.≈ cInj (bin Mc) inl
+    bridge₁ =
+      𝒞.≈-trans (𝒞M.funct .fmor-comp _ _)
+        (𝒞.≈-trans (𝒞.∘-cong 𝒞.≈-refl (𝒞.≈-sym (𝒞CP.copair-in₁ _ _))) (𝒞.≈-sym (𝒞.assoc _ _ _)))
+    bridge₂ : 𝒞M.funct .fmor (cInj (bin c) inr) 𝒞.≈ cInj (bin Mc) inr
+    bridge₂ =
+      𝒞.≈-trans (𝒞M.funct .fmor-comp _ _)
+        (𝒞.≈-trans (𝒞.∘-cong 𝒞.≈-refl (𝒞.≈-sym (𝒞CP.copair-in₂ _ _))) (𝒞.≈-sym (𝒞.assoc _ _ _)))
+
+    fp : MDistrib.FCoverPullback (bin c) g
+    fp .cover = pb .CoverPullback.cover
+    fp .reix s = s
+    fp .leg inl = pb .CoverPullback.leg inl
+    fp .leg inr = pb .CoverPullback.leg inr
+    fp .eq inl = 𝒞.≈-trans (𝒞.∘-cong bridge₁ 𝒞.≈-refl) (pb .CoverPullback.eq inl)
+    fp .eq inr = 𝒞.≈-trans (𝒞.∘-cong bridge₂ 𝒞.≈-refl) (pb .CoverPullback.eq inr)
+FMpull (idx c) g with FM-DC (c .IdxCover.S) (c .IdxCover.D)
+... | Miso , Mcompat = fp
+  where
+    open MDistrib.FCoverPullback
+
+    Mc : IdxCover (𝒞M.funct .fobj _)
+    Mc .IdxCover.S = c .IdxCover.S
+    Mc .IdxCover.D = 𝒞M.funct ∘F (c .IdxCover.D)
+    Mc .IdxCover.iso = 𝒞.Iso-trans Miso (functor-preserve-iso 𝒞M.funct (c .IdxCover.iso))
+
+    pb = covPull (idx Mc) g
+
+    bridge : ∀ s → 𝒞M.funct .fmor (cInj (idx c) (lift s)) 𝒞.≈ cInj (idx Mc) (lift s)
+    bridge s =
+      𝒞.≈-trans (𝒞M.funct .fmor-comp _ _)
+        (𝒞.≈-trans (𝒞.∘-cong 𝒞.≈-refl (𝒞.≈-sym (Mcompat s))) (𝒞.≈-sym (𝒞.assoc _ _ _)))
+
+    fp : MDistrib.FCoverPullback (idx c) g
+    fp .cover = pb .CoverPullback.cover
+    fp .reix (lift s) = lift s
+    fp .leg (lift s) = pb .CoverPullback.leg (lift s)
+    fp .eq (lift s) = 𝒞.≈-trans (𝒞.∘-cong (bridge s) 𝒞.≈-refl) (pb .CoverPullback.eq (lift s))
 
 Definable-coproducts : ∀ {x y} →
                 Definable (𝒞CP.coprod x y) ⊑
                 𝐂 ((Definable x ⟨ G .fmor (F .fmor 𝒞CP.in₁) ⟩) ++ (Definable y ⟨ G .fmor (F .fmor 𝒞CP.in₂) ⟩))
-Definable-coproducts .*⊑* z .*⊑* (lift g) (lift (f , eq)) =
-  liftS (node (stb .StableBits.y₁) (stb .StableBits.y₂)
-              (lift (F .fmor (𝒞CP.in₁ 𝒞.∘ stb .StableBits.h₁)))
-              (lift (F .fmor (𝒞CP.in₂ 𝒞.∘ stb .StableBits.h₂)))
-              (stb .StableBits.h)
-              (leaf (inj₁ (lift (F .fmor (stb .StableBits.h₁)) , lift (stb .StableBits.h₁ , 𝒟.≈-refl) , lift (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl 𝒟.id-right) (𝒟.≈-sym (F .fmor-comp _ _))))))
-              (leaf (inj₂ (lift (F .fmor (stb .StableBits.h₂)) , lift (stb .StableBits.h₂ , 𝒟.≈-refl) , lift (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl 𝒟.id-right) (𝒟.≈-sym (F .fmor-comp _ _))))))
-              (lift eq₁)
-              (lift eq₂))
-  where stb = stable 𝒞.Iso-refl f
-        open 𝒞.Iso
+Definable-coproducts {x} {y} .*⊑* z .*⊑* (lift g) (lift (f , eq)) =
+  node (pb .CoverPullback.cover) xs ts eqs
+  where
+    c₀ : BinCover (𝒞CP.coprod x y)
+    c₀ .BinCover.y₁ = x
+    c₀ .BinCover.y₂ = y
+    c₀ .BinCover.iso = 𝒞.Iso-refl
 
-        eq₁ : F .fmor (𝒞CP.in₁ 𝒞.∘ stb .StableBits.h₁) 𝒟.≈ (g 𝒟.∘ F .fmor (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁))
-        eq₁ = begin
-            F .fmor (𝒞CP.in₁ 𝒞.∘ stb .StableBits.h₁)
-          ≈˘⟨ F .fmor-cong 𝒞.id-left ⟩
-            F .fmor (𝒞.id _ 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stb .StableBits.h₁))
-          ≈⟨ F .fmor-cong (stb .StableBits.eq₁) ⟩
-            F .fmor (f 𝒞.∘ (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁))
-          ≈⟨ F .fmor-comp _ _ ⟩
-            F .fmor f 𝒟.∘ F .fmor (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁)
-          ≈⟨ 𝒟.∘-cong eq 𝒟.≈-refl ⟩
-            g 𝒟.∘ F .fmor (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁)
-          ∎
-          where open ≈-Reasoning 𝒟.isEquiv
+    pb = covPull (bin c₀) f
 
-        eq₂ : F .fmor (𝒞CP.in₂ 𝒞.∘ stb .StableBits.h₂) 𝒟.≈ (g 𝒟.∘ F .fmor (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂))
-        eq₂ = begin
-            F .fmor (𝒞CP.in₂ 𝒞.∘ stb .StableBits.h₂)
-          ≈˘⟨ F .fmor-cong 𝒞.id-left ⟩
-            F .fmor (𝒞.id _ 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stb .StableBits.h₂))
-          ≈⟨ F .fmor-cong (stb .StableBits.eq₂) ⟩
-            F .fmor (f 𝒞.∘ (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂))
-          ≈⟨ F .fmor-comp _ _ ⟩
-            F .fmor f 𝒟.∘ F .fmor (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂)
-          ≈⟨ 𝒟.∘-cong eq 𝒟.≈-refl ⟩
-            g 𝒟.∘ F .fmor (stb .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂)
-          ∎
-          where open ≈-Reasoning 𝒟.isEquiv
+    h₁ = pb .CoverPullback.leg inl
+    h₂ = pb .CoverPullback.leg inr
+
+    xs : ∀ s → Setoid.Carrier (G .fobj (F .fobj (𝒞CP.coprod x y)) .fobj (cDom (pb .CoverPullback.cover) s))
+    xs inl = lift (F .fmor (𝒞CP.in₁ 𝒞.∘ h₁))
+    xs inr = lift (F .fmor (𝒞CP.in₂ 𝒞.∘ h₂))
+
+    step : ∀ s → (cInj (bin c₀) s 𝒞.∘ pb .CoverPullback.leg s) 𝒞.≈ (f 𝒞.∘ cInj (pb .CoverPullback.cover) s)
+    step = pb .CoverPullback.eq
+
+    -- The summand restriction agrees with the reindexed witness.
+    eq' : ∀ s → F .fmor (cInj (bin c₀) s 𝒞.∘ pb .CoverPullback.leg s) 𝒟.≈ (g 𝒟.∘ F .fmor (cInj (pb .CoverPullback.cover) s))
+    eq' s = begin
+        F .fmor (cInj (bin c₀) s 𝒞.∘ pb .CoverPullback.leg s)
+      ≈⟨ F .fmor-cong (step s) ⟩
+        F .fmor (f 𝒞.∘ cInj (pb .CoverPullback.cover) s)
+      ≈⟨ F .fmor-comp _ _ ⟩
+        F .fmor f 𝒟.∘ F .fmor (cInj (pb .CoverPullback.cover) s)
+      ≈⟨ 𝒟.∘-cong eq 𝒟.≈-refl ⟩
+        g 𝒟.∘ F .fmor (cInj (pb .CoverPullback.cover) s)
+      ∎
+      where open ≈-Reasoning 𝒟.isEquiv
+
+    -- inl/inr injections differ from cInj (bin c₀) only by the identity iso.
+    inj₁≈ : F .fmor (𝒞CP.in₁ 𝒞.∘ h₁) 𝒟.≈ F .fmor (cInj (bin c₀) inl 𝒞.∘ h₁)
+    inj₁≈ = F .fmor-cong (𝒞.∘-cong (𝒞.≈-sym 𝒞.id-left) 𝒞.≈-refl)
+
+    inj₂≈ : F .fmor (𝒞CP.in₂ 𝒞.∘ h₂) 𝒟.≈ F .fmor (cInj (bin c₀) inr 𝒞.∘ h₂)
+    inj₂≈ = F .fmor-cong (𝒞.∘-cong (𝒞.≈-sym 𝒞.id-left) 𝒞.≈-refl)
+
+    ts : ∀ s → Context (G .fobj (F .fobj (𝒞CP.coprod x y)))
+                 ((Definable x ⟨ G .fmor (F .fmor 𝒞CP.in₁) ⟩) ++ (Definable y ⟨ G .fmor (F .fmor 𝒞CP.in₂) ⟩))
+                 (cDom (pb .CoverPullback.cover) s) (xs s)
+    ts inl = leaf (inj₁ (lift (F .fmor h₁) , lift (h₁ , 𝒟.≈-refl) ,
+                         lift (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl 𝒟.id-right) (𝒟.≈-sym (F .fmor-comp _ _)))))
+    ts inr = leaf (inj₂ (lift (F .fmor h₂) , lift (h₂ , 𝒟.≈-refl) ,
+                         lift (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl 𝒟.id-right) (𝒟.≈-sym (F .fmor-comp _ _)))))
+
+    eqs : ∀ s → Setoid._≈_ (G .fobj (F .fobj (𝒞CP.coprod x y)) .fobj (cDom (pb .CoverPullback.cover) s))
+                  (xs s)
+                  (G .fobj (F .fobj (𝒞CP.coprod x y)) .fmor (cInj (pb .CoverPullback.cover) s) .prop-setoid._⇒_.func (lift g))
+    eqs inl = lift (𝒟.≈-trans inj₁≈ (eq' inl))
+    eqs inr = lift (𝒟.≈-trans inj₂≈ (eq' inr))
+
+-- Set-indexed form.
+Definable-coproducts-indexed : ∀ {S : Setoid 0ℓ 0ℓ} {D : Functor (setoid→category S) 𝒞} →
+                               Definable (SI.∐ S D) ⊑
+                               𝐂 (⋁ (S .Setoid.Carrier) (λ s → Definable (D .fobj s) ⟨ G .fmor (F .fmor (SI.inj D s)) ⟩))
+Definable-coproducts-indexed {S} {D} .*⊑* z .*⊑* (lift g) (lift (f , eq)) =
+  node (pb .CoverPullback.cover) xs ts eqs
+  where
+    c₀ : IdxCover (SI.∐ S D)
+    c₀ .IdxCover.S = S
+    c₀ .IdxCover.D = D
+    c₀ .IdxCover.iso = 𝒞.Iso-refl
+
+    pb = covPull (idx c₀) f
+
+    xs : ∀ s → Setoid.Carrier (G .fobj (F .fobj (SI.∐ S D)) .fobj (cDom (pb .CoverPullback.cover) s))
+    xs (lift s) = lift (F .fmor (SI.inj D s 𝒞.∘ pb .CoverPullback.leg (lift s)))
+
+    -- The summand restriction agrees with the reindexed witness.
+    eq' : ∀ s → F .fmor (cInj (idx c₀) s 𝒞.∘ pb .CoverPullback.leg s) 𝒟.≈ (g 𝒟.∘ F .fmor (cInj (pb .CoverPullback.cover) s))
+    eq' s = begin
+        F .fmor (cInj (idx c₀) s 𝒞.∘ pb .CoverPullback.leg s)
+      ≈⟨ F .fmor-cong (pb .CoverPullback.eq s) ⟩
+        F .fmor (f 𝒞.∘ cInj (pb .CoverPullback.cover) s)
+      ≈⟨ F .fmor-comp _ _ ⟩
+        F .fmor f 𝒟.∘ F .fmor (cInj (pb .CoverPullback.cover) s)
+      ≈⟨ 𝒟.∘-cong eq 𝒟.≈-refl ⟩
+        g 𝒟.∘ F .fmor (cInj (pb .CoverPullback.cover) s)
+      ∎
+      where open ≈-Reasoning 𝒟.isEquiv
+
+    ts : ∀ s → Context (G .fobj (F .fobj (SI.∐ S D)))
+                 (⋁ (S .Setoid.Carrier) (λ s → Definable (D .fobj s) ⟨ G .fmor (F .fmor (SI.inj D s)) ⟩))
+                 (cDom (pb .CoverPullback.cover) s) (xs s)
+    ts (lift s) = leaf (s , (lift (F .fmor (pb .CoverPullback.leg (lift s))) , lift (pb .CoverPullback.leg (lift s) , 𝒟.≈-refl) ,
+                        lift (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl 𝒟.id-right) (𝒟.≈-sym (F .fmor-comp _ _)))))
+
+    eqs : ∀ s → Setoid._≈_ (G .fobj (F .fobj (SI.∐ S D)) .fobj (cDom (pb .CoverPullback.cover) s))
+                  (xs s)
+                  (G .fobj (F .fobj (SI.∐ S D)) .fmor (cInj (pb .CoverPullback.cover) s) .prop-setoid._⇒_.func (lift g))
+    eqs (lift s) = lift (𝒟.≈-trans (F .fmor-cong (𝒞.∘-cong (𝒞.≈-sym 𝒞.id-left) 𝒞.≈-refl)) (eq' (lift s)))
 
 open FunctorPred
 open MonadPred
@@ -458,40 +684,41 @@ Definable-closed : ∀ {X Y} (f : F .fobj X 𝒟.⇒ F .fobj Y) →
        Context (G .fobj (F .fobj Y)) (Definable Y) X (lift f) →
        ∃ (X 𝒞.⇒ Y) (λ g → F .fmor g 𝒟.≈ f)
 Definable-closed f (leaf (lift p)) = p
-Definable-closed f (node X₁ X₂ (lift f₁) (lift f₂) g t₁ t₂ (lift eq₁) (lift eq₂)) with Definable-closed f₁ t₁
+Definable-closed f (node (bin c) xs ts eqs) with xs inl | xs inr | eqs inl | eqs inr | ts inl | ts inr
+... | lift f₁ | lift f₂ | lift eq₁ | lift eq₂ | t₁ | t₂ with Definable-closed f₁ t₁
 ... | (g₁ , eq₃) with Definable-closed f₂ t₂
-... | (g₂ , eq₄) = 𝒞CP.copair g₁ g₂ 𝒞.∘ g .bwd ,
+... | (g₂ , eq₄) = 𝒞CP.copair g₁ g₂ 𝒞.∘ i₀ .bwd ,
       (begin
-        F .fmor (𝒞CP.copair g₁ g₂ 𝒞.∘ g .bwd)
+        F .fmor (𝒞CP.copair g₁ g₂ 𝒞.∘ i₀ .bwd)
       ≈⟨ F .fmor-comp _ _ ⟩
-        F .fmor (𝒞CP.copair g₁ g₂) 𝒟.∘ F .fmor (g .bwd)
+        F .fmor (𝒞CP.copair g₁ g₂) 𝒟.∘ F .fmor (i₀ .bwd)
       ≈˘⟨ 𝒟.∘-cong F-copair 𝒟.≈-refl ⟩
-        (𝒟CP.copair (F .fmor g₁) (F .fmor g₂) 𝒟.∘ mul) 𝒟.∘ F .fmor (g .bwd)
+        (𝒟CP.copair (F .fmor g₁) (F .fmor g₂) 𝒟.∘ mul) 𝒟.∘ F .fmor (i₀ .bwd)
       ≈⟨ 𝒟.assoc _ _ _ ⟩
-        𝒟CP.copair (F .fmor g₁) (F .fmor g₂) 𝒟.∘ (mul 𝒟.∘ F .fmor (g .bwd))
+        𝒟CP.copair (F .fmor g₁) (F .fmor g₂) 𝒟.∘ (mul 𝒟.∘ F .fmor (i₀ .bwd))
       ≈⟨ 𝒟.∘-cong (𝒟CP.copair-cong eq₃ eq₄) 𝒟.≈-refl ⟩
-        𝒟CP.copair f₁ f₂ 𝒟.∘ (mul 𝒟.∘ F .fmor (g .bwd))
+        𝒟CP.copair f₁ f₂ 𝒟.∘ (mul 𝒟.∘ F .fmor (i₀ .bwd))
       ≈⟨ 𝒟.∘-cong (𝒟CP.copair-cong eq₁ eq₂ ) 𝒟.≈-refl ⟩
-        𝒟CP.copair (f 𝒟.∘ F .fmor (g .fwd 𝒞.∘ 𝒞CP.in₁)) (f 𝒟.∘ F .fmor (g .fwd 𝒞.∘ 𝒞CP.in₂)) 𝒟.∘ (mul 𝒟.∘ F .fmor (g .bwd))
+        𝒟CP.copair (f 𝒟.∘ F .fmor (i₀ .fwd 𝒞.∘ 𝒞CP.in₁)) (f 𝒟.∘ F .fmor (i₀ .fwd 𝒞.∘ 𝒞CP.in₂)) 𝒟.∘ (mul 𝒟.∘ F .fmor (i₀ .bwd))
       ≈⟨ 𝒟.∘-cong (𝒟CP.copair-cong (𝒟.∘-cong 𝒟.≈-refl (F .fmor-comp _ _)) (𝒟.∘-cong 𝒟.≈-refl (F .fmor-comp _ _))) 𝒟.≈-refl ⟩
-        𝒟CP.copair (f 𝒟.∘ (F .fmor (g .fwd) 𝒟.∘ F .fmor 𝒞CP.in₁)) (f 𝒟.∘ (F .fmor (g .fwd) 𝒟.∘ F .fmor 𝒞CP.in₂)) 𝒟.∘ (mul 𝒟.∘ F .fmor (g .bwd))
+        𝒟CP.copair (f 𝒟.∘ (F .fmor (i₀ .fwd) 𝒟.∘ F .fmor 𝒞CP.in₁)) (f 𝒟.∘ (F .fmor (i₀ .fwd) 𝒟.∘ F .fmor 𝒞CP.in₂)) 𝒟.∘ (mul 𝒟.∘ F .fmor (i₀ .bwd))
       ≈˘⟨ 𝒟.∘-cong (𝒟CP.copair-cong (𝒟.assoc _ _ _) (𝒟.assoc _ _ _)) 𝒟.≈-refl ⟩
-        𝒟CP.copair ((f 𝒟.∘ F .fmor (g .fwd)) 𝒟.∘ F .fmor 𝒞CP.in₁) ((f 𝒟.∘ F .fmor (g .fwd)) 𝒟.∘ F .fmor 𝒞CP.in₂) 𝒟.∘ (mul 𝒟.∘ F .fmor (g .bwd))
+        𝒟CP.copair ((f 𝒟.∘ F .fmor (i₀ .fwd)) 𝒟.∘ F .fmor 𝒞CP.in₁) ((f 𝒟.∘ F .fmor (i₀ .fwd)) 𝒟.∘ F .fmor 𝒞CP.in₂) 𝒟.∘ (mul 𝒟.∘ F .fmor (i₀ .bwd))
       ≈˘⟨ 𝒟.∘-cong (𝒟CP.copair-natural _ _ _) 𝒟.≈-refl ⟩
-        ((f 𝒟.∘ F .fmor (g .fwd)) 𝒟.∘ 𝒟CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒟.∘ (mul 𝒟.∘ F .fmor (g .bwd))
+        ((f 𝒟.∘ F .fmor (i₀ .fwd)) 𝒟.∘ 𝒟CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒟.∘ (mul 𝒟.∘ F .fmor (i₀ .bwd))
       ≈⟨ 𝒟.assoc _ _ _ ⟩
-        (f 𝒟.∘ F .fmor (g .fwd)) 𝒟.∘ (𝒟CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒟.∘ (mul 𝒟.∘ F .fmor (g .bwd)))
+        (f 𝒟.∘ F .fmor (i₀ .fwd)) 𝒟.∘ (𝒟CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒟.∘ (mul 𝒟.∘ F .fmor (i₀ .bwd)))
       ≈˘⟨ 𝒟.∘-cong 𝒟.≈-refl (𝒟.assoc _ _ _) ⟩
-        (f 𝒟.∘ F .fmor (g .fwd)) 𝒟.∘ ((𝒟CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒟.∘ mul) 𝒟.∘ F .fmor (g .bwd))
+        (f 𝒟.∘ F .fmor (i₀ .fwd)) 𝒟.∘ ((𝒟CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒟.∘ mul) 𝒟.∘ F .fmor (i₀ .bwd))
       ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (𝒟.∘-cong (Category.IsIso.f∘inverse≈id FC) 𝒟.≈-refl) ⟩
-        (f 𝒟.∘ F .fmor (g .fwd)) 𝒟.∘ (𝒟.id _ 𝒟.∘ F .fmor (g .bwd))
+        (f 𝒟.∘ F .fmor (i₀ .fwd)) 𝒟.∘ (𝒟.id _ 𝒟.∘ F .fmor (i₀ .bwd))
       ≈⟨ 𝒟.∘-cong 𝒟.≈-refl 𝒟.id-left ⟩
-        (f 𝒟.∘ F .fmor (g .fwd)) 𝒟.∘ F .fmor (g .bwd)
+        (f 𝒟.∘ F .fmor (i₀ .fwd)) 𝒟.∘ F .fmor (i₀ .bwd)
       ≈⟨ 𝒟.assoc _ _ _ ⟩
-        f 𝒟.∘ (F .fmor (g .fwd) 𝒟.∘ F .fmor (g .bwd))
+        f 𝒟.∘ (F .fmor (i₀ .fwd) 𝒟.∘ F .fmor (i₀ .bwd))
       ≈˘⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-comp _ _) ⟩
-        f 𝒟.∘ F .fmor (g .fwd 𝒞.∘ g .bwd)
-      ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-cong (g .fwd∘bwd≈id)) ⟩
+        f 𝒟.∘ F .fmor (i₀ .fwd 𝒞.∘ i₀ .bwd)
+      ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-cong (i₀ .fwd∘bwd≈id)) ⟩
         f 𝒟.∘ F .fmor (𝒞.id _)
       ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-id) ⟩
         f 𝒟.∘ 𝒟.id _
@@ -499,8 +726,149 @@ Definable-closed f (node X₁ X₂ (lift f₁) (lift f₂) g t₁ t₂ (lift eq
         f
       ∎)
   where open ≈-Reasoning 𝒟.isEquiv
+        i₀ = c .BinCover.iso
         open preserve-chosen-coproducts-consequences F 𝒞CP 𝒟CP FC
         open 𝒞.Iso
+Definable-closed {X} {Y} f (node (idx c) xs ts eqs) = g , Fg≈f
+  where
+    open NatTrans
+    open ≃-NatTrans
+    S = c .IdxCover.S
+    D = c .IdxCover.D
+    iso = c .IdxCover.iso
+    module DC = Colimit (𝒞DC S D)
+
+    inj : (s : S .Setoid.Carrier) → D .fobj s 𝒞.⇒ DC.apex
+    inj s = DC.cocone .transf s
+
+    fs : (s : S .Setoid.Carrier) → F .fobj (D .fobj s) 𝒟.⇒ F .fobj Y
+    fs s = lower (xs (lift s))
+
+    fs-eq : (s : S .Setoid.Carrier) → fs s 𝒟.≈ (f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd 𝒞.∘ inj s))
+    fs-eq s = lower (eqs (lift s))
+
+    -- The summand restrictions are definable; pick their witnesses uniformly.
+    gs : (s : S .Setoid.Carrier) → D .fobj s 𝒞.⇒ Y
+    gs s = ∃ₛ.fst (Fdef (fs s) ⟪ Definable-closed (fs s) (ts (lift s)) ⟫)
+
+    Fgs : (s : S .Setoid.Carrier) → F .fmor (gs s) 𝒟.≈ fs s
+    Fgs s = ∃ₛ.snd (Fdef (fs s) ⟪ Definable-closed (fs s) (ts (lift s)) ⟫)
+
+    -- The witnesses form a cocone, faithfulness reflecting the naturality
+    -- squares that hold after applying F.
+    gs-cocone : NatTrans D (constF (setoid→category S) Y)
+    gs-cocone .transf = gs
+    gs-cocone .natural {s} {s'} ⟪ e ⟫ = 𝒞.≈-trans 𝒞.id-left (𝒞.≈-sym (F-faithful faith))
+      where
+        faith : F .fmor (gs s' 𝒞.∘ D .fmor ⟪ e ⟫) 𝒟.≈ F .fmor (gs s)
+        faith = begin
+            F .fmor (gs s' 𝒞.∘ D .fmor ⟪ e ⟫)
+          ≈⟨ F .fmor-comp _ _ ⟩
+            F .fmor (gs s') 𝒟.∘ F .fmor (D .fmor ⟪ e ⟫)
+          ≈⟨ 𝒟.∘-cong (Fgs s') 𝒟.≈-refl ⟩
+            fs s' 𝒟.∘ F .fmor (D .fmor ⟪ e ⟫)
+          ≈⟨ 𝒟.∘-cong (fs-eq s') 𝒟.≈-refl ⟩
+            (f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd 𝒞.∘ inj s')) 𝒟.∘ F .fmor (D .fmor ⟪ e ⟫)
+          ≈⟨ 𝒟.assoc _ _ _ ⟩
+            f 𝒟.∘ (F .fmor (iso .𝒞.Iso.fwd 𝒞.∘ inj s') 𝒟.∘ F .fmor (D .fmor ⟪ e ⟫))
+          ≈˘⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-comp _ _) ⟩
+            f 𝒟.∘ F .fmor ((iso .𝒞.Iso.fwd 𝒞.∘ inj s') 𝒞.∘ D .fmor ⟪ e ⟫)
+          ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-cong (𝒞.assoc _ _ _)) ⟩
+            f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd 𝒞.∘ (inj s' 𝒞.∘ D .fmor ⟪ e ⟫))
+          ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-cong (𝒞.∘-cong 𝒞.≈-refl (𝒞.≈-trans (𝒞.≈-sym (DC.cocone .natural ⟪ e ⟫)) 𝒞.id-left))) ⟩
+            f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd 𝒞.∘ inj s)
+          ≈˘⟨ fs-eq s ⟩
+            fs s
+          ≈˘⟨ Fgs s ⟩
+            F .fmor (gs s)
+          ∎
+          where open ≈-Reasoning 𝒟.isEquiv
+
+    g₀ : DC.apex 𝒞.⇒ Y
+    g₀ = DC.colambda Y gs-cocone
+
+    g : X 𝒞.⇒ Y
+    g = g₀ 𝒞.∘ iso .𝒞.Iso.bwd
+
+    -- F takes the injections to a jointly-epic family (F preserves the
+    -- coproduct), so agreement on injections gives equality.
+    module DCF = Colimit (𝒟DC S (F ∘F D))
+    Fiso    = ∃ₛ.fst (F-DC S D)
+    Fcompat = ∃ₛ.snd (F-DC S D)
+
+    F-epi : ∀ {Z} {h₁ h₂ : F .fobj DC.apex 𝒟.⇒ Z} →
+            (∀ s → (h₁ 𝒟.∘ F .fmor (inj s)) 𝒟.≈ (h₂ 𝒟.∘ F .fmor (inj s))) → h₁ 𝒟.≈ h₂
+    F-epi {Z} {h₁} {h₂} hyp = outer
+      where
+        uni : ∀ s → ((h₁ 𝒟.∘ Fiso .𝒟.Iso.fwd) 𝒟.∘ DCF.cocone .transf s)
+                    𝒟.≈ ((h₂ 𝒟.∘ Fiso .𝒟.Iso.fwd) 𝒟.∘ DCF.cocone .transf s)
+        uni s = begin
+            (h₁ 𝒟.∘ Fiso .𝒟.Iso.fwd) 𝒟.∘ DCF.cocone .transf s
+          ≈⟨ 𝒟.assoc _ _ _ ⟩
+            h₁ 𝒟.∘ (Fiso .𝒟.Iso.fwd 𝒟.∘ DCF.cocone .transf s)
+          ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (Fcompat s) ⟩
+            h₁ 𝒟.∘ F .fmor (inj s)
+          ≈⟨ hyp s ⟩
+            h₂ 𝒟.∘ F .fmor (inj s)
+          ≈˘⟨ 𝒟.∘-cong 𝒟.≈-refl (Fcompat s) ⟩
+            h₂ 𝒟.∘ (Fiso .𝒟.Iso.fwd 𝒟.∘ DCF.cocone .transf s)
+          ≈˘⟨ 𝒟.assoc _ _ _ ⟩
+            (h₂ 𝒟.∘ Fiso .𝒟.Iso.fwd) 𝒟.∘ DCF.cocone .transf s
+          ∎
+          where open ≈-Reasoning 𝒟.isEquiv
+
+        outer : h₁ 𝒟.≈ h₂
+        outer = begin
+            h₁
+          ≈˘⟨ 𝒟.id-right ⟩
+            h₁ 𝒟.∘ 𝒟.id _
+          ≈˘⟨ 𝒟.∘-cong 𝒟.≈-refl (Fiso .𝒟.Iso.fwd∘bwd≈id) ⟩
+            h₁ 𝒟.∘ (Fiso .𝒟.Iso.fwd 𝒟.∘ Fiso .𝒟.Iso.bwd)
+          ≈˘⟨ 𝒟.assoc _ _ _ ⟩
+            (h₁ 𝒟.∘ Fiso .𝒟.Iso.fwd) 𝒟.∘ Fiso .𝒟.Iso.bwd
+          ≈⟨ 𝒟.∘-cong (colambda-unique (DCF.isColimit) uni) 𝒟.≈-refl ⟩
+            (h₂ 𝒟.∘ Fiso .𝒟.Iso.fwd) 𝒟.∘ Fiso .𝒟.Iso.bwd
+          ≈⟨ 𝒟.assoc _ _ _ ⟩
+            h₂ 𝒟.∘ (Fiso .𝒟.Iso.fwd 𝒟.∘ Fiso .𝒟.Iso.bwd)
+          ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (Fiso .𝒟.Iso.fwd∘bwd≈id) ⟩
+            h₂ 𝒟.∘ 𝒟.id _
+          ≈⟨ 𝒟.id-right ⟩
+            h₂
+          ∎
+          where open ≈-Reasoning 𝒟.isEquiv
+
+    Fg₀ : F .fmor g₀ 𝒟.≈ (f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd))
+    Fg₀ = F-epi coeval-step
+      where
+        coeval-step : ∀ s → (F .fmor g₀ 𝒟.∘ F .fmor (inj s))
+                            𝒟.≈ ((f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd)) 𝒟.∘ F .fmor (inj s))
+        coeval-step s =
+          𝒟.≈-trans (𝒟.≈-sym (F .fmor-comp g₀ (inj s)))
+          (𝒟.≈-trans (F .fmor-cong (DC.colambda-coeval Y gs-cocone .transf-eq s))
+          (𝒟.≈-trans (Fgs s)
+          (𝒟.≈-trans (fs-eq s)
+          (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl (F .fmor-comp (iso .𝒞.Iso.fwd) (inj s)))
+                     (𝒟.≈-sym (𝒟.assoc _ _ _))))))
+
+    Fg≈f : F .fmor g 𝒟.≈ f
+    Fg≈f = begin
+        F .fmor (g₀ 𝒞.∘ iso .𝒞.Iso.bwd)
+      ≈⟨ F .fmor-comp _ _ ⟩
+        F .fmor g₀ 𝒟.∘ F .fmor (iso .𝒞.Iso.bwd)
+      ≈⟨ 𝒟.∘-cong Fg₀ 𝒟.≈-refl ⟩
+        (f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd)) 𝒟.∘ F .fmor (iso .𝒞.Iso.bwd)
+      ≈⟨ 𝒟.assoc _ _ _ ⟩
+        f 𝒟.∘ (F .fmor (iso .𝒞.Iso.fwd) 𝒟.∘ F .fmor (iso .𝒞.Iso.bwd))
+      ≈˘⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-comp _ _) ⟩
+        f 𝒟.∘ F .fmor (iso .𝒞.Iso.fwd 𝒞.∘ iso .𝒞.Iso.bwd)
+      ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-cong (iso .𝒞.Iso.fwd∘bwd≈id)) ⟩
+        f 𝒟.∘ F .fmor (𝒞.id _)
+      ≈⟨ 𝒟.∘-cong 𝒟.≈-refl (F .fmor-id) ⟩
+        f 𝒟.∘ 𝒟.id _
+      ≈⟨ 𝒟.id-right ⟩
+        f
+      ∎
+      where open ≈-Reasoning 𝒟.isEquiv
 
 ------------------------------------------------------------------------------
 -- Now construct the category of Grothendieck Logical Relations
@@ -508,7 +876,7 @@ Definable-closed f (node X₁ X₂ (lift f₁) (lift f₂) g t₁ t₂ (lift eq
 open import closure-predicate PSh⟨𝒞⟩-system closureOp
   using (system; embed; module 𝐂Monad)
 
-open 𝐂Monad _ MP (distrib _ FM-C)
+open 𝐂Monad _ MP (MDistrib.distrib FMpull)
 
 module Gl = glueing-simple 𝒟 PSh⟨𝒞⟩ _ system G
 
@@ -527,6 +895,25 @@ open import lists Gl.cat GlPE.terminal GlPE.products GlPE.exponentials GDC
   using ()
   renaming (lists to Gl-lists)
 
+-- Poly-types for the glued category, realised from the μ-types of Fam(Gl).
+GlSC : HasStrongCoproducts Gl.cat GlPE.products
+GlSC = ccc→strong-coproducts GlCP.coproducts GlPE.exponentials
+
+abstract
+  Gl-Mu : polynomial-functor.Interp.HasMu GlPE.terminal GlPE.products GlSC
+  Gl-Mu = fam-mu-realisation.Muℰ 0ℓ 0ℓ GDC GlPE.terminal GlPE.products GlPE.exponentials GlSC
+
+  Gl-MuLaws : polynomial-functor.Interp.HasMuLaws GlPE.terminal GlPE.products GlSC Gl-Mu
+  Gl-MuLaws = fam-mu-realisation.MuLawsℰ 0ℓ 0ℓ GDC GlPE.terminal GlPE.products GlPE.exponentials GlSC
+
+  -- Expose the μ-objects behind the abstraction: they are the realised
+  -- μ-objects of the construction above.
+  Gl-Mu-obj : ∀ {n} (Q : polynomial-functor.Poly Gl.cat (Data.Nat.suc n))
+              (δ : Data.Fin.Fin n → Category.obj Gl.cat) →
+              polynomial-functor.Interp.HasMu.μ-obj Gl-Mu Q δ ≡
+              fam-mu-realisation.μ-objℰ 0ℓ 0ℓ GDC GlPE.terminal GlPE.products GlPE.exponentials GlSC Q δ
+  Gl-Mu-obj Q δ = ≡-refl
+
 module Glued = Category Gl.cat
 open Gl.Obj
 open Gl._=>_
@@ -633,6 +1020,116 @@ GF-preserve-coproducts .Category.IsIso.inverse = presv-cp
 GF-preserve-coproducts .Category.IsIso.f∘inverse≈id .f≃f = Category.IsIso.f∘inverse≈id FC
 GF-preserve-coproducts .Category.IsIso.inverse∘f≈id .f≃f = Category.IsIso.inverse∘f≈id FC
 
+-- GF preserves set-indexed coproducts: carrier by F-DC, predicate by
+-- Definable-coproducts-indexed. The set-indexed twin of GF-preserve-coproducts.
+GF-preserve-coproducts-indexed : ∀ (S : Setoid 0ℓ 0ℓ) (D : Functor (setoid→category S) 𝒞) →
+  Glued.Iso (GDC S (GF ∘F D) .Colimit.apex) (GF .fobj (SI.∐ S D))
+GF-preserve-coproducts-indexed S D = iso
+  where
+    module FI = ∃ₛ (F-DC S D)
+
+    -- project ∘F GF and F agree on objects and morphisms, but not as no-eta
+    -- functor records, so the Gl coproduct's carrier 𝒟DC S (project ∘F GF ∘F D)
+    -- is bridged to F-DC's 𝒟DC S (F ∘F D) by the identity natural iso.
+    D-eq : NatIso (Gl.project ∘F (GF ∘F D)) (F ∘F D)
+    D-eq .NatIso.transform .transf s = 𝒟.id _
+    D-eq .NatIso.transform .natural {s} {s'} _ = 𝒟.≈-trans 𝒟.id-right (𝒟.≈-sym 𝒟.id-left)
+    D-eq .NatIso.transf-iso s .Category.IsIso.inverse = 𝒟.id _
+    D-eq .NatIso.transf-iso s .Category.IsIso.f∘inverse≈id = 𝒟.id-left
+    D-eq .NatIso.transf-iso s .Category.IsIso.inverse∘f≈id = 𝒟.id-left
+
+    carrierIso = 𝒟.Iso-trans (𝒟d.∐-iso D-eq) FI.fst
+
+    -- Under the coproduct comparison each 𝒞-injection maps to the Gl carrier's
+    -- colimit injection: F-DC's compat, then the D-eq bridge.
+    F-inⱼ : ∀ s → (carrierIso .Category.Iso.bwd 𝒟.∘ F .fmor (SI.inj D s)) 𝒟.≈
+                  (GDC S (GF ∘F D) .Colimit.cocone .transf s .morph)
+    F-inⱼ s =
+      𝒟.≈-trans (𝒟.assoc _ _ _)
+        (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl bwd-inj)
+          (𝒟.≈-trans (𝒟d.∐-map-coeval (NatIso.transform⁻¹ D-eq) s) 𝒟.id-right))
+      where
+        bwd-inj : (FI.fst .Category.Iso.bwd 𝒟.∘ F .fmor (SI.inj D s)) 𝒟.≈
+                  (𝒟DC S (F ∘F D) .Colimit.cocone .transf s)
+        bwd-inj =
+          𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl (𝒟.≈-sym (FI.snd s)))
+            (𝒟.≈-trans (𝒟.≈-sym (𝒟.assoc _ _ _))
+              (𝒟.≈-trans (𝒟.∘-cong (FI.fst .Category.Iso.bwd∘fwd≈id) 𝒟.≈-refl) 𝒟.id-left))
+
+    iso : Glued.Iso (GDC S (GF ∘F D) .Colimit.apex) (GF .fobj (SI.∐ S D))
+    iso .Glued.Iso.fwd .morph = carrierIso .Category.Iso.fwd
+    iso .Glued.Iso.fwd .presv =
+      IsPreorder.trans ⊑-isPreorder
+        (𝐂-isClosure .IsClosureOp.mono (IsBigJoin.least PSh⟨𝒞⟩-system.⋁-isJoin _ _ _ per-s))
+        target-closed
+      where
+        ι : ∀ s → _
+        ι s = GDC S (GF ∘F D) .Colimit.cocone .transf s .morph
+
+        fwd-inⱼ : ∀ s → (carrierIso .Category.Iso.fwd 𝒟.∘ ι s) 𝒟.≈ F .fmor (SI.inj D s)
+        fwd-inⱼ s =
+          𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl (𝒟.≈-sym (F-inⱼ s)))
+            (𝒟.≈-trans (𝒟.≈-sym (𝒟.assoc _ _ _))
+              (𝒟.≈-trans (𝒟.∘-cong (carrierIso .Category.Iso.fwd∘bwd≈id) 𝒟.≈-refl) 𝒟.id-left))
+
+        target-closed :
+          𝐂 (𝐂 (Definable (SI.∐ S D)) [ G .fmor (carrierIso .Category.Iso.fwd) ]) ⊑
+          (𝐂 (Definable (SI.∐ S D)) [ G .fmor (carrierIso .Category.Iso.fwd) ])
+        target-closed =
+          IsPreorder.trans ⊑-isPreorder 𝐂-[]
+            (𝐂-isClosure .IsClosureOp.closed PSh⟨𝒞⟩-system.[ _ ]m)
+
+        inner-s : ∀ s →
+          𝐂 (Definable (D .fobj s)) ⟨ G .fmor (ι s) ⟩ ⊑
+          (𝐂 (Definable (SI.∐ S D)) [ G .fmor (carrierIso .Category.Iso.fwd) ])
+        inner-s s =
+          PSh⟨𝒞⟩-system.adjoint₂
+            (IsPreorder.trans ⊑-isPreorder (GF .fmor (SI.inj D s) .presv)
+              (IsPreorder.trans ⊑-isPreorder
+                (PSh⟨𝒞⟩-system.[]-cong (G .fmor-cong (𝒟.≈-sym (fwd-inⱼ s))))
+                (IsPreorder.trans ⊑-isPreorder
+                  (PSh⟨𝒞⟩-system.[]-cong (G .fmor-comp _ _))
+                  (PSh⟨𝒞⟩-system.[]-comp⁻¹ _ _))))
+
+        per-s : ∀ s →
+          𝐂 (𝐂 (Definable (D .fobj s)) ⟨ G .fmor (ι s) ⟩) ⊑
+          (𝐂 (Definable (SI.∐ S D)) [ G .fmor (carrierIso .Category.Iso.fwd) ])
+        per-s s =
+          IsPreorder.trans ⊑-isPreorder
+            (𝐂-isClosure .IsClosureOp.mono (inner-s s))
+            target-closed
+    iso .Glued.Iso.bwd .morph = carrierIso .Category.Iso.bwd
+    iso .Glued.Iso.bwd .presv = begin
+        𝐂 (Definable (SI.∐ S D))
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono Definable-coproducts-indexed ⟩
+        𝐂 (𝐂 (⋁ (S .Setoid.Carrier) (λ s → Definable (D .fobj s) ⟨ G .fmor (F .fmor (SI.inj D s)) ⟩)))
+      ≤⟨ 𝐂-isClosure .IsClosureOp.closed ⟩
+        𝐂 (⋁ (S .Setoid.Carrier) (λ s → Definable (D .fobj s) ⟨ G .fmor (F .fmor (SI.inj D s)) ⟩))
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono
+           (IsBigJoin.mono PSh⟨𝒞⟩-system.⋁-isJoin (λ s → (𝐂-isClosure .IsClosureOp.unit) PSh⟨𝒞⟩-system.⟨ _ ⟩m)) ⟩
+        𝐂 (⋁ (S .Setoid.Carrier) (λ s → 𝐂 (Definable (D .fobj s)) ⟨ G .fmor (F .fmor (SI.inj D s)) ⟩))
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono (IsBigJoin.mono PSh⟨𝒞⟩-system.⋁-isJoin (λ s → 𝐂-isClosure .IsClosureOp.unit)) ⟩
+        _
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono (IsBigJoin.mono PSh⟨𝒞⟩-system.⋁-isJoin (λ s → 𝐂-isClosure .IsClosureOp.mono (PSh⟨𝒞⟩-system.unit _))) ⟩
+        _
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono (IsBigJoin.mono PSh⟨𝒞⟩-system.⋁-isJoin (λ s → 𝐂-isClosure .IsClosureOp.mono (PSh⟨𝒞⟩-system.⟨⟩-comp _ _ PSh⟨𝒞⟩-system.[ _ ]m))) ⟩
+        _
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono (IsBigJoin.mono PSh⟨𝒞⟩-system.⋁-isJoin (λ s → 𝐂-isClosure .IsClosureOp.mono (PSh⟨𝒞⟩-system.⟨⟩-cong (PSh⟨𝒞⟩.≈-sym (G .fmor-comp _ _)) PSh⟨𝒞⟩-system.[ _ ]m))) ⟩
+        _
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono (IsBigJoin.mono PSh⟨𝒞⟩-system.⋁-isJoin (λ s → 𝐂-isClosure .IsClosureOp.mono (PSh⟨𝒞⟩-system.⟨⟩-cong (G .fmor-cong (F-inⱼ s)) PSh⟨𝒞⟩-system.[ _ ]m))) ⟩
+        _
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono (IsBigJoin.mono PSh⟨𝒞⟩-system.⋁-isJoin (λ s → 𝐂-[])) ⟩
+        _
+      ≤⟨ 𝐂-isClosure .IsClosureOp.mono (IsBigJoin.least PSh⟨𝒞⟩-system.⋁-isJoin _ _ _ (λ s → (IsBigJoin.upper PSh⟨𝒞⟩-system.⋁-isJoin _ _ s) PSh⟨𝒞⟩-system.[ _ ]m)) ⟩
+        _
+      ≤⟨ 𝐂-[] ⟩
+        𝐂 (⋁ (S .Setoid.Carrier) (λ s → 𝐂 (𝐂 (Definable (D .fobj s)) ⟨ G .fmor (GDC S (GF ∘F D) .Colimit.cocone .transf s .morph) ⟩)))
+          [ G .fmor (carrierIso .Category.Iso.bwd) ]
+      ∎
+      where open ≤-Reasoning ⊑-isPreorder
+    iso .Glued.Iso.fwd∘bwd≈id .f≃f = carrierIso .Category.Iso.fwd∘bwd≈id
+    iso .Glued.Iso.bwd∘fwd≈id .f≃f = carrierIso .Category.Iso.bwd∘fwd≈id
+
 -- FIXME: If 𝒞 has exponentials, then GF preserves them as well.
 
 open preserve-monad
@@ -683,7 +1180,7 @@ GF-preserve-monad .iso .NatIso.transform .natural f .f≃f = FM.transform .natur
 GF-preserve-monad .iso .NatIso.transf-iso x .Category.IsIso.inverse .morph = FM.transform⁻¹ .transf x
 GF-preserve-monad .iso .NatIso.transf-iso x .Category.IsIso.inverse .presv = begin
     𝐂 (𝐂 (MP .liftF (𝐂 (Definable x))) ⟨ G-monad .transf (F .fobj x) ⟩)
-  ≤⟨ 𝐂-isClosure .IsClosureOp.mono (𝐂-isClosure .IsClosureOp.mono (distrib _ FM-C) PSh⟨𝒞⟩-system.⟨ _ ⟩m) ⟩
+  ≤⟨ 𝐂-isClosure .IsClosureOp.mono (𝐂-isClosure .IsClosureOp.mono (MDistrib.distrib FMpull) PSh⟨𝒞⟩-system.⟨ _ ⟩m) ⟩
     𝐂 (𝐂 (𝐂 (MP .liftF (Definable x))) ⟨ G-monad .transf (F .fobj x) ⟩)
   ≤⟨ 𝐂-isClosure .IsClosureOp.mono (𝐂-isClosure .IsClosureOp.closed PSh⟨𝒞⟩-system.⟨ _ ⟩m) ⟩
     𝐂 (𝐂 (MP .liftF (Definable x)) ⟨ G-monad .transf (F .fobj x) ⟩)
@@ -711,8 +1208,7 @@ GF-preserve-monad .preserve-join .f≃f = FM.preserve-join
 -- morphism in the GLR category whose domain and codomain are from
 -- 𝒞, then it is really a 𝒞 morphism.
 definability : ∀ {X Y} → (f : GF .fobj X Glued.⇒ GF .fobj Y) → ∃ (X 𝒞.⇒ Y) (λ g → F .fmor g 𝒟.≈ f .morph)
-definability {X} {Y} f with f .presv .*⊑* X .*⊑* (lift (F .fmor (𝒞.id _))) (liftS (leaf (lift (𝒞.id _ , 𝒟.≈-refl))))
-... | liftS t with Definable-closed _ t
+definability {X} {Y} f with Definable-closed _ (f .presv .*⊑* X .*⊑* (lift (F .fmor (𝒞.id _))) (leaf (lift (𝒞.id _ , 𝒟.≈-refl))))
 ... | g , eq = g , (begin
                       F .fmor g
                     ≈⟨ eq ⟩
@@ -725,3 +1221,38 @@ definability {X} {Y} f with f .presv .*⊑* X .*⊑* (lift (F .fmor (𝒞.id _))
                       f .morph
                     ∎)
     where open ≈-Reasoning 𝒟.isEquiv
+
+------------------------------------------------------------------------------
+-- The morphisms in the logical relations category that we are
+-- interested are the ones that come from interpretations of the
+-- language.
+
+module syntactic {ℓ}
+   (Sig : Signature ℓ)
+   (𝒞SC : HasStrongCoproducts 𝒞 𝒞P)
+   (𝒞Mu : polynomial-functor.Interp.HasMu 𝒞T 𝒞P 𝒞SC)
+   (GFC : preserve-chosen-coproducts GF (strong-coproducts→coproducts 𝒞T 𝒞SC)
+                                        (strong-coproducts→coproducts GlPE.terminal GlSC))
+   (GFμ : polynomial-functor.Preserves-μ 𝒞T 𝒞P 𝒞SC GlPE.terminal GlPE.products GlSC 𝒞Mu Gl-Mu GF)
+   (𝒞-Sig-Model : Model PFPC[ 𝒞 , 𝒞T , 𝒞P ,
+                   HasCoproducts.coprod (strong-coproducts→coproducts 𝒞T 𝒞SC)
+                     (𝒞T .HasTerminal.witness) (𝒞T .HasTerminal.witness) ] Sig)
+   where
+
+  open import language-syntax Sig using (_⊢_; first-order; first-order-ctxt)
+
+  open import language-fo-interpretation Sig
+         𝒞 𝒞T 𝒞P 𝒞SC 𝒞Mu
+         Gl.cat GlPE.terminal GlPE.products GlSC GlPE.exponentials Gl-Mu Gl-MuLaws
+         GF GF-preserve-terminal GF-preserve-products GFC GFμ
+         𝒞-Sig-Model
+    renaming (𝒟⟦_⟧ty to G⟦_⟧ty; 𝒟⟦_⟧ctxt to G⟦_⟧ctxt; 𝒟⟦_⟧tm to G⟦_⟧tm)
+
+  open Glued.Iso
+
+  syntactic-definability :
+    ∀ {Γ τ} (Γ-fo : first-order-ctxt Γ) (τ-fo : first-order τ) (M : Γ ⊢ τ) →
+    ∃ (𝒞⟦ Γ-fo ⟧ctxt 𝒞.⇒ 𝒞⟦ τ-fo ⟧ty (λ ())) λ g →
+      F .fmor g 𝒟.≈ (⟦ τ-fo ⟧-iso (λ ()) .bwd .morph 𝒟.∘ (G⟦ M ⟧tm .morph 𝒟.∘ ⟦ Γ-fo ⟧ctxt-iso .fwd .morph))
+  syntactic-definability Γ-fo τ-fo M =
+    definability (⟦ τ-fo ⟧-iso (λ ()) .bwd Glued.∘ (G⟦ M ⟧tm Glued.∘ ⟦ Γ-fo ⟧ctxt-iso .fwd))
diff --git a/agda/src/everything.agda b/agda/src/everything.agda
index 2fd028be..13d029b1 100644
--- a/agda/src/everything.agda
+++ b/agda/src/everything.agda
@@ -2,19 +2,29 @@
 
 module everything where
 
--- The examples of Section 5, one interpretation instance per semiring.
-import example.all
+-- Value-level tests of the examples: Boolean dependency, rational AD, and perturbation bounds,
+-- each a Primitives record with its model derived by interp-primitives. Renderings are tested by
+-- diffing generated dot files against committed baselines (graph-viz.dump-graphs, script/check-dot.sh).
+import test.all
 
--- Section 3 "Models of Semiring Dependency": Fam(C) is bicartesian closed when C has biproducts
--- and all small products (Lucatelli Nunes and Vákár 2023).
+-- Fam(C) is bicartesian closed when C has biproducts and all small products (Lucatelli Nunes and
+-- Vákár 2023).
 import fam-exponentials
 
--- The first-order models (Section 3): self-dual semimodules over a commutative semiring, and the
--- Boolean special case, self-dual Boolean algebras.
+-- The first-order model: self-dual semimodules over a commutative semiring, with the higher-order
+-- model over it and the interpretation of the primitives.
 import ho-model-sd-semimod
-import ho-model-boolalg-sd-semimod
 
--- Section 6 "Correctness of the Higher-Order Interpretation": the Fiore and Simpson 1999
--- definability theorem, in the conservativity module, gives agreement of the underlying function
--- with the Set interpretation at first order.
+-- The Fiore and Simpson 1999 definability theorem gives agreement of the underlying function with
+-- the Set interpretation at first order.
 import conservativity
+
+-- Polynomials over a category and their parameterised initial algebras; the
+-- action of a functor on polynomials, and the action of componentwise
+-- morphisms and isomorphisms on μ-objects.
+import polynomial-functor
+
+-- For the language with general recursive types: every first-order type's
+-- interpretation in the higher-order model is isomorphic to the image of its
+-- first-order interpretation.
+import language-fo-interpretation
diff --git a/agda/src/example.agda b/agda/src/example.agda
index 683500a0..f635bd1f 100644
--- a/agda/src/example.agda
+++ b/agda/src/example.agda
@@ -3,8 +3,10 @@
 module example (Num : Set) (num-zero : Num) where
 
 open import Level using (0ℓ; lift)
+import Data.Fin as Fin
 open import Data.List using (List; []; _∷_)
 open import every using (Every; []; _∷_)
+open import Relation.Binary.PropositionalEquality using (refl)
 open import signature
 import language-syntax
 import label
@@ -20,42 +22,33 @@ module L = language-syntax Sig
 --
 --   sum (concatMap x (e. if equal-label 'a' (fst e) then return (snd e) else nil))
 --
---   sum = fold (lit num-zero) (add (var zero) (var (succ zero)))
+--   sum = foldr (lit num-zero) (add (var zero) (var (succ zero)))
 
 module ex where
   open L
 
-  -- writer monad over the approximation object
-  Tag : type → type
-  Tag τ = base approx [×] τ
-
-  Tag-pure : ∀ {Γ τ} → Γ ⊢ τ [→] Tag τ
-  Tag-pure = lam (pair (bop approx-unit []) (var zero))
-
-  Tag-bind : ∀ {Γ σ τ} → Γ ⊢ Tag σ [→] (σ [→] Tag τ) [→] Tag τ
-  Tag-bind = lam (lam (pair (bop approx-mult (fst (var (succ zero)) ∷ fst (app (var zero) (snd (var (succ zero)))) ∷ []))
-                          (snd (app (var zero) (snd (var (succ zero)))))))
-
-  Tag-monad : SynMonad
-  Tag-monad .SynMonad.Mon = Tag
-  Tag-monad .SynMonad.pure = Tag-pure
-  Tag-monad .SynMonad.bind = Tag-bind
-
-  -- Summation function
-  sum : ∀ {Γ} → Γ ⊢ list (base number) [→] base number
-  sum = lam (fold (bop (lit num-zero) []) (bop add (var zero ∷ var (succ zero) ∷ [])) (var zero))
-
   `_ : ∀ {Γ} → label.label → Γ ⊢ base label
   ` l = bop (lbl l) []
 
   _≟_ : ∀ {Γ} → Γ ⊢ base label → Γ ⊢ base label → Γ ⊢ bool
   M ≟ N = brel equal-label (M ∷ N ∷ [])
 
+  sum : ∀ {Γ} → Γ ⊢ list (base number) [→] base number
+  sum = lam (foldr (bop (lit num-zero) []) (bop add (var zero ∷ var (succ zero) ∷ [])) (var zero))
+
+  some-eq : ∀ {Γ} → Γ ⊢ base label [→] list (base label) [→] bool
+  some-eq = lam (lam
+    (foldr false
+      (if (brel equal-label (var (succ zero) ∷ var (succ (succ (succ zero))) ∷ []))
+       then true else (var zero))
+      (var zero)))
+
   query : label.label → emp , list (base label [×] base number) ⊢ base number
-  query l = app sum
-                (from var zero collect
-                 when fst (var zero) ≟ (` l) ；
-                 return (snd (var zero)))
+  query l =
+    app sum
+      (from var zero collect
+      when fst (var zero) ≟ (` l) ；
+      return (snd (var zero)))
 
   -- Price-weighted sum of the quantities with a given label; the per-label prices are a further
   -- pair of inputs.
@@ -74,21 +67,27 @@ module ex where
 
   -- Moving average with window two over four inputs; adjacent outputs share an input, and
   -- non-adjacent outputs share none. h is the constant 1/2, supplied as a literal.
-  mavg : Num → emp , ((base number [×] base number) [×] base number) [×] base number
-             ⊢ (base number [×] base number) [×] base number
-  mavg h = pair (pair (avg (fst (fst (fst (var zero)))) (snd (fst (fst (var zero)))))
-                      (avg (snd (fst (fst (var zero)))) (snd (fst (var zero)))))
-                (avg (snd (fst (var zero))) (snd (var zero)))
+  mavg-body : ∀ {Γ} → Num → Γ ⊢ base number [×] (base number [×] (base number [×] base number))
+            → Γ ⊢ base number [×] (base number [×] base number)
+  mavg-body h v = pair (avg x₁ x₂) (pair (avg x₂ x₃) (avg x₃ x₄))
     where
       avg : ∀ {Γ} → Γ ⊢ base number → Γ ⊢ base number → Γ ⊢ base number
       avg x y = bop mult (bop (lit h) [] ∷ bop add (x ∷ y ∷ []) ∷ [])
+      x₁ = fst v
+      x₂ = fst (snd v)
+      x₃ = fst (snd (snd v))
+      x₄ = snd (snd (snd v))
+
+  mavg : Num → emp , base number [×] (base number [×] (base number [×] base number))
+             ⊢ base number [×] (base number [×] base number)
+  mavg h = mavg-body h (var zero)
 
   -- 3x3 grid scorer for the signed-saliency reading: a centre-surround linear filter (centre
   -- positive, corners negative) plus two adjacent-cell interaction products. Unlike the linear
   -- mavg, the products make the Jacobian, and hence the saliency, depend on the input. `neg` is
   -- the -1 weight literal; positive weights are implicit. The bottom-middle cell is absent from
   -- the score, so masked.
-  Row Grid : type
+  Row Grid : type 0
   Row  = (base number [×] base number) [×] base number
   Grid = (Row [×] Row) [×] Row
 
@@ -126,7 +125,18 @@ module ex where
   sum-mul : emp , list (base number) [×] base number ⊢ base number
   sum-mul = bop mult (app sum (fst (var zero)) ∷ snd (var zero) ∷ [])
 
-  open import cbn-translation Sig Tag-monad
+  -- Rose trees of numbers: a nested recursive type (the children list is itself
+  -- a μ-type mentioning the outer recursion variable).
+  rose : type 0
+  rose = μ (base number [×] μ (unit [+] (var (Fin.suc Fin.zero) [×] var Fin.zero)))
+
+  node : ∀ {Γ} → Γ ⊢ base number → Γ ⊢ list rose → Γ ⊢ rose
+  node n ts = roll (pair n ts)
+
+  -- Sum of all numbers in a rose tree: the fold's recursion crosses the inner
+  -- list μ, so the children arrive as a list of subtree sums.
+  rose-sum : ∀ {Γ} → Γ ⊢ rose [→] base number
+  rose-sum = lam (fold (bop add (fst (var zero) ∷ app sum (snd (var zero)) ∷ [])) (var zero))
 
-  cbn-query : label.label → emp , Tag (list (Tag (Tag (base label) [×] Tag (base number)))) ⊢ Tag (base number)
-  cbn-query l = ⟪ query l ⟫tm
+  rose-query : emp , rose ⊢ base number
+  rose-query = app rose-sum (var zero)
diff --git a/agda/src/example/all.agda b/agda/src/example/all.agda
deleted file mode 100644
index 2caf63d8..00000000
--- a/agda/src/example/all.agda
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
-module example.all where
-
-import example.bool-fwd
-import example.bool-bwd
-import example.bool-mult
-import example.dependency-mavg
-import example.dependency-total
-import example.rationals-fwd
-import example.rationals-bwd
-import example.rationals-total
-import example.counting-total
-import example.free-total
-import example.intervals-query
-import example.intervals-mult-total
-import example.signs-score
diff --git a/agda/src/example/dependency-mavg.agda b/agda/src/example/dependency-mavg.agda
deleted file mode 100644
index 2d3d91f5..00000000
--- a/agda/src/example/dependency-mavg.agda
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
--- Boolean dependency analysis of the moving-average example: adjacent outputs share an input, and
--- composing the backward and forward derivatives sends a selection of outputs to the outputs
--- related to it by a shared dependency, as in the cognacy analyses of linked visualisations.
-module example.dependency-mavg where
-
-open import example.dependency
-
-half : ℚ
-half = + 1 / 2
-
-input : ⟦ ((base number [×] base number) [×] base number) [×] base number ⟧ty .idx .Carrier
-input = ((1ℚ , + 2 / 1) , + 4 / 1) , + 8 / 1
-
-input-ty : first-order-data (((base number [×] base number) [×] base number) [×] base number)
-input-ty = ((base number [×] base number) [×] base number) [×] base number
-
-output-ty : first-order-data ((base number [×] base number) [×] base number)
-output-ty = (base number [×] base number) [×] base number
-
--- The first input reaches only the first output ...
-test-fwd-first : fwd (mavg half) (_ , input) (lift · , (((⊤ , ⊥) , ⊥) , ⊥))
-                 ≡ ((⊤ , ⊥) , ⊥)
-test-fwd-first = refl
-
--- ... and a shared input reaches both adjacent outputs.
-test-fwd-shared : fwd (mavg half) (_ , input) (lift · , (((⊥ , ⊤) , ⊥) , ⊥))
-                  ≡ ((⊤ , ⊤) , ⊥)
-test-fwd-shared = refl
-
--- Backward derivative of the full output: every input is used.
-test-bwd : SDSemiMod-𝟚.conjugate (selfDual (ty (unit [×] input-ty) (_ , input)))
-             (selfDual (ty output-ty ((+ 3 / 2 , + 3 / 1) , + 6 / 1)))
-             (mor (mavg half) (_ , input)) .func ((⊤ , ⊤) , ⊤)
-           ≡ (lift · , (((⊤ , ⊤) , ⊤) , ⊤))
-test-bwd = refl
-
--- Related outputs: backwards from the first output and forwards again. The second output shares
--- an input with the first; the third shares nothing and stays ⊥.
-test-related : fwd (mavg half) (_ , input)
-                 (SDSemiMod-𝟚.conjugate (selfDual (ty (unit [×] input-ty) (_ , input)))
-                    (selfDual (ty output-ty ((+ 3 / 2 , + 3 / 1) , + 6 / 1)))
-                    (mor (mavg half) (_ , input)) .func ((⊤ , ⊥) , ⊥))
-               ≡ ((⊤ , ⊤) , ⊥)
-test-related = refl
diff --git a/agda/src/example/dependency.agda b/agda/src/example/dependency.agda
index 56b47d9f..ea524b7e 100644
--- a/agda/src/example/dependency.agda
+++ b/agda/src/example/dependency.agda
@@ -1,25 +1,27 @@
 {-# OPTIONS --prop --postfix-projections --safe #-}
 
--- Test harness for Boolean dependency analysis over rational data: the derivative coefficient of
--- a value is the zero map when the value is 0 and the identity otherwise, so the Jacobian entries
--- agree with the nonzero entries of the rational Jacobian, up to the chain rule's
--- over-approximation.
+-- Test harness for Boolean dependency analysis over rational data: a number carries one scalar
+-- position, and the dependency relation of an operation at given arguments is the Boolean collapse
+-- of the rational Jacobian there, ⊥ where an entry is 0 and ⊤ elsewhere.
 module example.dependency where
 
-open import categories using (Category; HasInitial; HasProducts; HasTerminal)
-import cmon-enriched
+open import categories using (Category)
 import prop
+import matrix
 import semimodule
-import sd-semimodule
-import boolalg-sd-semimodule
-import ho-model-boolalg-sd-semimod
+import ho-model-sd-semimod
 import semiring-Q
 import indexed-family
+open import primitives using (Primitives)
+import example.values as V
+open Primitives using (sort-index; sort-width; op-fun; op-deps; rel-pred)
 open import commutative-semiring using (CommutativeSemiring)
 
 open import Level using (lift; 0ℓ) public
+open import Data.Nat using (ℕ)
 open import Data.Unit renaming (tt to ·) using () public
 open import Data.Product using (_,_) public
+open import Data.Sum using (inj₁; inj₂) public
 open import Relation.Binary.PropositionalEquality using (_≡_; refl) public
 open import Relation.Nullary using (yes; no)
 open import two renaming (I to ⊤; O to ⊥) using () public
@@ -27,9 +29,9 @@ open import Data.Integer using (+_; -[1+_]) public
 open import Data.Rational using (ℚ; 0ℚ; 1ℚ; _/_) public
 open import Data.Rational using () renaming (_≟_ to _≟ℚ_)
 open import Data.Nat.Base public using (nonZero)
-open import prop-setoid using (Setoid)
+open import prop-setoid using (Setoid; IsEquivalence)
 open Setoid using (Carrier) public
-open import example.signature ℚ using (Sig; number; label; approx) public
+open import example.signature ℚ using (Sig; sort; number; label; op; rel; lit; add; mult; lbl; equal-label) public
 import example
 open import language-syntax Sig hiding (_,_) public
 module Ex = example ℚ 0ℚ
@@ -37,51 +39,55 @@ open Ex.ex public
 open import label using (a; b) public
 open import prop using (liftS; LiftS)
 
--- Model instantiation: Boolean approximations over rational data.
-module BoolAlg-𝟚 = boolalg-sd-semimodule two.semiring two.semiring-boolean
-module SDSemiMod-𝟚 = sd-semimodule two.semiring
-module SemiMod-𝟚 = semimodule two.semiring
-open cmon-enriched.CMonEnriched SemiMod-𝟚.cmon-enriched using (_+m_; εm)
-
-Approx : Category.obj BoolAlg-𝟚.cat
-Approx = BoolAlg-𝟚.𝕀
-
-approx-unit : Category._⇒_ BoolAlg-𝟚.cat (HasTerminal.witness BoolAlg-𝟚.terminal) Approx
-approx-unit = HasInitial.from-initial BoolAlg-𝟚.initial {Approx}
-approx-conjunct : Category._⇒_ BoolAlg-𝟚.cat (HasProducts.prod BoolAlg-𝟚.products Approx Approx) Approx
-approx-conjunct = HasProducts.p₁ BoolAlg-𝟚.products {Approx} {Approx}
-        +m HasProducts.p₂ BoolAlg-𝟚.products {Approx} {Approx}
-
 private
+  open matrix.Mat two.semiring using (_∥_; block)
+  module M𝟚 = matrix.Mat two.semiring
   open prop-setoid._⇒_
 
-  module Scalars = CommutativeSemiring semiring-Q.semiring
-
-  num-add : prop-setoid._⇒_ (prop-setoid.⊗-setoid semiring-Q.setoid semiring-Q.setoid) semiring-Q.setoid
-  num-add .func (x , y) = x Scalars.+ y
-  num-add .func-resp-≈ e = Scalars.+-cong (prop.proj₁ e) (prop.proj₂ e)
 
-  num-mult : prop-setoid._⇒_ (prop-setoid.⊗-setoid semiring-Q.setoid semiring-Q.setoid) semiring-Q.setoid
-  num-mult .func (x , y) = x Scalars.· y
-  num-mult .func-resp-≈ e = Scalars.·-cong (prop.proj₁ e) (prop.proj₂ e)
+-- Boolean collapse of a rational: ⊥ at 0, ⊤ elsewhere.
+collapse : ℚ → two.Two
+collapse q with q ≟ℚ 0ℚ
+... | yes _ = ⊥
+... | no _  = ⊤
 
-open import example.signature-interpretation BoolAlg-𝟚.cat BoolAlg-𝟚.products BoolAlg-𝟚.terminal
-  Approx approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
-
--- Boolean-collapse derivative coefficient: zero map at 0, identity elsewhere.
 private
-  coeff-b : ℚ → Category._⇒_ BoolAlg-𝟚.cat Approx Approx
-  coeff-b q with q ≟ℚ 0ℚ
-  ... | yes _ = εm
-  ... | no _ = Category.id BoolAlg-𝟚.cat Approx
-
-  coeff-cong-b : ∀ {x y} → Setoid._≈_ semiring-Q.setoid x y → Category._≈_ SemiMod-𝟚.cat (coeff-b x) (coeff-b y)
-  coeff-cong-b {x} (liftS refl) = Category.≈-refl SemiMod-𝟚.cat {f = coeff-b x}
-
-module D = Deriv coeff-b coeff-cong-b
-open ho-model-boolalg-sd-semimod.interp-boolean two.semiring two.semiring-boolean Sig D.BaseInterp1 public
+  -- The Boolean collapse of the Jacobian of multiplication: [ ∂/∂x , ∂/∂y ] = [ y , x ].
+  mult-rel : ℚ → ℚ → Category._⇒_ M𝟚.cat 2 1
+  mult-rel x y = block (collapse y) ∥ block (collapse x)
+
+  mult-rel-resp : ∀ {x x' y y'} →
+                  Setoid._≈_ semiring-Q.setoid x x' → Setoid._≈_ semiring-Q.setoid y y' →
+                  Category._≈_ M𝟚.cat (mult-rel x y) (mult-rel x' y')
+  mult-rel-resp {x} {_} {y} (liftS refl) (liftS refl) = Category.≈-refl M𝟚.cat {f = mult-rel x y}
+
+primitives : Primitives two.semiring Sig
+primitives .sort-index = V.sort-index
+primitives .sort-width number = 1
+primitives .sort-width label  = 0
+primitives .op-fun = V.op-fun
+primitives .rel-pred = V.rel-pred
+primitives .op-deps (lit n) .func _ = M𝟚.εₘ
+primitives .op-deps add .func _ = M𝟚.I ∥ M𝟚.I
+primitives .op-deps mult .func (x , y , _) = mult-rel x y
+primitives .op-deps (lbl l) .func _ = M𝟚.εₘ
+primitives .op-deps (lit n) .func-resp-≈ _ = Category.≈-refl M𝟚.cat {f = M𝟚.εₘ}
+primitives .op-deps add .func-resp-≈ _ = Category.≈-refl M𝟚.cat {f = M𝟚.I ∥ M𝟚.I}
+primitives .op-deps mult .func-resp-≈ e =
+  mult-rel-resp (prop.proj₁ e) (prop.proj₁ (prop.proj₂ e))
+primitives .op-deps (lbl l) .func-resp-≈ _ = Category.≈-refl M𝟚.cat {f = M𝟚.εₘ}
+
+sort-val : sort → Set
+sort-val = Primitives.sort-val primitives
+
+-- The model determined by the primitives, and the interpretation of the language over it.
+module HM = ho-model-sd-semimod two.semiring
+module PI = HM.interp-primitives Sig primitives
+open HM.interp-sd Sig PI.model public
+
+-- W-trees indexing the fibres of closed μ-types, for writing inputs.
+module T = Pm.Tree {n = 0} (λ ())
 
+module SemiMod-𝟚 = semimodule two.semiring
 open indexed-family._⇒f_ public
 open SemiMod-𝟚._⇒_ public
-open BoolAlg-𝟚.SelfDualBooleanAlgebra public using (selfDual)
-
diff --git a/agda/src/example/intervals-query.agda b/agda/src/example/intervals-query.agda
deleted file mode 100644
index 3dbacd4b..00000000
--- a/agda/src/example/intervals-query.agda
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
--- Absolute perturbation bounds for the selection-and-sum query, forwards and backwards.
-module example.intervals-query where
-
-open import example.intervals
-
-input : ⟦ list (base label [×] base number) ⟧ty .idx .Carrier
-input = 3 , (a , + 3 / 1) , (b , 1ℚ) , (a , -[1+ 2 ] / 1) , _
-
-input-ty : first-order-data (list (base label [×] base number))
-input-ty = list (base label [×] base number)
-
--- An interval [l, u] around q becomes the pair of perturbation bounds (q - l , u - q); ∞ is the
--- absent (bottom) approximation.
--- Query a sums #1 and #3 (values 3 and -3, output 0); the forward derivative combines their
--- perturbation bounds by min:
---   ( min(1/2, 1/5) , min(0, 1/2) ) = (1/5 , 0) = the interval [-1/5, 0] around 0.
-test-addᵀ : fwd (query a) (_ , input)
-              (lift · , (lift · , (fin (+ 1 / 2) , fin 0ℚ))
-                      , (lift · , (∞ , ∞))
-                      , (lift · , (fin (+ 1 / 5) , fin (+ 1 / 2))) , _)
-            ≡ (fin (+ 1 / 5) , fin 0ℚ)
-test-addᵀ = refl
-
-bwd-slice : _ → _
-bwd-slice r =
-  conjugate (ty (unit [×] input-ty) (_ , input)) (ty (base number) 0ℚ)
-            (mor (query a) (_ , input)) .func r
-
--- Feeding back output interval [-1/10, 1/10] around 0 = perturbation bounds (1/10, 1/10). The
--- conjugate copies it to the two label-a inputs (#1, #3) and leaves ∞ elsewhere:
---   #1 around 3:  (1/10, 1/10) = [29/10, 31/10]
---   #2 (label b): (∞, ∞)       = no constraint
---   #3 around -3: (1/10, 1/10) = [-31/10, -29/10]
-test-bwd : bwd-slice (fin (+ 1 / 10) , fin (+ 1 / 10))
-           ≡ (lift · , (lift · , (fin (+ 1 / 10) , fin (+ 1 / 10)))
-                     , (lift · , (∞ , ∞))
-                     , (lift · , (fin (+ 1 / 10) , fin (+ 1 / 10))) , lift ·)
-test-bwd = refl
diff --git a/agda/src/example/intervals.agda b/agda/src/example/intervals.agda
deleted file mode 100644
index 20bc2f6f..00000000
--- a/agda/src/example/intervals.agda
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
--- Forward and backward analysis of the example query in the perturbation-bound model, over the
--- self-dual semimodules; numbers approximated by ℚ∞² (left, right perturbation bound).
-module example.intervals where
-
-open import categories using (Category; HasInitial; HasProducts; HasTerminal)
-import cmon-enriched
-import prop
-import semimodule
-import sd-semimodule
-import ho-model-sd-semimod
-import semiring-Q-tropical-add
-import semiring-Q
-
-open import Level using (lift; 0ℓ) public
-open import Data.Unit renaming (tt to ·) using () public
-open import Data.Product using (_,_) public
-open import Relation.Binary.PropositionalEquality using (_≡_; refl) public
-open import Data.Rational using (ℚ; 0ℚ; 1ℚ; _/_) public
-open import Data.Nat.Base public using (nonZero)
-open import Data.Integer.Base public using (nonNeg)
-open import Data.Integer using (+_; -[1+_]) public
-open import commutative-semiring using (CommutativeSemiring)
-open import prop using (liftS)
-open import Data.Integer using (+_)
-open import prop-setoid using (Setoid)
-open Setoid using (Carrier) public
-open import example.signature ℚ using (Sig; number; label; approx) public
-import example
-open import language-syntax Sig hiding (_,_) public
-module Ex = example ℚ 0ℚ
-open Ex.ex public
-open import label using (a; b) public
-open semiring-Q-tropical-add public using (∞; fin)
-
--- Model instantiation.
-module SDSemiMod-ℚ∞ = sd-semimodule semiring-Q-tropical-add.semiring
-module SemiMod-ℚ∞ = semimodule semiring-Q-tropical-add.semiring
-open cmon-enriched.CMonEnriched SemiMod-ℚ∞.cmon-enriched using (_+m_; εm)
-
-Approx : Category.obj SDSemiMod-ℚ∞.cat
-Approx = SDSemiMod-ℚ∞._⊕_ SDSemiMod-ℚ∞.𝕀 SDSemiMod-ℚ∞.𝕀
-
-approx-unit : Category._⇒_ SDSemiMod-ℚ∞.cat (HasTerminal.witness SDSemiMod-ℚ∞.terminal) Approx
-approx-unit = HasInitial.from-initial SDSemiMod-ℚ∞.initial {Approx}
-approx-conjunct : Category._⇒_ SDSemiMod-ℚ∞.cat (HasProducts.prod SDSemiMod-ℚ∞.products Approx Approx) Approx
-approx-conjunct = HasProducts.p₁ SDSemiMod-ℚ∞.products {Approx} {Approx}
-        +m HasProducts.p₂ SDSemiMod-ℚ∞.products {Approx} {Approx}
-
-private
-  module Num = CommutativeSemiring semiring-Q.semiring
-  open prop-setoid._⇒_
-
-  num-add : prop-setoid._⇒_ (prop-setoid.⊗-setoid semiring-Q.setoid semiring-Q.setoid) semiring-Q.setoid
-  num-add .func (x , y) = x Num.+ y
-  num-add .func-resp-≈ e = Num.+-cong (prop.proj₁ e) (prop.proj₂ e)
-
-  num-mult : prop-setoid._⇒_ (prop-setoid.⊗-setoid semiring-Q.setoid semiring-Q.setoid) semiring-Q.setoid
-  num-mult .func (x , y) = x Num.· y
-  num-mult .func-resp-≈ e = Num.·-cong (prop.proj₁ e) (prop.proj₂ e)
-
-open import example.signature-interpretation SDSemiMod-ℚ∞.cat SDSemiMod-ℚ∞.products SDSemiMod-ℚ∞.terminal
-  Approx approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
-
--- Multiplication admits no min-plus-linear perturbation bound; the zero map (constantly ∞) records
--- the absence of a bound.
-private
-  coeff-t : ℚ → Category._⇒_ SDSemiMod-ℚ∞.cat Approx Approx
-  coeff-t _ = εm
-  coeff-cong-t : ∀ {x y} → Setoid._≈_ semiring-Q.setoid x y → Category._≈_ SemiMod-ℚ∞.cat (coeff-t x) (coeff-t y)
-  coeff-cong-t {x} _ = Category.≈-refl SemiMod-ℚ∞.cat {f = coeff-t x}
-
-module D = Deriv coeff-t coeff-cong-t
-open ho-model-sd-semimod.interp-sd semiring-Q-tropical-add.semiring Sig D.BaseInterp1 public
-open SDSemiMod-ℚ∞ public using (conjugate)
-open SemiMod-ℚ∞._⇒_ public
-
diff --git a/agda/src/example/rationals-bwd.agda b/agda/src/example/rationals-bwd.agda
deleted file mode 100644
index b2056027..00000000
--- a/agda/src/example/rationals-bwd.agda
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
--- Reverse-mode AD over the self-dual semimodules, via the conjugate.
-module example.rationals-bwd where
-
-open import example.rationals
-import Data.Rational as Q
-open import Data.Integer using (+_)
-open import Data.Rational using (_/_)
-
-2ℚ = (+ 2) / 1
-3ℚ = (+ 3) / 1
-
-bwd-mult : ℚ → ℚ → ℚ → _
-bwd-mult a b w =
-  conjugate (ty (unit [×] (base number [×] base number)) (_ , (a , b)))
-            (ty (base number) (Q._*_ a b))
-            (mor mult-ex (_ , (a , b))) .func w
-
--- Reverse mode: the gradient of x × y at (2, 3) is (∂/∂x, ∂/∂y) = (y, x) = (3, 2).
-test-rev : bwd-mult 2ℚ 3ℚ 1ℚ ≡ (lift · , (3ℚ , 2ℚ))
-test-rev = refl
diff --git a/agda/src/example/rationals-fwd.agda b/agda/src/example/rationals-fwd.agda
deleted file mode 100644
index 10b08cac..00000000
--- a/agda/src/example/rationals-fwd.agda
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
--- Forward-mode AD over the self-dual semimodules.
-module example.rationals-fwd where
-
-open import example.rationals
-open import Data.Integer using (+_)
-open import Data.Rational using (_/_; -_)
-
-2ℚ = (+ 2) / 1
-3ℚ = (+ 3) / 1
-5ℚ = (+ 5) / 1
-
--- The Jacobian of x × y at (2, 3) is [ ∂/∂x , ∂/∂y ] = [ y , x ] = [ 3 , 2 ].
-test-∂x : fwd mult-ex (_ , (2ℚ , 3ℚ)) (lift · , (1ℚ , 0ℚ)) ≡ 3ℚ
-test-∂x = refl
-
-test-∂y : fwd mult-ex (_ , (2ℚ , 3ℚ)) (lift · , (0ℚ , 1ℚ)) ≡ 2ℚ
-test-∂y = refl
-
--- Tangent (1,1) combines both partials: y + x = 5.
-test-sum : fwd mult-ex (_ , (2ℚ , 3ℚ)) (lift · , (1ℚ , 1ℚ)) ≡ 5ℚ
-test-sum = refl
-
--- Cancellation: at (3, 2), tangent (3, −2) gives (2 × 3) + (3 × −2) = 0, though both inputs contribute.
-test-cancel : fwd mult-ex (_ , (3ℚ , 2ℚ)) (lift · , (3ℚ , - 2ℚ)) ≡ 0ℚ
-test-cancel = refl
-
-8ℚ = (+ 8) / 1
-
--- (sum xs) × y at xs = [3, 5], y = 2: ∂/∂x = y = 2, ∂/∂y = sum xs = 8.
-test-sum-v : fwd sum-mul (_ , ((2 , 3ℚ , 5ℚ , _) , 2ℚ)) (lift · , ((1ℚ , 0ℚ , _) , 0ℚ)) ≡ 2ℚ
-test-sum-v = refl
-
-test-sum-y : fwd sum-mul (_ , ((2 , 3ℚ , 5ℚ , _) , 2ℚ)) (lift · , ((0ℚ , 0ℚ , _) , 1ℚ)) ≡ 8ℚ
-test-sum-y = refl
diff --git a/agda/src/example/rationals-total.agda b/agda/src/example/rationals-total.agda
deleted file mode 100644
index 8eb96011..00000000
--- a/agda/src/example/rationals-total.agda
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
--- Forward and backward derivatives of the weighted-sum query from the introduction, at the
--- rationals: the price column cancels (3 + (-3) = 0) even though the price is used.
-module example.rationals-total where
-
-open import example.rationals
-open import Data.Integer using (+_; -[1+_])
-open import Data.Rational using (_/_)
-open import label using (a; b)
-
-input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty .idx .Carrier
-input = (3 , (a , + 3 / 1) , (b , 1ℚ) , (a , -[1+ 2 ] / 1) , _) , (+ 2 / 1 , + 5 / 1)
-
-input-ty : first-order-data ((list (base label [×] base number)) [×] (base number [×] base number))
-input-ty = list (base label [×] base number) [×] (base number [×] base number)
-
--- ∂/∂q₁ is the price, 2.
-test-q₁ : fwd (total a) (_ , input)
-            (lift · , ((lift · , 1ℚ) , (lift · , 0ℚ) , (lift · , 0ℚ) , _) , (0ℚ , 0ℚ))
-          ≡ + 2 / 1
-test-q₁ = refl
-
--- ∂/∂(price a) is 3 + (-3) = 0: the contributions cancel.
-test-price-a : fwd (total a) (_ , input)
-                 (lift · , ((lift · , 0ℚ) , (lift · , 0ℚ) , (lift · , 0ℚ) , _) , (1ℚ , 0ℚ))
-               ≡ 0ℚ
-test-price-a = refl
-
--- The full backward derivative: (2 0 2 0 0), the price entries zero.
-test-bwd : conjugate (ty (unit [×] input-ty) (_ , input)) (ty (base number) 0ℚ)
-             (mor (total a) (_ , input)) .func 1ℚ
-           ≡ (lift · , ((lift · , + 2 / 1) , (lift · , 0ℚ) , (lift · , + 2 / 1) , lift ·) , (0ℚ , 0ℚ))
-test-bwd = refl
diff --git a/agda/src/example/rationals.agda b/agda/src/example/rationals.agda
deleted file mode 100644
index 1d666b7d..00000000
--- a/agda/src/example/rationals.agda
+++ /dev/null
@@ -1,85 +0,0 @@
-{-# OPTIONS --prop --postfix-projections --safe #-}
-
--- Test harness for the rationals (AD) model with the value-carrying base interpretation
--- (BaseInterp1), over the self-dual semimodules as first-order model.
-module example.rationals where
-
-open import categories using (Category; HasInitial; HasProducts; HasTerminal)
-import cmon-enriched
-import prop
-import semimodule
-import sd-semimodule
-import ho-model-sd-semimod
-import indexed-family
-import semiring-Q
-
-open import Level using (lift; 0ℓ) public
-open import Data.Unit renaming (tt to ·) using () public
-open import Data.Product using (_,_) public
-open import Relation.Binary.PropositionalEquality using (_≡_; refl) public
-open import prop using (liftS) public
-open import Data.Rational using (ℚ; 0ℚ; 1ℚ) public
-open import prop-setoid using (Setoid)
-open Setoid using (Carrier) public
-open import commutative-monoid using (CommutativeMonoid)
-open import commutative-semiring using (CommutativeSemiring)
-open import example.signature ℚ using (Sig; number; label; approx) public
-import example
-open import language-syntax Sig hiding (_,_) public
-module Ex = example ℚ 0ℚ
-open Ex.ex public
-
--- Model instantiation.
-
-module SDSemiMod-ℚ = sd-semimodule semiring-Q.semiring
-module SemiMod-ℚ = semimodule semiring-Q.semiring
-module Scalars = CommutativeSemiring semiring-Q.semiring
-open cmon-enriched.CMonEnriched SemiMod-ℚ.cmon-enriched using (_+m_)
-
-Approx : Category.obj SDSemiMod-ℚ.cat
-Approx = SDSemiMod-ℚ.𝕀
-
-approx-unit : Category._⇒_ SDSemiMod-ℚ.cat (HasTerminal.witness SDSemiMod-ℚ.terminal) Approx
-approx-unit = HasInitial.from-initial SDSemiMod-ℚ.initial {Approx}
-approx-conjunct : Category._⇒_ SDSemiMod-ℚ.cat (HasProducts.prod SDSemiMod-ℚ.products Approx Approx) Approx
-approx-conjunct = HasProducts.p₁ SDSemiMod-ℚ.products {Approx} {Approx}
-        +m HasProducts.p₂ SDSemiMod-ℚ.products {Approx} {Approx}
-
-private
-  module Add = CommutativeMonoid semiring-Q.additive
-  module Mul = CommutativeMonoid semiring-Q.multiplicative
-  open prop-setoid._⇒_
-  open prop-setoid._≃m_
-  open SemiMod-ℚ._≈m_ using (*≈*)
-
-  num-add : prop-setoid._⇒_ (prop-setoid.⊗-setoid semiring-Q.setoid semiring-Q.setoid) semiring-Q.setoid
-  num-add .func (x , y) = x Add.+ y
-  num-add .func-resp-≈ e = Add.+-cong (prop.proj₁ e) (prop.proj₂ e)
-
-  num-mult : prop-setoid._⇒_ (prop-setoid.⊗-setoid semiring-Q.setoid semiring-Q.setoid) semiring-Q.setoid
-  num-mult .func (x , y) = x Mul.+ y
-  num-mult .func-resp-≈ e = Mul.+-cong (prop.proj₁ e) (prop.proj₂ e)
-
-  -- Multiplication by c as a linear endomorphism of the scalars.
-  scalar : ℚ → Category._⇒_ SDSemiMod-ℚ.cat Approx Approx
-  scalar c .SemiMod-ℚ._⇒_.*→* .func x = c Scalars.· x
-  scalar c .SemiMod-ℚ._⇒_.*→* .func-resp-≈ e = Scalars.·-cong (Scalars.refl {c}) e
-  scalar c .SemiMod-ℚ._⇒_.preserve-ze = Scalars.ε-annihilᵣ {c}
-  scalar c .SemiMod-ℚ._⇒_.preserve-+ {x} {y} = Scalars.·-+-distribₗ {c} {x} {y}
-  scalar c .SemiMod-ℚ._⇒_.preserve-· {s} {x} =
-    Scalars.trans (Scalars.sym (Scalars.·-assoc {c} {s} {x}))
-      (Scalars.trans (Scalars.·-cong (Scalars.·-comm {c} {s}) Scalars.refl) (Scalars.·-assoc {s} {c} {x}))
-
-  scalar-cong : ∀ {x y} → Setoid._≈_ semiring-Q.setoid x y → Category._≈_ SemiMod-ℚ.cat (scalar x) (scalar y)
-  scalar-cong e .*≈* .func-eq u≈v = Scalars.·-cong e u≈v
-
-open import example.signature-interpretation SDSemiMod-ℚ.cat SDSemiMod-ℚ.products SDSemiMod-ℚ.terminal
-  Approx approx-unit approx-conjunct semiring-Q.setoid num-add num-mult public
-module D = Deriv scalar scalar-cong
-open ho-model-sd-semimod.interp-sd semiring-Q.semiring Sig D.BaseInterp1 public
-open SDSemiMod-ℚ public using (conjugate)
-
-open indexed-family._⇒f_ public
-open SemiMod-ℚ._⇒_ public
-
-
diff --git a/agda/src/example/relation.agda b/agda/src/example/relation.agda
new file mode 100644
index 00000000..8131101f
--- /dev/null
+++ b/agda/src/example/relation.agda
@@ -0,0 +1,27 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Instantiation of the logical relation at the example signature: Boolean dependency model over rational
+-- data.
+module example.relation where
+
+open import Level using (0ℓ)
+open import Data.Nat using (ℕ)
+open import Data.Rational using (ℚ)
+open import categories using (Category)
+open import primitives using (Primitives)
+import two
+import matrix
+import language-operational.logical-relation
+open import example.signature ℚ using (Sig; sort; number; label; op)
+import example.dependency
+
+module Dep = example.dependency
+
+module LR = language-operational.logical-relation Sig Dep.primitives
+
+-- The fundamental property, specialised to this instantiation.
+FP : Set
+FP = LR.FundamentalProperty
+
+import language-operational.totality
+module Tot = language-operational.totality Sig Dep.primitives
diff --git a/agda/src/example/signature.agda b/agda/src/example/signature.agda
index 19ebb14c..f125c28e 100644
--- a/agda/src/example/signature.agda
+++ b/agda/src/example/signature.agda
@@ -10,15 +10,13 @@ open import Data.List using (List; []; _∷_)
 import label
 
 data sort : Set where
-  number label approx : sort
+  number label : sort
 
 data op : List sort → sort → Set where
   lit  : Num → op [] number
   add  : op (number ∷ number ∷ []) number
   mult : op (number ∷ number ∷ []) number
   lbl  : label.label → op [] label
-  approx-unit : op [] approx
-  approx-mult : op (approx ∷ approx ∷ []) approx
 
 data rel : List sort → Set where
   equal-label : rel (label ∷ label ∷ [])
diff --git a/agda/src/example/values.agda b/agda/src/example/values.agda
new file mode 100644
index 00000000..2dd868ac
--- /dev/null
+++ b/agda/src/example/values.agda
@@ -0,0 +1,44 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- The setoid-side data of the example primitives, shared by the models: rational constants and
+-- operations, labels, and label equality. The models differ only in their widths and dependency
+-- relations.
+module example.values where
+
+open import Level using (0ℓ)
+import prop
+open import prop-setoid using (Setoid; IsEquivalence; +-setoid; 𝟙)
+open import primitives using (sort-vals-setoid)
+open import commutative-semiring using (CommutativeSemiring)
+open import Data.Rational using (ℚ)
+open import Data.Product using (_,_)
+open import Relation.Binary.PropositionalEquality using (refl)
+open import prop using (liftS)
+import semiring-Q
+import label
+open import example.signature ℚ
+  using (sort; number; label; op; rel; lit; add; mult; lbl; equal-label)
+
+private
+  module Scalars = CommutativeSemiring semiring-Q.semiring
+  open prop-setoid._⇒_
+
+sort-index : sort → Setoid 0ℓ 0ℓ
+sort-index number = semiring-Q.setoid
+sort-index label  = label.Label
+
+op-fun : ∀ {is o} (ω : op is o) → prop-setoid._⇒_ (sort-vals-setoid sort-index is) (sort-index o)
+op-fun (lit n) .func _ = n
+op-fun add .func (x , y , _) = x Scalars.+ y
+op-fun mult .func (x , y , _) = x Scalars.· y
+op-fun (lbl l) .func _ = l
+op-fun (lit n) .func-resp-≈ _ = liftS refl
+op-fun add .func-resp-≈ e = Scalars.+-cong (prop.proj₁ e) (prop.proj₁ (prop.proj₂ e))
+op-fun mult .func-resp-≈ e = Scalars.·-cong (prop.proj₁ e) (prop.proj₁ (prop.proj₂ e))
+op-fun (lbl l) .func-resp-≈ _ = Setoid.isEquivalence label.Label .IsEquivalence.refl
+
+rel-pred : ∀ {is} (ψ : rel is) →
+           prop-setoid._⇒_ (sort-vals-setoid sort-index is) (+-setoid (𝟙 {0ℓ} {0ℓ}) 𝟙)
+rel-pred equal-label .func (l₁ , l₂ , _) = label.equal-label .func (l₁ , l₂)
+rel-pred equal-label .func-resp-≈ e =
+  label.equal-label .func-resp-≈ (prop.proj₁ e prop., prop.proj₁ (prop.proj₂ e))
diff --git a/agda/src/fam-functor.agda b/agda/src/fam-functor.agda
index 19b9a116..4700b648 100644
--- a/agda/src/fam-functor.agda
+++ b/agda/src/fam-functor.agda
@@ -3,13 +3,13 @@
 open import Level using (lift)
 open import Data.Unit using (tt)
 open import Data.Product using (_,_)
-open import prop using (_,_; ∃ₛ)
+open import prop using (_,_; ∃; ∃ₛ; Prf; ⟪_⟫)
 open import prop-setoid
-  using (IsEquivalence; module ≈-Reasoning; idS)
+  using (IsEquivalence; module ≈-Reasoning; idS; Setoid)
   renaming (≃m-isEquivalence to ≈s-isEquivalence; _⇒_ to _⇒s_)
-open import categories using (Category; HasTerminal; HasCoproducts; HasProducts)
+open import categories using (Category; HasTerminal; HasCoproducts; HasProducts; setoid→category)
 open import setoid-cat using (SetoidCat; Setoid-coproducts; Setoid-products; Setoid-terminal)
-open import functor using (Functor; NatTrans; Full; Faithful)
+open import functor using (Functor; NatTrans; Colimit; _∘F_; Full; Faithful)
 open import fam using (module CategoryOfFamilies)
 open import finite-product-functor
   using (preserve-chosen-products; preserve-chosen-terminal; module preserve-chosen-products-consequences)
@@ -303,6 +303,91 @@ module _ {o₁ m₁ e₁ o₂ m₂ e₂}
       ∎
       where open ≈-Reasoning 𝒟.isEquiv
 
+  -- FamF admits a uniform choice of definability witnesses when the base
+  -- functor does (and is faithful, for the reconstructed naturality).
+  FamF-def : (∀ {a b} (h : F .fobj a 𝒟.⇒ F .fobj b) →
+                Prf (∃ (a 𝒞.⇒ b) λ g → F .fmor g 𝒟.≈ h) → ∃ₛ (a 𝒞.⇒ b) λ g → F .fmor g 𝒟.≈ h) →
+             (∀ {a b} {g₁ g₂ : a 𝒞.⇒ b} → F .fmor g₁ 𝒟.≈ F .fmor g₂ → g₁ 𝒞.≈ g₂) →
+             ∀ {X Y} (H : Category._⇒_ Fam𝒟.cat (FamF .fobj X) (FamF .fobj Y)) →
+             Prf (∃ (Category._⇒_ Fam𝒞.cat X Y) λ Φ → Category._≈_ Fam𝒟.cat (FamF .fmor Φ) H) →
+             ∃ₛ (Category._⇒_ Fam𝒞.cat X Y) λ Φ → Category._≈_ Fam𝒟.cat (FamF .fmor Φ) H
+  FamF-def def₀ faith {X} {Y} H pr = Φ , eqΦ
+    where
+      open _⇒s_
+
+      wit : ∀ x → ∃ₛ (X .fam .fm x 𝒞.⇒ Y .fam .fm (H .idxf .func x)) λ g → F .fmor g 𝒟.≈ H .famf .transf x
+      wit x = def₀ (H .famf .transf x) ⟪ mapPrf (Prf.prf pr) ⟫
+        where
+          mapPrf : (∃ (Category._⇒_ Fam𝒞.cat X Y) λ Φ → Category._≈_ Fam𝒟.cat (FamF .fmor Φ) H) →
+                   ∃ (X .fam .fm x 𝒞.⇒ Y .fam .fm (H .idxf .func x)) λ g → F .fmor g 𝒟.≈ H .famf .transf x
+          mapPrf (Φ , eq) =
+            (Y .fam .subst (eq .idxf-eq .prop-setoid._≃m_.func-eq (prop-setoid.Setoid.isEquivalence (X .idx) .IsEquivalence.refl)) 𝒞.∘ Φ .famf .transf x)
+            , 𝒟.≈-trans (F .fmor-comp _ _) (eq .famf-eq .transf-eq {x})
+
+      Φ : Category._⇒_ Fam𝒞.cat X Y
+      Φ .idxf = H .idxf
+      Φ .famf .transf x = ∃ₛ.fst (wit x)
+      Φ .famf .natural {x₁} {x₂} e =
+        faith (𝒟.≈-trans (F .fmor-comp _ _)
+              (𝒟.≈-trans (𝒟.∘-cong (∃ₛ.snd (wit x₂)) 𝒟.≈-refl)
+              (𝒟.≈-trans (H .famf .natural e)
+              (𝒟.≈-trans (𝒟.∘-cong 𝒟.≈-refl (𝒟.≈-sym (∃ₛ.snd (wit x₁))))
+                         (𝒟.≈-sym (F .fmor-comp _ _))))))
+
+      eqΦ : Category._≈_ Fam𝒟.cat (FamF .fmor Φ) H
+      eqΦ .idxf-eq = ≈s-isEquivalence .IsEquivalence.refl
+      eqΦ .famf-eq .transf-eq {x} =
+        𝒟.≈-trans (𝒟.∘-cong (FamF .fobj Y .fam .refl*) 𝒟.≈-refl)
+          (𝒟.≈-trans 𝒟.id-left (∃ₛ.snd (wit x)))
+
+  -- FamF preserves set-indexed coproducts: index sets and fibres are unchanged,
+  -- so the comparison is the identity up to the fibrewise fmor-comp bridge.
+  FamF-preserve-bigCopro : ∀ (S : Setoid os es) (D : Functor (setoid→category S) Fam𝒞.cat) →
+    ∃ₛ (Category.Iso Fam𝒟.cat
+          (Colimit.apex (Fam𝒟.bigCoproducts S (FamF ∘F D)))
+          (FamF .fobj (Colimit.apex (Fam𝒞.bigCoproducts S D))))
+       (λ i → ∀ s → Category._≈_ Fam𝒟.cat
+                     (Category._∘_ Fam𝒟.cat (Category.Iso.fwd i)
+                        (Colimit.cocone (Fam𝒟.bigCoproducts S (FamF ∘F D)) .NatTrans.transf s))
+                     (FamF .fmor (Colimit.cocone (Fam𝒞.bigCoproducts S D) .NatTrans.transf s)))
+  FamF-preserve-bigCopro S D = theIso , compat
+    where
+      Lo = Colimit.apex (Fam𝒟.bigCoproducts S (FamF ∘F D))
+      Ro = FamF .fobj (Colimit.apex (Fam𝒞.bigCoproducts S D))
+
+      fwd : Category._⇒_ Fam𝒟.cat Lo Ro
+      fwd .idxf .prop-setoid._⇒_.func p = p
+      fwd .idxf .prop-setoid._⇒_.func-resp-≈ e = e
+      fwd .famf .transf p = 𝒟.id _
+      fwd .famf .natural {s₁ , x₁} {s₂ , x₂} (s₁≈s₂ , x₁≈x₂) =
+        𝒟.≈-trans 𝒟.id-left (𝒟.≈-trans (𝒟.≈-sym (F .fmor-comp _ _)) (𝒟.≈-sym 𝒟.id-right))
+
+      bwd : Category._⇒_ Fam𝒟.cat Ro Lo
+      bwd .idxf .prop-setoid._⇒_.func p = p
+      bwd .idxf .prop-setoid._⇒_.func-resp-≈ e = e
+      bwd .famf .transf p = 𝒟.id _
+      bwd .famf .natural {s₁ , x₁} {s₂ , x₂} (s₁≈s₂ , x₁≈x₂) =
+        𝒟.≈-trans 𝒟.id-left (𝒟.≈-trans (F .fmor-comp _ _) (𝒟.≈-sym 𝒟.id-right))
+
+      theIso : Category.Iso Fam𝒟.cat Lo Ro
+      theIso .Category.Iso.fwd = fwd
+      theIso .Category.Iso.bwd = bwd
+      theIso .Category.Iso.fwd∘bwd≈id .idxf-eq .prop-setoid._≃m_.func-eq e = e
+      theIso .Category.Iso.fwd∘bwd≈id .famf-eq .transf-eq {p} =
+        𝒟.≈-trans (𝒟.∘-cong (Ro .fam .refl*) (𝒟.≈-trans 𝒟.id-left 𝒟.id-left)) 𝒟.id-left
+      theIso .Category.Iso.bwd∘fwd≈id .idxf-eq .prop-setoid._≃m_.func-eq e = e
+      theIso .Category.Iso.bwd∘fwd≈id .famf-eq .transf-eq {p} =
+        𝒟.≈-trans (𝒟.∘-cong (Lo .fam .refl*) (𝒟.≈-trans 𝒟.id-left 𝒟.id-left)) 𝒟.id-left
+
+      compat : ∀ s → Category._≈_ Fam𝒟.cat
+                      (Category._∘_ Fam𝒟.cat fwd (Colimit.cocone (Fam𝒟.bigCoproducts S (FamF ∘F D)) .NatTrans.transf s))
+                      (FamF .fmor (Colimit.cocone (Fam𝒞.bigCoproducts S D) .NatTrans.transf s))
+      compat s .idxf-eq .prop-setoid._≃m_.func-eq e =
+        Colimit.cocone (Fam𝒞.bigCoproducts S D) .NatTrans.transf s .idxf .prop-setoid._⇒_.func-resp-≈ e
+      compat s .famf-eq .transf-eq {d} =
+        𝒟.≈-trans (𝒟.∘-cong (Ro .fam .refl*) (𝒟.≈-trans 𝒟.id-left 𝒟.id-left))
+          (𝒟.≈-trans 𝒟.id-left (𝒟.≈-sym (F .fmor-id)))
+
 
 
 module _ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂}
diff --git a/agda/src/fam-mu-checked.agda b/agda/src/fam-mu-checked.agda
new file mode 100644
index 00000000..fc5ff09f
--- /dev/null
+++ b/agda/src/fam-mu-checked.agda
@@ -0,0 +1,543 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- Checking commutes with μ at constant-free forms. A family is "checked"
+-- by applying a functor G to its singleton fibres; the μ-carrier of a constant-free form
+-- over an environment then agrees with the μ-carrier of the same constant-free over
+-- the checked environment. The two constant-free forms live over the two Fam categories
+-- but share their sorts and trees, which are built from index setoids alone;
+-- the transports below relate the two erasures by recursion on the polynomial,
+-- with identities at the leaves.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_; lift) renaming (suc to lsuc)
+open import Data.Nat using (ℕ) renaming (suc to sucℕ; _+_ to _+ℕ_)
+import Data.Fin as Fin
+open Fin using (Fin; _↑ˡ_; _↑ʳ_)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Data.Product using (_,_)
+open import Data.Unit using (⊤; tt)
+open import prop using () renaming (_,_ to _,ₚ_)
+open import categories using (Category; HasTerminal; HasProducts)
+open import functor using (Functor; _∘F_; functor-preserve-iso)
+open import finite-product-functor
+  using (preserve-chosen-products; module preserve-chosen-products-consequences)
+open import prop-setoid using (Setoid; 𝟙; idS; module ≈-Reasoning)
+open import indexed-family using (functor→fam; Fam)
+import fam
+import fam-presentation
+import polynomial-functor
+import fam-mu-types.sort
+import fam-mu-types.fibre
+
+module fam-mu-checked {o m e o₂ m₂ e₂} (os es : Level)
+    {𝒞 : Category o m e} (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞)
+    {𝒢 : Category o₂ m₂ e₂} (𝒢T : HasTerminal 𝒢) (𝒢P : HasProducts 𝒢)
+    (G : Functor (fam.CategoryOfFamilies.cat os (os ⊔ es) 𝒞) 𝒢)
+    (G-prod : preserve-chosen-products G
+                (fam.CategoryOfFamilies.products.products os (os ⊔ es) 𝒞 𝒞P) 𝒢P)
+    where
+
+private
+  module F𝒞 = fam.CategoryOfFamilies os (os ⊔ es) 𝒞
+  module F𝒢 = fam.CategoryOfFamilies os (os ⊔ es) 𝒢
+  module Sh = fam-mu-types.sort os es
+  module Fc = fam-mu-types.fibre os es 𝒞T 𝒞P
+  module Fg = fam-mu-types.fibre os es 𝒢T 𝒢P
+  module PresC = fam-presentation os (os ⊔ es) {𝒞}
+  module 𝒢C = Category 𝒢
+  module 𝒢Pm = HasProducts 𝒢P
+
+open Sh using (Sort; mkSort)
+open polynomial-functor using (Poly; #c; constant-free; constant-free-go; extend)
+open prop-setoid using (mk-≃m)
+open prop-setoid._⇒_
+open Functor
+open F𝒞.Obj
+open F𝒢.Obj
+open F𝒢.Mor
+open F𝒢._≃_
+open indexed-family._⇒f_
+open indexed-family._≃f_
+open 𝒢C
+open Iso
+
+private
+  -- Conjugating a commuting square by isomorphisms on both sides.
+  iso-flip : ∀ {a b c d} (i : Iso a b) (j : Iso c d)
+             {f : a ⇒ c} {g : b ⇒ d} →
+             (j .fwd ∘ f) ≈ (g ∘ i .fwd) →
+             (f ∘ i .bwd) ≈ (j .bwd ∘ g)
+  iso-flip i j {f} {g} sq =
+    ≈-trans (≈-sym id-left)
+      (≈-trans (∘-cong (≈-sym (j .bwd∘fwd≈id)) ≈-refl)
+        (≈-trans (assoc _ _ _)
+          (≈-trans (∘-cong ≈-refl (≈-sym (assoc _ _ _)))
+            (≈-trans (∘-cong ≈-refl (∘-cong sq ≈-refl))
+              (≈-trans (∘-cong ≈-refl (assoc _ _ _))
+                (≈-trans (∘-cong ≈-refl
+                    (∘-cong ≈-refl (i .fwd∘bwd≈id)))
+                  (∘-cong ≈-refl id-right)))))))
+
+ℓk : Level
+ℓk = o ⊔ m ⊔ e ⊔ o₂ ⊔ m₂ ⊔ e₂ ⊔ lsuc os ⊔ lsuc es
+
+-- The checked family: G applied to the singleton fibres, over the same index
+-- setoid.
+check : F𝒞.Obj → F𝒢.Obj
+check X .idx = X .idx
+check X .fam = functor→fam (G ∘F PresC.singletons X)
+
+module Checked {N : ℕ} (k : ℕ) (δ : Fin N → F𝒞.Obj) where
+  module T  = Sh.Tree (λ i → δ i .idx)
+  module C  = Fc.Fibre δ
+  module Gd = Fg.Fibre (λ i → check (δ i))
+
+  -- The same polynomial in constant-free form over either Fam category.
+  skC : ∀ {j} (Q : Poly F𝒞.cat j) → (Fin (#c Q) → Fin k) → Poly F𝒞.cat (j +ℕ k)
+  skC = constant-free-go
+
+  skG : ∀ {j} (Q : Poly F𝒞.cat j) → (Fin (#c Q) → Fin k) → Poly F𝒢.cat (j +ℕ k)
+  skG = constant-free-go
+
+  -- Relate references and decorated sorts of the two constant-free forms:
+  -- environment positions coincide, and sorts relate recursively through the
+  -- μ-body from which both are formed.
+  mutual
+    data SRel : (r₁ r₂ : Fin N ⊎ Sort N) → C.DecoAssign r₁ → Gd.DecoAssign r₂ → Set ℓk where
+      env : ∀ {p} → SRel (inj₁ p) (inj₁ p) (lift tt) (lift tt)
+      srt : ∀ {s₁ s₂ e₁ e₂} → SortChk s₁ s₂ e₁ e₂ → SRel (inj₂ s₁) (inj₂ s₂) e₁ e₂
+
+    data SortChk : (s₁ s₂ : Sort N) → C.Deco s₁ → Gd.Deco s₂ → Set ℓk where
+      mk : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+           (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+           (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i)) →
+           (∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+           SortChk (mkSort Fc.∣ skC Q ι ∣ ρ₁) (mkSort Fg.∣ skG Q ι ∣ ρ₂)
+                   (C.mkDeco (skC Q ι) d₁) (Gd.mkDeco (skG Q ι) d₂)
+
+  -- Forward tree transport, by recursion on the polynomial; the leaves are
+  -- identities.
+  mutual
+    cfwd : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+           (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+           (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+           (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+           T.W Fc.∣ skC Q ι ∣ ρ₁ → T.W Fg.∣ skG Q ι ∣ ρ₂
+    cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel (T.sup x) =
+      T.sup (shape-cfwd Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+               (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+               (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+               (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) x)
+
+    extend-rel : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+                 (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+                 (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+                 (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+                 ∀ i → SRel (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)) i)
+                            (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)) i)
+                            (C.deco-ext (skC Q ι) d₁ i)
+                            (Gd.deco-ext (skG Q ι) d₂ i)
+    extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel Fin.zero    = srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)
+    extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel (Fin.suc i) = rel i
+
+    shape-cfwd : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                 (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                 (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                 (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i)) →
+                 T.⟦ Fc.∣ skC Q ι ∣ ⟧shape η₁ → T.⟦ Fg.∣ skG Q ι ∣ ⟧shape η₂
+    shape-cfwd {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel x = el-cfwd (rel (jv ↑ʳ ι Fin.zero)) x
+    shape-cfwd (Poly.var i)   ι η₁ η₂ d₁ d₂ rel x = el-cfwd (rel (i ↑ˡ k)) x
+    shape-cfwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₁ x) =
+      inj₁ (shape-cfwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x)
+    shape-cfwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₂ y) =
+      inj₂ (shape-cfwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y)
+    shape-cfwd (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel (x , y) =
+      shape-cfwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x
+      , shape-cfwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y
+    shape-cfwd (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel t = cfwd Q' ι η₁ η₂ d₁ d₂ rel t
+
+    el-cfwd : ∀ {r₁ r₂ e₁ e₂} → SRel r₁ r₂ e₁ e₂ → T.El r₁ → T.El r₂
+    el-cfwd env x = x
+    el-cfwd (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) x = cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel x
+
+  -- The forward transport preserves bisimilarity.
+  mutual
+    c≈fwd : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+            (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+            (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+            (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+            {x y : T.W Fc.∣ skC Q ι ∣ ρ₁} → T.W-≈ x y →
+            T.W-≈ (cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel x) (cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel y)
+    c≈fwd Q ι ρ₁ ρ₂ d₁ d₂ rel {T.sup x} {T.sup y} p =
+      shape≈-cfwd Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+        (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+        (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+        (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) p
+
+    shape≈-cfwd : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                  (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                  (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                  (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i)) →
+                  {x y : T.⟦ Fc.∣ skC Q ι ∣ ⟧shape η₁} → T.shape≈ Fc.∣ skC Q ι ∣ η₁ x y →
+                  T.shape≈ Fg.∣ skG Q ι ∣ η₂ (shape-cfwd Q ι η₁ η₂ d₁ d₂ rel x) (shape-cfwd Q ι η₁ η₂ d₁ d₂ rel y)
+    shape≈-cfwd {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel p = elEq-cfwd (rel (jv ↑ʳ ι Fin.zero)) p
+    shape≈-cfwd (Poly.var i)   ι η₁ η₂ d₁ d₂ rel p = elEq-cfwd (rel (i ↑ˡ k)) p
+    shape≈-cfwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel {inj₁ _} {inj₁ _} p =
+      shape≈-cfwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel p
+    shape≈-cfwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel {inj₂ _} {inj₂ _} p =
+      shape≈-cfwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel p
+    shape≈-cfwd (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel {_ , _} {_ , _} (p ,ₚ q) =
+      shape≈-cfwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel p
+      ,ₚ shape≈-cfwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel q
+    shape≈-cfwd (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel {x} {y} p = c≈fwd Q' ι η₁ η₂ d₁ d₂ rel {x} {y} p
+
+    elEq-cfwd : ∀ {r₁ r₂ e₁ e₂} (r : SRel r₁ r₂ e₁ e₂) {x y : T.El r₁} →
+                T.elEq r₁ x y → T.elEq r₂ (el-cfwd r x) (el-cfwd r y)
+    elEq-cfwd env p = p
+    elEq-cfwd (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) {x} {y} p = c≈fwd Q ι ρ₁ ρ₂ d₁ d₂ rel {x} {y} p
+
+  -- Backward tree transport.
+  mutual
+    cbwd : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+           (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+           (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+           (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+           T.W Fg.∣ skG Q ι ∣ ρ₂ → T.W Fc.∣ skC Q ι ∣ ρ₁
+    cbwd Q ι ρ₁ ρ₂ d₁ d₂ rel (T.sup x) =
+      T.sup (shape-cbwd Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+               (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+               (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+               (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) x)
+
+    shape-cbwd : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                 (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                 (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                 (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i)) →
+                 T.⟦ Fg.∣ skG Q ι ∣ ⟧shape η₂ → T.⟦ Fc.∣ skC Q ι ∣ ⟧shape η₁
+    shape-cbwd {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel x = el-cbwd (rel (jv ↑ʳ ι Fin.zero)) x
+    shape-cbwd (Poly.var i)   ι η₁ η₂ d₁ d₂ rel x = el-cbwd (rel (i ↑ˡ k)) x
+    shape-cbwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₁ x) =
+      inj₁ (shape-cbwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x)
+    shape-cbwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₂ y) =
+      inj₂ (shape-cbwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y)
+    shape-cbwd (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel (x , y) =
+      shape-cbwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x
+      , shape-cbwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y
+    shape-cbwd (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel t = cbwd Q' ι η₁ η₂ d₁ d₂ rel t
+
+    el-cbwd : ∀ {r₁ r₂ e₁ e₂} → SRel r₁ r₂ e₁ e₂ → T.El r₂ → T.El r₁
+    el-cbwd env x = x
+    el-cbwd (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) x = cbwd Q ι ρ₁ ρ₂ d₁ d₂ rel x
+
+  -- The backward transport preserves bisimilarity.
+  mutual
+    c≈bwd : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+            (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+            (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+            (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+            {x y : T.W Fg.∣ skG Q ι ∣ ρ₂} → T.W-≈ x y →
+            T.W-≈ (cbwd Q ι ρ₁ ρ₂ d₁ d₂ rel x) (cbwd Q ι ρ₁ ρ₂ d₁ d₂ rel y)
+    c≈bwd Q ι ρ₁ ρ₂ d₁ d₂ rel {T.sup x} {T.sup y} p =
+      shape≈-cbwd Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+        (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+        (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+        (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) p
+
+    shape≈-cbwd : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                  (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                  (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                  (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i)) →
+                  {x y : T.⟦ Fg.∣ skG Q ι ∣ ⟧shape η₂} → T.shape≈ Fg.∣ skG Q ι ∣ η₂ x y →
+                  T.shape≈ Fc.∣ skC Q ι ∣ η₁ (shape-cbwd Q ι η₁ η₂ d₁ d₂ rel x) (shape-cbwd Q ι η₁ η₂ d₁ d₂ rel y)
+    shape≈-cbwd {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel p = elEq-cbwd (rel (jv ↑ʳ ι Fin.zero)) p
+    shape≈-cbwd (Poly.var i)   ι η₁ η₂ d₁ d₂ rel p = elEq-cbwd (rel (i ↑ˡ k)) p
+    shape≈-cbwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel {inj₁ _} {inj₁ _} p =
+      shape≈-cbwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel p
+    shape≈-cbwd (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel {inj₂ _} {inj₂ _} p =
+      shape≈-cbwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel p
+    shape≈-cbwd (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel {_ , _} {_ , _} (p ,ₚ q) =
+      shape≈-cbwd Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel p
+      ,ₚ shape≈-cbwd R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel q
+    shape≈-cbwd (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel {x} {y} p = c≈bwd Q' ι η₁ η₂ d₁ d₂ rel {x} {y} p
+
+    elEq-cbwd : ∀ {r₁ r₂ e₁ e₂} (r : SRel r₁ r₂ e₁ e₂) {x y : T.El r₂} →
+                T.elEq r₂ x y → T.elEq r₁ (el-cbwd r x) (el-cbwd r y)
+    elEq-cbwd env p = p
+    elEq-cbwd (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) {x} {y} p = c≈bwd Q ι ρ₁ ρ₂ d₁ d₂ rel {x} {y} p
+
+  -- Round trips: the two transports are mutually inverse up to bisimilarity.
+  mutual
+    c-fb : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+           (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+           (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+           (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+           (x : T.W Fc.∣ skC Q ι ∣ ρ₁) →
+           T.W-≈ (cbwd Q ι ρ₁ ρ₂ d₁ d₂ rel (cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel x)) x
+    c-fb Q ι ρ₁ ρ₂ d₁ d₂ rel (T.sup x) =
+      shape-cfb Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+        (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+        (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+        (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) x
+
+    shape-cfb : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i)) →
+                (x : T.⟦ Fc.∣ skC Q ι ∣ ⟧shape η₁) →
+                T.shape≈ Fc.∣ skC Q ι ∣ η₁ (shape-cbwd Q ι η₁ η₂ d₁ d₂ rel (shape-cfwd Q ι η₁ η₂ d₁ d₂ rel x)) x
+    shape-cfb {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel x = el-cfb (rel (jv ↑ʳ ι Fin.zero)) x
+    shape-cfb (Poly.var i)   ι η₁ η₂ d₁ d₂ rel x = el-cfb (rel (i ↑ˡ k)) x
+    shape-cfb (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₁ x) =
+      shape-cfb Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x
+    shape-cfb (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₂ y) =
+      shape-cfb R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y
+    shape-cfb (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel (x , y) =
+      shape-cfb Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x
+      ,ₚ shape-cfb R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y
+    shape-cfb (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel t = c-fb Q' ι η₁ η₂ d₁ d₂ rel t
+
+    el-cfb : ∀ {r₁ r₂ e₁ e₂} (r : SRel r₁ r₂ e₁ e₂) (x : T.El r₁) →
+             T.elEq r₁ (el-cbwd r (el-cfwd r x)) x
+    el-cfb (env {p}) x = T.elEq-refl (inj₁ p) x
+    el-cfb (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) x = c-fb Q ι ρ₁ ρ₂ d₁ d₂ rel x
+
+  mutual
+    c-bf : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+           (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+           (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+           (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i)) →
+           (y : T.W Fg.∣ skG Q ι ∣ ρ₂) →
+           T.W-≈ (cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel (cbwd Q ι ρ₁ ρ₂ d₁ d₂ rel y)) y
+    c-bf Q ι ρ₁ ρ₂ d₁ d₂ rel (T.sup y) =
+      shape-cbf Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+        (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+        (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+        (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) y
+
+    shape-cbf : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i)) →
+                (y : T.⟦ Fg.∣ skG Q ι ∣ ⟧shape η₂) →
+                T.shape≈ Fg.∣ skG Q ι ∣ η₂ (shape-cfwd Q ι η₁ η₂ d₁ d₂ rel (shape-cbwd Q ι η₁ η₂ d₁ d₂ rel y)) y
+    shape-cbf {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel y = el-cbf (rel (jv ↑ʳ ι Fin.zero)) y
+    shape-cbf (Poly.var i)   ι η₁ η₂ d₁ d₂ rel y = el-cbf (rel (i ↑ˡ k)) y
+    shape-cbf (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₁ y) =
+      shape-cbf Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel y
+    shape-cbf (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₂ y) =
+      shape-cbf R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y
+    shape-cbf (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel (x , y) =
+      shape-cbf Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x
+      ,ₚ shape-cbf R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y
+    shape-cbf (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel t = c-bf Q' ι η₁ η₂ d₁ d₂ rel t
+
+    el-cbf : ∀ {r₁ r₂ e₁ e₂} (r : SRel r₁ r₂ e₁ e₂) (y : T.El r₂) →
+             T.elEq r₂ (el-cfwd r (el-cbwd r y)) y
+    el-cbf (env {p}) y = T.elEq-refl (inj₁ p) y
+    el-cbf (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) y = c-bf Q ι ρ₁ ρ₂ d₁ d₂ rel y
+
+  -- The fibre isomorphisms: G of the checked singleton fibre at a tree against
+  -- the 𝒢-side μ-fibre at the transported tree. The leaves are identities by
+  -- the construction of check; products go through simple-⊗ and G's
+  -- preservation of products.
+  mutual
+    fib-ciso : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+               (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+               (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+               (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i))
+               (w : T.W Fc.∣ skC Q ι ∣ ρ₁) →
+               Iso (G .fobj F𝒞.simple[ 𝟙 , C.fib (skC Q ι) d₁ w ])
+                      (Gd.fib (skG Q ι) d₂ (cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel w))
+    fib-ciso Q ι ρ₁ ρ₂ d₁ d₂ rel (T.sup x) =
+      fib-shape-ciso Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+        (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+        (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+        (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) x
+
+    fib-shape-ciso : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                     (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                     (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                     (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i))
+                     (x : T.⟦ Fc.∣ skC Q ι ∣ ⟧shape η₁) →
+                     Iso (G .fobj F𝒞.simple[ 𝟙 , C.fib-shape (skC Q ι) d₁ x ])
+                            (Gd.fib-shape (skG Q ι) d₂ (shape-cfwd Q ι η₁ η₂ d₁ d₂ rel x))
+    fib-shape-ciso {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel x = fib-el-ciso (rel (jv ↑ʳ ι Fin.zero)) x
+    fib-shape-ciso (Poly.var i)   ι η₁ η₂ d₁ d₂ rel x = fib-el-ciso (rel (i ↑ˡ k)) x
+    fib-shape-ciso (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₁ x) =
+      fib-shape-ciso Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x
+    fib-shape-ciso (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel (inj₂ y) =
+      fib-shape-ciso R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y
+    fib-shape-ciso (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel (x , y) =
+      Iso-trans (functor-preserve-iso G (PresC.simple-⊗ 𝒞P))
+        (Iso-trans (IsIso→Iso G-prod)
+          (𝒢Pm.product-preserves-iso
+            (fib-shape-ciso Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel x)
+            (fib-shape-ciso R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel y)))
+    fib-shape-ciso (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel t = fib-ciso Q' ι η₁ η₂ d₁ d₂ rel t
+
+    fib-el-ciso : ∀ {r₁ r₂ e₁ e₂} (r : SRel r₁ r₂ e₁ e₂) (x : T.El r₁) →
+                  Iso (G .fobj F𝒞.simple[ 𝟙 , C.fib-el r₁ e₁ x ])
+                         (Gd.fib-el r₂ e₂ (el-cfwd r x))
+    fib-el-ciso (env {p}) x = Iso-refl
+    fib-el-ciso (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) x = fib-ciso Q ι ρ₁ ρ₂ d₁ d₂ rel x
+
+  open preserve-chosen-products-consequences G (F𝒞.products.products 𝒞P) 𝒢P G-prod
+    using (mul⁻¹-natural)
+
+  -- The fibre isomorphisms commute with transport along bisimilarity.
+  mutual
+    fib-cnat : ∀ {j} (Q : Poly F𝒞.cat (sucℕ j)) (ι : Fin (#c Q) → Fin k)
+               (ρ₁ ρ₂ : Fin (j +ℕ k) → Fin N ⊎ Sort N)
+               (d₁ : ∀ i → C.DecoAssign (ρ₁ i)) (d₂ : ∀ i → Gd.DecoAssign (ρ₂ i))
+               (rel : ∀ i → SRel (ρ₁ i) (ρ₂ i) (d₁ i) (d₂ i))
+               {w w' : T.W Fc.∣ skC Q ι ∣ ρ₁} (p : T.W-≈ w w') →
+               ((fib-ciso Q ι ρ₁ ρ₂ d₁ d₂ rel w' .fwd)
+                 ∘ G .fmor F𝒞.simplef[ idS 𝟙 , C.fib-subst (skC Q ι) d₁ {x = w} {y = w'} p ])
+               ≈ ((Gd.fib-subst (skG Q ι) d₂
+                        {x = cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel w} {y = cfwd Q ι ρ₁ ρ₂ d₁ d₂ rel w'}
+                        (c≈fwd Q ι ρ₁ ρ₂ d₁ d₂ rel {w} {w'} p))
+                     ∘ (fib-ciso Q ι ρ₁ ρ₂ d₁ d₂ rel w .fwd))
+    fib-cnat Q ι ρ₁ ρ₂ d₁ d₂ rel {T.sup x} {T.sup x'} p =
+      fib-shape-cnat Q ι (extend ρ₁ (inj₂ (mkSort Fc.∣ skC Q ι ∣ ρ₁)))
+        (extend ρ₂ (inj₂ (mkSort Fg.∣ skG Q ι ∣ ρ₂)))
+        (C.deco-ext (skC Q ι) d₁) (Gd.deco-ext (skG Q ι) d₂)
+        (extend-rel Q ι ρ₁ ρ₂ d₁ d₂ rel) {x} {x'} p
+
+    fib-shape-cnat : ∀ {jv} (Q : Poly F𝒞.cat jv) (ι : Fin (#c Q) → Fin k)
+                     (η₁ η₂ : Fin (jv +ℕ k) → Fin N ⊎ Sort N)
+                     (d₁ : ∀ i → C.DecoAssign (η₁ i)) (d₂ : ∀ i → Gd.DecoAssign (η₂ i))
+                     (rel : ∀ i → SRel (η₁ i) (η₂ i) (d₁ i) (d₂ i))
+                     {x x' : T.⟦ Fc.∣ skC Q ι ∣ ⟧shape η₁} (p : T.shape≈ Fc.∣ skC Q ι ∣ η₁ x x') →
+                     ((fib-shape-ciso Q ι η₁ η₂ d₁ d₂ rel x' .fwd)
+                       ∘ G .fmor F𝒞.simplef[ idS 𝟙 , C.fib-shape-subst (skC Q ι) d₁ p ])
+                     ≈ ((Gd.fib-shape-subst (skG Q ι) d₂ (shape≈-cfwd Q ι η₁ η₂ d₁ d₂ rel {x} {x'} p))
+                           ∘ (fib-shape-ciso Q ι η₁ η₂ d₁ d₂ rel x .fwd))
+    fib-shape-cnat {jv} (Poly.const A) ι η₁ η₂ d₁ d₂ rel p = fib-el-cnat (rel (jv ↑ʳ ι Fin.zero)) p
+    fib-shape-cnat (Poly.var i)   ι η₁ η₂ d₁ d₂ rel p = fib-el-cnat (rel (i ↑ˡ k)) p
+    fib-shape-cnat (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel {inj₁ _} {inj₁ _} p =
+      fib-shape-cnat Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel p
+    fib-shape-cnat (Q Poly.+ R) ι η₁ η₂ d₁ d₂ rel {inj₂ _} {inj₂ _} p =
+      fib-shape-cnat R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel p
+    fib-shape-cnat (Q Poly.× R) ι η₁ η₂ d₁ d₂ rel {x₁ , x₂} {x₁' , x₂'} (p₁ ,ₚ p₂) =
+      ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong ≈-refl
+            (≈-trans (≈-sym (G .fmor-comp _ _))
+              (≈-trans (G .fmor-cong (PresC.simple-⊗-natural 𝒞P s₁ s₂))
+                (G .fmor-comp _ _))))
+          (≈-trans (≈-sym (assoc _ _ _))
+            (≈-trans (∘-cong (assoc _ _ _) ≈-refl)
+              (≈-trans (∘-cong (∘-cong ≈-refl
+                  (mul⁻¹-natural {f = smp s₁} {g = smp s₂})) ≈-refl)
+                (≈-trans (∘-cong (≈-sym (assoc _ _ _)) ≈-refl)
+                  (≈-trans (∘-cong (∘-cong
+                      (≈-trans (≈-sym (𝒢Pm.prod-m-comp _ _ _ _))
+                        (≈-trans
+                          (𝒢Pm.prod-m-cong
+                            (fib-shape-cnat Q (λ c → ι (c ↑ˡ #c R)) η₁ η₂ d₁ d₂ rel {x₁} {x₁'} p₁)
+                            (fib-shape-cnat R (λ c → ι (#c Q ↑ʳ c)) η₁ η₂ d₁ d₂ rel {x₂} {x₂'} p₂))
+                          (𝒢Pm.prod-m-comp _ _ _ _))) ≈-refl) ≈-refl)
+                    (≈-trans (∘-cong (assoc _ _ _) ≈-refl)
+                      (assoc _ _ _))))))))
+      where
+        s₁ = C.fib-shape-subst (skC Q (λ c → ι (c ↑ˡ #c R))) d₁ p₁
+        s₂ = C.fib-shape-subst (skC R (λ c → ι (#c Q ↑ʳ c))) d₁ p₂
+
+        smp : ∀ {a b} → Category._⇒_ 𝒞 a b → F𝒞.Mor F𝒞.simple[ 𝟙 , a ] F𝒞.simple[ 𝟙 , b ]
+        smp h = F𝒞.simplef[ idS 𝟙 , h ]
+    fib-shape-cnat (Poly.μ Q')  ι η₁ η₂ d₁ d₂ rel {t} {t'} p = fib-cnat Q' ι η₁ η₂ d₁ d₂ rel {t} {t'} p
+
+    fib-el-cnat : ∀ {r₁ r₂ e₁ e₂} (r : SRel r₁ r₂ e₁ e₂) {x x' : T.El r₁} (p : T.elEq r₁ x x') →
+                  ((fib-el-ciso r x' .fwd)
+                    ∘ G .fmor F𝒞.simplef[ idS 𝟙 , C.fib-el-subst r₁ e₁ p ])
+                  ≈ ((Gd.fib-el-subst r₂ e₂ (elEq-cfwd r {x} {x'} p))
+                        ∘ (fib-el-ciso r x .fwd))
+    fib-el-cnat (env {p}) q = ≈-trans id-left (≈-sym id-right)
+    fib-el-cnat (srt (mk Q ι ρ₁ ρ₂ d₁ d₂ rel)) {x} {x'} q = fib-cnat Q ι ρ₁ ρ₂ d₁ d₂ rel {x} {x'} q
+
+-- The assembled comparison: check commutes with μ at the constant-free form,
+-- as an isomorphism of Fam(𝒢)-objects.
+module ChkMu {n : ℕ} (P : Poly F𝒞.cat (sucℕ n)) (ε : Fin (n +ℕ #c P) → F𝒞.Obj) where
+  open Checked (#c P) ε
+  open Fam
+
+  private
+    ρ₀ : Fin (n +ℕ #c P) → Fin (n +ℕ #c P) ⊎ Sort (n +ℕ #c P)
+    ρ₀ i = inj₁ i
+
+    d₁₀ : ∀ i → C.DecoAssign (ρ₀ i)
+    d₁₀ i = lift tt
+
+    d₂₀ : ∀ i → Gd.DecoAssign (ρ₀ i)
+    d₂₀ i = lift tt
+
+    rel₀ : ∀ i → SRel (ρ₀ i) (ρ₀ i) (d₁₀ i) (d₂₀ i)
+    rel₀ i = env
+
+    Fw = cfwd P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀
+    Bw = cbwd P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀
+    ci = fib-ciso P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀
+
+  fwd-mor : F𝒢.Mor (check (Fc.μObj (constant-free P) ε)) (Fg.μObj (constant-free P) (λ i → check (ε i)))
+  fwd-mor .idxf .func = Fw
+  fwd-mor .idxf .func-resp-≈ {w} {w'} =
+    c≈fwd P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ {w} {w'}
+  fwd-mor .famf .transf w = ci w .fwd
+  fwd-mor .famf .natural {w} {w'} q =
+    fib-cnat P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ {w} {w'} q
+
+  bwd-mor : F𝒢.Mor (Fg.μObj (constant-free P) (λ i → check (ε i))) (check (Fc.μObj (constant-free P) ε))
+  bwd-mor .idxf .func = Bw
+  bwd-mor .idxf .func-resp-≈ {s} {s'} =
+    c≈bwd P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ {s} {s'}
+  bwd-mor .famf .transf s =
+    ci (Bw s) .bwd ∘
+    Gd.fib-subst (constant-free P) d₂₀ {x = s} {y = Fw (Bw s)}
+      (T.W-≈-sym {x = Fw (Bw s)} {y = s} (c-bf P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ s))
+  bwd-mor .famf .natural {s₁} {s₂} q =
+    ≈-trans (assoc _ _ _)
+      (≈-trans (∘-cong₂ (≈-sym (Gd.fib-trans* (constant-free P) d₂₀
+                                           {x = s₁} {y = s₂} {z = Fw (Bw s₂)} _ q)))
+        (≈-sym
+          (≈-trans (≈-sym (assoc _ _ _))
+            (≈-trans (∘-cong₁ (iso-flip (ci (Bw s₁)) (ci (Bw s₂))
+                (fib-cnat P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ {Bw s₁} {Bw s₂}
+                  (c≈bwd P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ {s₁} {s₂} q))))
+              (≈-trans (assoc _ _ _)
+                (∘-cong₂ (≈-sym (Gd.fib-trans* (constant-free P) d₂₀
+                                          {x = s₁} {y = Fw (Bw s₁)} {z = Fw (Bw s₂)} _ _))))))))
+
+  fb-≃ : Category._≈_ F𝒢.cat
+           (Category._∘_ F𝒢.cat fwd-mor bwd-mor) (Category.id F𝒢.cat _)
+  fb-≃ .idxf-eq =
+    mk-≃m (λ s → c-bf P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ s)
+  fb-≃ .famf-eq .transf-eq {s} =
+    ≈-trans (∘-cong₂ id-left)
+      (≈-trans (∘-cong₂ (≈-trans (≈-sym (assoc _ _ _))
+          (≈-trans (∘-cong₁ (ci (Bw s) .fwd∘bwd≈id)) id-left)))
+        (≈-trans (≈-sym (Gd.fib-trans* (constant-free P) d₂₀
+                                  {x = s} {y = Fw (Bw s)} {z = s} _ _))
+          (Gd.fib-refl* (constant-free P) d₂₀ s)))
+
+  bf-≃ : Category._≈_ F𝒢.cat
+           (Category._∘_ F𝒢.cat bwd-mor fwd-mor) (Category.id F𝒢.cat _)
+  bf-≃ .idxf-eq =
+    mk-≃m (λ w → c-fb P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ w)
+  bf-≃ .famf-eq .transf-eq {w} =
+    ≈-trans (∘-cong₂ id-left)
+      (≈-trans (∘-cong₂ (≈-trans (assoc _ _ _)
+          (≈-trans (∘-cong₂ (≈-sym
+              (fib-cnat P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ {w} {Bw (Fw w)}
+                (T.W-≈-sym {x = Bw (Fw w)} {y = w} (c-fb P (λ c → c) ρ₀ ρ₀ d₁₀ d₂₀ rel₀ w)))))
+            (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong₁ (ci (Bw (Fw w)) .bwd∘fwd≈id)) id-left)))))
+        (≈-trans (≈-sym (check (Fc.μObj (constant-free P) ε) .fam .trans*
+                                  {x = w} {y = Bw (Fw w)} {z = w} _ _))
+          (check (Fc.μObj (constant-free P) ε) .fam .refl* {x = w})))
+
+  check-μ-iso : Category.Iso F𝒢.cat
+                  (check (Fc.μObj (constant-free P) ε)) (Fg.μObj (constant-free P) (λ i → check (ε i)))
+  check-μ-iso .Category.Iso.fwd = fwd-mor
+  check-μ-iso .Category.Iso.bwd = bwd-mor
+  check-μ-iso .Category.Iso.fwd∘bwd≈id = fb-≃
+  check-μ-iso .Category.Iso.bwd∘fwd≈id = bf-≃
diff --git a/agda/src/fam-mu-realisation.agda b/agda/src/fam-mu-realisation.agda
new file mode 100644
index 00000000..45652b94
--- /dev/null
+++ b/agda/src/fam-mu-realisation.agda
@@ -0,0 +1,466 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Parameterised initial algebras for a category ℰ with setoid-indexed
+-- colimits, products, exponentials and strong coproducts, constructed by
+-- realising the μ-types of Fam(ℰ). The realised μ-object carries an initial
+-- algebra for the realised polynomial endofunctor; the algebra map, fold and
+-- laws are established by a mutual induction on polynomials: the invariance
+-- isomorphisms (realisation is invariant under replacing an environment entry
+-- by a family with isomorphic realisation), initiality via folds transposed
+-- through the adjunction between realisation and the singleton embedding, and
+-- uniqueness of initial algebras at the inner-μ cases.
+
+open import Level using (Level; _⊔_)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import prop-setoid using (Setoid; module ≈-Reasoning)
+open import categories
+  using (Category; setoid→category; HasTerminal; HasProducts; HasExponentials;
+         HasStrongCoproducts; HasCoproducts; strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor; HasColimits)
+open import polynomial-functor using (Poly; extend; Poly-map)
+import fam
+import fam-mu-types
+import fam-realisation
+import polynomial-functor
+import fam-mu-realisation.natural
+
+module fam-mu-realisation {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os (os ⊔ es)) → HasColimits (setoid→category A) ℰ)
+  (ℰT : HasTerminal ℰ) (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP)
+  (ℰSC : HasStrongCoproducts ℰ ℰP)
+  where
+
+open fam-mu-realisation.natural os es ℰC ℰT ℰP ℰE ℰSC public
+
+-- The μ-objects for ℰ itself, via realisation of the Fam(ℰ) μ-objects at
+-- singleton-embedded environments.
+μ-objℰ : ∀ {n} → Poly ℰ (suc n) → (Fin n → obj) → obj
+μ-objℰ P δ = Creal P (λ i → η .fobj (δ i))
+
+private
+  module ℰCoprod = HasCoproducts (strong-coproducts→coproducts ℰT ℰSC)
+
+-- The ℰ-interpretation of a polynomial agrees with the realised Fam(ℰ)
+-- interpretation, over any pointwise agreement of environments.
+fobj-realise-iso : ∀ {n} (P : Poly ℰ n) (δ : Fin n → obj) (δ̂ : Fin n → FM.Obj) →
+                   (∀ i → Iso (δ i) (realise .fobj (δ̂ i))) →
+                   Iso (ℰI.fobj μ-objℰ P δ) (realise .fobj (FM.fobj FM.μObj (Poly-map η P) δ̂))
+fobj-realise-iso (const A) δ δ̂ js = Iso-sym (realise-η-iso A)
+fobj-realise-iso (var i)   δ δ̂ js = js i
+fobj-realise-iso (P + Q)   δ δ̂ js =
+  Iso-trans
+    (ℰCoprod.coproduct-preserve-iso (fobj-realise-iso P δ δ̂ js) (fobj-realise-iso Q δ δ̂ js))
+    (Iso-sym (FR.realise-coproducts-iso (strong-coproducts→coproducts ℰT ℰSC) _ _))
+fobj-realise-iso (P × Q)   δ δ̂ js =
+  Iso-trans
+    (ℰP.product-preserves-iso (fobj-realise-iso P δ δ̂ js) (fobj-realise-iso Q δ δ̂ js))
+    (Iso-sym (FR.realise-products-iso ℰP ℰE _ _))
+fobj-realise-iso (μ P)     δ δ̂ js =
+  MuInvariance.mu-invariance P (invarianceAt P) (λ i → η .fobj (δ i)) δ̂
+    (λ i → Iso-trans (realise-η-iso (δ i)) (js i))
+
+-- Pointwise agreement between an extended ℰ-environment and its embedded
+-- Fam(ℰ) counterpart.
+ηjs : ∀ {n} (δ : Fin n → obj) (X : obj) →
+      ∀ i → Iso (extend δ X i) (realise .fobj (extend (λ j → η .fobj (δ j)) (η .fobj X) i))
+ηjs δ X Fin.zero    = Iso-sym (realise-η-iso X)
+ηjs δ X (Fin.suc i) = Iso-sym (realise-η-iso (δ i))
+
+-- The initial-algebra structure for ℰ.
+inMapℰ : ∀ {n} (P : Poly ℰ (suc n)) (δ : Fin n → obj) →
+     ℰI.fobj μ-objℰ P (extend δ (μ-objℰ P δ)) ⇒ μ-objℰ P δ
+inMapℰ {n} P δ =
+  Initiality.inR P (λ i → η .fobj (δ i)) (invarianceAt P) ∘
+  fobj-realise-iso P (extend δ (μ-objℰ P δ)) (extend (λ i → η .fobj (δ i)) (η .fobj (μ-objℰ P δ))) (ηjs δ (μ-objℰ P δ)) .fwd
+
+⦅⦆ℰ : ∀ {n Γ A} {P : Poly ℰ (suc n)} {δ : Fin n → obj} →
+      (ℰP.prod Γ (ℰI.fobj μ-objℰ P (extend δ A)) ⇒ A) → ℰP.prod Γ (μ-objℰ P δ) ⇒ A
+⦅⦆ℰ {n} {Γ} {A} {P} {δ} alg =
+  Initiality.foldR P (λ i → η .fobj (δ i)) (invarianceAt P)
+    (alg ∘ ℰP.prod-m (id _) (fobj-realise-iso P (extend δ A) (extend (λ i → η .fobj (δ i)) (η .fobj A)) (ηjs δ A) .bwd))
+
+-- ℰ has Poly-types.
+Muℰ : ℰI.HasMu
+Muℰ .ℰI.HasMu.μ-obj = μ-objℰ
+Muℰ .ℰI.HasMu.inMap = inMapℰ
+Muℰ .ℰI.HasMu.⦅_⦆ = ⦅⦆ℰ
+
+private
+  module ℰMu = ℰI.HasMu Muℰ
+
+-- The realised Fam(ℰ) strong action simulates ℰ's own derived strong action,
+-- across the interpretation isomorphism.
+SimStmt : ∀ {n} (P : Poly ℰ n) → Prop (o ⊔ m ⊔ e ⊔ Level.suc os ⊔ Level.suc es)
+SimStmt {n} P =
+  ∀ {Γ : obj} (δ δ' : Fin n → obj) (δ̂ δ̂' : Fin n → FM.Obj)
+  (js : ∀ i → Iso (δ i) (realise .fobj (δ̂ i))) (js' : ∀ i → Iso (δ' i) (realise .fobj (δ̂' i)))
+  (fs : ∀ i → ℰP.prod Γ (δ i) ⇒ δ' i)
+  (ĝs : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂ i)) (δ̂' i)) →
+  (∀ i → fmorη Γ (δ̂ i) (ĝs i) ∘co (js i .fwd ∘ ℰP.p₂) ≈ js' i .fwd ∘ fs i) →
+  fmorη Γ (FM.fobj FM.μObj (Poly-map η P) δ̂) (FMu.strong-fmor (Poly-map η P) ĝs)
+    ∘co (fobj-realise-iso P δ δ̂ js .fwd ∘ ℰP.p₂)
+  ≈ fobj-realise-iso P δ' δ̂' js' .fwd ∘ ℰMu.strong-fmor P fs
+
+sim-const : ∀ {n} (A : obj) → SimStmt {n} (const A)
+sim-const A δ δ' δ̂ δ̂' js js' fs ĝs sqs =
+  ≈-trans (CoK.∘-cong₁ (fmorη-p₂ _ _)) CoK.id-left
+
+sim-var : ∀ {n} (i : Fin n) → SimStmt (var i)
+sim-var i δ δ' δ̂ δ̂' js js' fs ĝs sqs = sqs i
+
+sim-sum : ∀ {n} (P Q : Poly ℰ n) → SimStmt P → SimStmt Q → SimStmt (P + Q)
+sim-sum {n} P Q simP simQ {Γ} δ δ' δ̂ δ̂' js js' fs ĝs sqs =
+  ≈-trans lhs (≈-sym rhs)
+  where
+    X̂ : (Fin n → FM.Obj) → FM.Obj
+    X̂ γ̂ = FM.fobj FM.μObj (Poly-map η P) γ̂
+
+    Ŷ : (Fin n → FM.Obj) → FM.Obj
+    Ŷ γ̂ = FM.fobj FM.μObj (Poly-map η Q) γ̂
+
+    mid : ℰP.prod Γ (ℰCoprod.coprod (ℰI.fobj μ-objℰ P δ) (ℰI.fobj μ-objℰ Q δ)) ⇒ realise .fobj (FCP.coprod (X̂ δ̂') (Ŷ δ̂'))
+    mid = ℰSCm.copair
+            (realise .fmor FCP.in₁ ∘ (fobj-realise-iso P δ' δ̂' js' .fwd ∘ ℰMu.strong-fmor P fs))
+            (realise .fmor FCP.in₂ ∘ (fobj-realise-iso Q δ' δ̂' js' .fwd ∘ ℰMu.strong-fmor Q fs))
+
+
+
+    lhs : fmorη Γ (FCP.coprod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P + Q)) ĝs)
+            ∘co (fobj-realise-iso (P + Q) δ δ̂ js .fwd ∘ ℰP.p₂)
+          ≈ mid
+    lhs =
+      begin
+        fmorη Γ (FCP.coprod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P + Q)) ĝs)
+          ∘co ((K⊕ (X̂ δ̂) (Ŷ δ̂) .bwd ∘ ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd)) ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        fmorη Γ (FCP.coprod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P + Q)) ĝs)
+          ∘co ((K⊕ (X̂ δ̂) (Ŷ δ̂) .bwd ∘ ℰP.p₂) ∘co (ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd) ∘ ℰP.p₂))
+      ≈˘⟨ CoK.assoc _ _ _ ⟩
+        (fmorη Γ (FCP.coprod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P + Q)) ĝs)
+          ∘co (K⊕ (X̂ δ̂) (Ŷ δ̂) .bwd ∘ ℰP.p₂)) ∘co (ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (fmorη-scopair Γ (X̂ δ̂) (Ŷ δ̂) _ _) ⟩
+        ℰSCm.copair (fmorη Γ (X̂ δ̂) (FM.Mor-∘ FCP.in₁ (FMu.strong-fmor (Poly-map η P) ĝs))) (fmorη Γ (Ŷ δ̂) (FM.Mor-∘ FCP.in₂ (FMu.strong-fmor (Poly-map η Q) ĝs)))
+          ∘co (ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd) ∘ ℰP.p₂)
+      ≈⟨ scopair-coprod-m _ _ _ _ ⟩
+        ℰSCm.copair
+          (fmorη Γ (X̂ δ̂) (FM.Mor-∘ FCP.in₁ (FMu.strong-fmor (Poly-map η P) ĝs)) ∘co (fobj-realise-iso P δ δ̂ js .fwd ∘ ℰP.p₂))
+          (fmorη Γ (Ŷ δ̂) (FM.Mor-∘ FCP.in₂ (FMu.strong-fmor (Poly-map η Q) ĝs)) ∘co (fobj-realise-iso Q δ δ̂ js .fwd ∘ ℰP.p₂))
+      ≈⟨ ℰSCm.copair-cong (≈-trans (CoK.∘-cong₁ (fmorη-post Γ (X̂ δ̂) FCP.in₁ _)) (≈-trans (assoc _ _ _) (∘-cong₂ (simP δ δ' δ̂ δ̂' js js' fs ĝs sqs)))) (≈-trans (CoK.∘-cong₁ (fmorη-post Γ (Ŷ δ̂) FCP.in₂ _)) (≈-trans (assoc _ _ _) (∘-cong₂ (simQ δ δ' δ̂ δ̂' js js' fs ĝs sqs)))) ⟩
+        mid
+      ∎ where open ≈-Reasoning isEquiv
+
+
+
+    rhs : fobj-realise-iso (P + Q) δ' δ̂' js' .fwd ∘ ℰMu.strong-fmor (P + Q) fs ≈ mid
+    rhs =
+      ≈-trans (ℰSCm.copair-natural _ _ _)
+        (ℰSCm.copair-cong
+          (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (ℰCoprod.copair-in₁ _ _)) (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (K⊕-in₁ (X̂ δ̂') (Ŷ δ̂'))))))) (assoc _ _ _)))
+          (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (ℰCoprod.copair-in₂ _ _)) (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (K⊕-in₂ (X̂ δ̂') (Ŷ δ̂'))))))) (assoc _ _ _))))
+
+sim-prod : ∀ {n} (P Q : Poly ℰ n) → SimStmt P → SimStmt Q → SimStmt (P × Q)
+sim-prod {n} P Q simP simQ {Γ} δ δ' δ̂ δ̂' js js' fs ĝs sqs =
+  ≈-trans lhs (≈-sym rhs)
+  where
+    X̂ : (Fin n → FM.Obj) → FM.Obj
+    X̂ γ̂ = FM.fobj FM.μObj (Poly-map η P) γ̂
+
+    Ŷ : (Fin n → FM.Obj) → FM.Obj
+    Ŷ γ̂ = FM.fobj FM.μObj (Poly-map η Q) γ̂
+
+    mid : ℰP.prod Γ (ℰP.prod (ℰI.fobj μ-objℰ P δ) (ℰI.fobj μ-objℰ Q δ)) ⇒ realise .fobj (FamP.prod (X̂ δ̂') (Ŷ δ̂'))
+    mid = K× (X̂ δ̂') (Ŷ δ̂') .bwd ∘
+          ℰP.strong-prod-m
+            (fobj-realise-iso P δ' δ̂' js' .fwd ∘ ℰMu.strong-fmor P fs)
+            (fobj-realise-iso Q δ' δ̂' js' .fwd ∘ ℰMu.strong-fmor Q fs)
+
+
+
+    lhs : fmorη Γ (FamP.prod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P × Q)) ĝs)
+            ∘co (fobj-realise-iso (P × Q) δ δ̂ js .fwd ∘ ℰP.p₂)
+          ≈ mid
+    lhs =
+      begin
+        fmorη Γ (FamP.prod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P × Q)) ĝs)
+          ∘co ((K× (X̂ δ̂) (Ŷ δ̂) .bwd ∘ ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd)) ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        fmorη Γ (FamP.prod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P × Q)) ĝs)
+          ∘co ((K× (X̂ δ̂) (Ŷ δ̂) .bwd ∘ ℰP.p₂) ∘co (ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd) ∘ ℰP.p₂))
+      ≈˘⟨ CoK.assoc _ _ _ ⟩
+        (fmorη Γ (FamP.prod (X̂ δ̂) (Ŷ δ̂)) (FMu.strong-fmor (Poly-map η (P × Q)) ĝs)
+          ∘co (K× (X̂ δ̂) (Ŷ δ̂) .bwd ∘ ℰP.p₂)) ∘co (ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (fmorη-sprodm Γ (X̂ δ̂) (Ŷ δ̂) _ _) ⟩
+        (K× (X̂ δ̂') (Ŷ δ̂') .bwd ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂) (FMu.strong-fmor (Poly-map η P) ĝs)) (fmorη Γ (Ŷ δ̂) (FMu.strong-fmor (Poly-map η Q) ĝs)))
+          ∘co (ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd) ∘ ℰP.p₂)
+      ≈⟨ assoc _ _ _ ⟩
+        K× (X̂ δ̂') (Ŷ δ̂') .bwd ∘ (ℰP.strong-prod-m (fmorη Γ (X̂ δ̂) (FMu.strong-fmor (Poly-map η P) ĝs)) (fmorη Γ (Ŷ δ̂) (FMu.strong-fmor (Poly-map η Q) ĝs)) ∘co (ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd) ∘ ℰP.p₂))
+      ≈⟨ ∘-cong₂ (∘-cong₂ (ℰP.pair-cong (≈-sym id-left) ≈-refl)) ⟩
+        K× (X̂ δ̂') (Ŷ δ̂') .bwd ∘ (ℰP.strong-prod-m (fmorη Γ (X̂ δ̂) (FMu.strong-fmor (Poly-map η P) ĝs)) (fmorη Γ (Ŷ δ̂) (FMu.strong-fmor (Poly-map η Q) ĝs)) ∘ ℰP.prod-m (id _) (ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd)))
+      ≈⟨ ∘-cong₂ (ℰP.strong-prod-m-pre _ _ _ _ _) ⟩
+        K× (X̂ δ̂') (Ŷ δ̂') .bwd ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂) (FMu.strong-fmor (Poly-map η P) ĝs) ∘ ℰP.prod-m (id _) (fobj-realise-iso P δ δ̂ js .fwd)) (fmorη Γ (Ŷ δ̂) (FMu.strong-fmor (Poly-map η Q) ĝs) ∘ ℰP.prod-m (id _) (fobj-realise-iso Q δ δ̂ js .fwd))
+      ≈⟨ ∘-cong₂ (ℰP.strong-prod-m-cong (≈-trans (∘-cong₂ (ℰP.pair-cong id-left ≈-refl)) (simP δ δ' δ̂ δ̂' js js' fs ĝs sqs)) (≈-trans (∘-cong₂ (ℰP.pair-cong id-left ≈-refl)) (simQ δ δ' δ̂ δ̂' js js' fs ĝs sqs))) ⟩
+        mid
+      ∎ where open ≈-Reasoning isEquiv
+
+    rhs : fobj-realise-iso (P × Q) δ' δ̂' js' .fwd ∘ ℰMu.strong-fmor (P × Q) fs ≈ mid
+    rhs =
+      ≈-trans (assoc _ _ _)
+        (∘-cong₂ (ℰP.strong-prod-m-post _ _ _ _))
+
+-- A invariance after the interpretation isomorphism fuses into the agreement.
+SI-invariance : ∀ {n} (P : Poly ℰ n) (δ : Fin n → obj) (δ̂ δ̂'' : Fin n → FM.Obj)
+              (js : ∀ i → Iso (δ i) (realise .fobj (δ̂ i)))
+              (isos : ∀ i → Iso (realise .fobj (δ̂ i)) (realise .fobj (δ̂'' i)))
+              (js'' : ∀ i → Iso (δ i) (realise .fobj (δ̂'' i))) →
+              (∀ i → Iso-trans (js i) (isos i) .fwd ≈ js'' i .fwd) →
+              invarianceAt P .iso δ̂ δ̂'' isos .fwd ∘ fobj-realise-iso P δ δ̂ js .fwd
+              ≈ fobj-realise-iso P δ δ̂'' js'' .fwd
+SI-invariance (const A) δ δ̂ δ̂'' js isos js'' pw = id-left
+SI-invariance (var i)   δ δ̂ δ̂'' js isos js'' pw = pw i
+SI-invariance (P + Q)   δ δ̂ δ̂'' js isos js'' pw =
+  begin
+    ((K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰCoprod.coprod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd)) ∘ K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .fwd) ∘ (K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .bwd ∘ ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd))
+  ≈⟨ assoc _ _ _ ⟩
+    (K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰCoprod.coprod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd)) ∘ (K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .fwd ∘ (K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .bwd ∘ ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd)))
+  ≈⟨ ∘-cong₂ (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .fwd∘bwd≈id)) id-left)) ⟩
+    (K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰCoprod.coprod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd)) ∘ ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd)
+  ≈⟨ assoc _ _ _ ⟩
+    K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ (ℰCoprod.coprod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd) ∘ ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd))
+  ≈˘⟨ ∘-cong₂ (ℰCoprod.coprod-m-comp _ _ _ _) ⟩
+    K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰCoprod.coprod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd ∘ fobj-realise-iso P δ δ̂ js .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd ∘ fobj-realise-iso Q δ δ̂ js .fwd)
+  ≈⟨ ∘-cong₂ (ℰCoprod.coprod-m-cong (SI-invariance P δ δ̂ δ̂'' js isos js'' pw) (SI-invariance Q δ δ̂ δ̂'' js isos js'' pw)) ⟩
+    K⊕ (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰCoprod.coprod-m (fobj-realise-iso P δ δ̂'' js'' .fwd) (fobj-realise-iso Q δ δ̂'' js'' .fwd)
+  ∎ where open ≈-Reasoning isEquiv
+SI-invariance (P × Q)   δ δ̂ δ̂'' js isos js'' pw =
+  begin
+    ((K× (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰP.prod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd)) ∘ K× (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .fwd) ∘ (K× (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .bwd ∘ ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd))
+  ≈⟨ assoc _ _ _ ⟩
+    (K× (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰP.prod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd)) ∘ (K× (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .fwd ∘ (K× (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .bwd ∘ ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd)))
+  ≈⟨ ∘-cong₂ (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (K× (FM.fobj FM.μObj (Poly-map η P) δ̂) (FM.fobj FM.μObj (Poly-map η Q) δ̂) .fwd∘bwd≈id)) id-left)) ⟩
+    (K× (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰP.prod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd)) ∘ ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd)
+  ≈⟨ assoc _ _ _ ⟩
+    K× (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ (ℰP.prod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd) ∘ ℰP.prod-m (fobj-realise-iso P δ δ̂ js .fwd) (fobj-realise-iso Q δ δ̂ js .fwd))
+  ≈˘⟨ ∘-cong₂ (ℰP.prod-m-comp _ _ _ _) ⟩
+    K× (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰP.prod-m (invarianceAt P .iso δ̂ δ̂'' isos .fwd ∘ fobj-realise-iso P δ δ̂ js .fwd) (invarianceAt Q .iso δ̂ δ̂'' isos .fwd ∘ fobj-realise-iso Q δ δ̂ js .fwd)
+  ≈⟨ ∘-cong₂ (ℰP.prod-m-cong (SI-invariance P δ δ̂ δ̂'' js isos js'' pw) (SI-invariance Q δ δ̂ δ̂'' js isos js'' pw)) ⟩
+    K× (FM.fobj FM.μObj (Poly-map η P) δ̂'') (FM.fobj FM.μObj (Poly-map η Q) δ̂'') .bwd ∘ ℰP.prod-m (fobj-realise-iso P δ δ̂'' js'' .fwd) (fobj-realise-iso Q δ δ̂'' js'' .fwd)
+  ∎ where open ≈-Reasoning isEquiv
+SI-invariance (μ P)     δ δ̂ δ̂'' js isos js'' pw =
+  ≈-trans (≈-sym (mu-invariance-comp P (invarianceAt P) _ δ̂ δ̂'' _ isos))
+    (invariance-ext (μ P) (invarianceAt (μ P)) _ _ _ _
+      (λ i → ≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (pw i))))
+
+sim-mu : ∀ {n} (P : Poly ℰ (suc n)) → SimStmt P → SimStmt (μ P)
+sim-mu {n} P simP {Γ} δ δ' δ̂ δ̂' js js' fs ĝs sqs =
+  ≈-trans step1 (∘-cong₂ μ-key)
+  where
+    Q̂ = Poly-map η P
+    CP = invarianceAt P
+
+    δ̂η δ̂η' : Fin n → FM.Obj
+    δ̂η  i = η .fobj (δ i)
+    δ̂η' i = η .fobj (δ' i)
+
+    μℰ' = μ-objℰ P δ'
+    μ̂' = FM.μObj Q̂ δ̂η'
+
+    ctfs : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂η i)) (δ̂η' i)
+    ctfs i = ctxη Γ (δ i) (fs i)
+
+    module Mδ = Initiality P δ̂η CP
+    module M' = Initiality P δ̂η' CP
+    module Sd = SμfFold P CP δ̂η δ̂η' ctfs
+
+    sqs' : ∀ i → fmorη Γ (δ̂ i) (ĝs i) ∘co (Iso-trans (realise-η-iso (δ i)) (js i) .fwd ∘ ℰP.p₂)
+                 ≈ Iso-trans (realise-η-iso (δ' i)) (js' i) .fwd ∘ fmorη Γ (δ̂η i) (ctfs i)
+    sqs' i =
+      ≈-trans (CoK.∘-cong₂ (≈-sym (co-pure _ _)))
+        (≈-trans (≈-sym (CoK.assoc _ _ _))
+          (≈-trans (CoK.∘-cong₁ (sqs i))
+            (≈-trans (assoc _ _ _)
+              (≈-trans (∘-cong₂ (∘-cong₂ (ℰP.pair-cong (≈-sym id-left) ≈-refl)))
+                (≈-sym (≈-trans (assoc _ _ _) (∘-cong₂ (ctxη-counit Γ (δ i) (fs i)))))))))
+
+    step1 : fmorη Γ (FM.μObj Q̂ δ̂) (FMu.strong-μ-fmor Q̂ ĝs)
+              ∘co (fobj-realise-iso (μ P) δ δ̂ js .fwd ∘ ℰP.p₂)
+            ≈ fobj-realise-iso (μ P) δ' δ̂' js' .fwd ∘ fmorη Γ (FM.μObj Q̂ δ̂η) (FMu.strong-μ-fmor Q̂ ctfs)
+    step1 =
+      MuNat.mu-natural P CP δ̂η δ̂ δ̂η' δ̂'
+        (λ i → Iso-trans (realise-η-iso (δ i)) (js i))
+        (λ i → Iso-trans (realise-η-iso (δ' i)) (js' i))
+        ctfs ĝs sqs'
+
+    jsE : ∀ i → Iso (extend δ μℰ' i) (realise .fobj (extend δ̂η μ̂' i))
+    jsE Fin.zero    = Iso-refl
+    jsE (Fin.suc i) = Iso-sym (realise-η-iso (δ i))
+
+    jsE' : ∀ i → Iso (extend δ' μℰ' i) (realise .fobj (extend δ̂η' μ̂' i))
+    jsE' Fin.zero    = Iso-refl
+    jsE' (Fin.suc i) = Iso-sym (realise-η-iso (δ' i))
+
+    SIA = fobj-realise-iso P (extend δ μℰ') (extend δ̂η (η .fobj μℰ')) (ηjs δ μℰ')
+    SIμext = fobj-realise-iso P (extend δ' μℰ') (extend δ̂η' (η .fobj μℰ')) (ηjs δ' μℰ')
+    SIE = fobj-realise-iso P (extend δ μℰ') (extend δ̂η μ̂') jsE
+    SIE' = fobj-realise-iso P (extend δ' μℰ') (extend δ̂η' μ̂') jsE'
+
+    sfF = FMu.strong-fmor Q̂ (FMu.strong-extend-mor ctfs FamP.p₂)
+
+    sqsE : ∀ i → fmorη Γ (extend δ̂η μ̂' i) (FMu.strong-extend-mor ctfs FamP.p₂ i) ∘co (jsE i .fwd ∘ ℰP.p₂)
+                 ≈ jsE' i .fwd ∘ ℰMu.strong-extend-mor fs ℰP.p₂ i
+    sqsE Fin.zero    = ≈-trans (CoK.∘-cong₁ (fmorη-p₂ Γ μ̂')) CoK.id-left
+    sqsE (Fin.suc i) = ctxη-counit-sq Γ (δ i) (fs i)
+
+    ihE : fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) sfF ∘co (SIE .fwd ∘ ℰP.p₂)
+          ≈ SIE' .fwd ∘ ℰMu.strong-fmor P (ℰMu.strong-extend-mor fs ℰP.p₂)
+    ihE = simP (extend δ μℰ') (extend δ' μℰ') (extend δ̂η μ̂') (extend δ̂η' μ̂') jsE jsE'
+            (ℰMu.strong-extend-mor fs ℰP.p₂) (FMu.strong-extend-mor ctfs FamP.p₂) sqsE
+
+    fuseA : Sd.KKε .fwd ∘ SIA .fwd ≈ SIE .fwd
+    fuseA =
+      SI-invariance P (extend δ μℰ') (extend δ̂η (η .fobj μℰ')) (extend δ̂η μ̂') (ηjs δ μℰ') Sd.KKisos jsE pw
+      where
+        pw : ∀ i → Iso-trans (ηjs δ μℰ' i) (Sd.KKisos i) .fwd ≈ jsE i .fwd
+        pw Fin.zero    = realise-η-iso μℰ' .fwd∘bwd≈id
+        pw (Fin.suc i) = id-left
+
+    fuseM : CP .iso (extend δ̂η' (η .fobj (Creal P δ̂η'))) (extend δ̂η' μ̂') M'.inIsos .fwd ∘ SIμext .fwd ≈ SIE' .fwd
+    fuseM =
+      SI-invariance P (extend δ' μℰ') (extend δ̂η' (η .fobj μℰ')) (extend δ̂η' μ̂') (ηjs δ' μℰ') M'.inIsos jsE' pw
+      where
+        pw : ∀ i → Iso-trans (ηjs δ' μℰ' i) (M'.inIsos i) .fwd ≈ jsE' i .fwd
+        pw Fin.zero    = realise-η-iso μℰ' .fwd∘bwd≈id
+        pw (Fin.suc i) = id-left
+
+    inR-decomp : M'.inR ∘ SIμext .fwd ≈ realise .fmor (FMu.inMap Q̂ δ̂η') ∘ SIE' .fwd
+    inR-decomp =
+      ≈-trans (∘-cong₁ inRK') (≈-trans (assoc _ _ _) (∘-cong₂ fuseM))
+      where
+        inRK' : M'.inR ≈ realise .fmor (FMu.inMap Q̂ δ̂η') ∘ CP .iso (extend δ̂η' (η .fobj (Creal P δ̂η'))) (extend δ̂η' μ̂') M'.inIsos .fwd
+        inRK' =
+          ≈-sym (≈-trans (∘-cong₁ (inR-K P δ̂η' CP))
+            (≈-trans (assoc _ _ _)
+              (≈-trans (∘-cong₂ (CP .iso _ _ M'.inIsos .bwd∘fwd≈id)) id-right)))
+
+    cancelSIE : SIE .fwd ∘ SIA .bwd ≈ Sd.KKε .fwd
+    cancelSIE =
+      ≈-trans (∘-cong₁ (≈-sym fuseA))
+        (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (SIA .fwd∘bwd≈id)) id-right))
+
+    C : (inMapℰ P δ' ∘ ℰMu.strong-fmor P (ℰMu.strong-extend-mor fs ℰP.p₂)) ∘ ℰP.prod-m (id _) (SIA .bwd) ≈ Sd.aStar
+    C =
+      begin
+        ((M'.inR ∘ SIμext .fwd) ∘ ℰMu.strong-fmor P (ℰMu.strong-extend-mor fs ℰP.p₂)) ∘ ℰP.prod-m (id _) (SIA .bwd)
+      ≈⟨ ∘-cong₁ (∘-cong₁ inR-decomp) ⟩
+        ((realise .fmor (FMu.inMap Q̂ δ̂η') ∘ SIE' .fwd) ∘ ℰMu.strong-fmor P (ℰMu.strong-extend-mor fs ℰP.p₂)) ∘ ℰP.prod-m (id _) (SIA .bwd)
+      ≈⟨ ∘-cong₁ (assoc _ _ _) ⟩
+        (realise .fmor (FMu.inMap Q̂ δ̂η') ∘ (SIE' .fwd ∘ ℰMu.strong-fmor P (ℰMu.strong-extend-mor fs ℰP.p₂))) ∘ ℰP.prod-m (id _) (SIA .bwd)
+      ≈˘⟨ ∘-cong₁ (∘-cong₂ ihE) ⟩
+        (realise .fmor (FMu.inMap Q̂ δ̂η') ∘ (fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) sfF ∘co (SIE .fwd ∘ ℰP.p₂))) ∘ ℰP.prod-m (id _) (SIA .bwd)
+      ≈˘⟨ ∘-cong₁ (assoc _ _ _) ⟩
+        ((realise .fmor (FMu.inMap Q̂ δ̂η') ∘ fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) sfF) ∘co (SIE .fwd ∘ ℰP.p₂)) ∘ ℰP.prod-m (id _) (SIA .bwd)
+      ≈⟨ assoc _ _ _ ⟩
+        (realise .fmor (FMu.inMap Q̂ δ̂η') ∘ fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) sfF) ∘ (ℰP.pair ℰP.p₁ (SIE .fwd ∘ ℰP.p₂) ∘ ℰP.prod-m (id _) (SIA .bwd))
+      ≈⟨ ∘-cong₂ (ℰP.pair-natural _ _ _) ⟩
+        (realise .fmor (FMu.inMap Q̂ δ̂η') ∘ fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) sfF) ∘ ℰP.pair (ℰP.p₁ ∘ ℰP.prod-m (id _) (SIA .bwd)) ((SIE .fwd ∘ ℰP.p₂) ∘ ℰP.prod-m (id _) (SIA .bwd))
+      ≈⟨ ∘-cong₂ (ℰP.pair-cong (≈-trans (ℰP.pair-p₁ _ _) id-left) (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (ℰP.pair-p₂ _ _)) (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ cancelSIE))))) ⟩
+        (realise .fmor (FMu.inMap Q̂ δ̂η') ∘ fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) sfF) ∘co (Sd.KKε .fwd ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₁ (fmorη-post Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) (FMu.inMap Q̂ δ̂η') sfF) ⟩
+        fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂η μ̂')) (FM.Mor-∘ (FMu.inMap Q̂ δ̂η') sfF) ∘co (Sd.KKε .fwd ∘ ℰP.p₂)
+      ∎
+      where
+        open ≈-Reasoning isEquiv
+
+
+
+    μ-key : fmorη Γ (FM.μObj Q̂ δ̂η) (FMu.strong-μ-fmor Q̂ ctfs) ≈ ℰMu.strong-fmor (μ P) fs
+    μ-key = ≈-trans Sd.sμf-fold (Mδ.foldR-cong (≈-sym C))
+
+-- The simulation, tied over all polynomials.
+sim : ∀ {n} (P : Poly ℰ n) → SimStmt P
+sim (const A) = sim-const A
+sim (var i)   = sim-var i
+sim (P + Q)   = sim-sum P Q (sim P) (sim Q)
+sim (P × Q)   = sim-prod P Q (sim P) (sim Q)
+sim (μ P)     = sim-mu P (sim P)
+
+-- The initiality laws for ℰ: the β and η laws of the Fam(ℰ) fold, conjugated
+-- through the interpretation isomorphism by the simulation.
+private
+  module ⦅⦆Laws {n} {Γ A : obj} {P : Poly ℰ (suc n)} {δ : Fin n → obj}
+      (alg : ℰP.prod Γ (ℰI.fobj μ-objℰ P (extend δ A)) ⇒ A)
+    where
+
+    δ̂η : Fin n → FM.Obj
+    δ̂η i = η .fobj (δ i)
+
+    module M = Initiality P δ̂η (invarianceAt P)
+
+    μℰ = μ-objℰ P δ
+    SIμ = fobj-realise-iso P (extend δ μℰ) (extend δ̂η (η .fobj μℰ)) (ηjs δ μℰ)
+    SIA = fobj-realise-iso P (extend δ A) (extend δ̂η (η .fobj A)) (ηjs δ A)
+
+    a : ℰP.prod Γ (Greal P δ̂η A) ⇒ A
+    a = alg ∘ ℰP.prod-m (id _) (SIA .bwd)
+
+    -- The realised strong action of a fold candidate simulates ℰ's action at
+    -- the extended environments.
+    GM : (h : ℰP.prod Γ μℰ ⇒ A) →
+         Gmap P δ̂η h ∘co (SIμ .fwd ∘ ℰP.p₂)
+         ≈ SIA .fwd ∘ ℰMu.strong-fmor P (ℰMu.strong-extend-mor (λ i → ℰP.p₂) h)
+    GM h =
+      sim P (extend δ μℰ) (extend δ A) (extend δ̂η (η .fobj μℰ)) (extend δ̂η (η .fobj A))
+        (ηjs δ μℰ) (ηjs δ A)
+        (ℰMu.strong-extend-mor (λ i → ℰP.p₂) h)
+        (FMu.strong-extend-mor (λ i → FamP.p₂) (ctxη Γ μℰ h))
+        sqs
+      where
+        sqs : ∀ i → fmorη Γ (extend δ̂η (η .fobj μℰ) i) (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ μℰ h) i) ∘co (ηjs δ μℰ i .fwd ∘ ℰP.p₂)
+                    ≈ ηjs δ A i .fwd ∘ ℰMu.strong-extend-mor (λ j → ℰP.p₂) h i
+        sqs Fin.zero    = ctxη-counit-sq Γ μℰ h
+        sqs (Fin.suc i) = ≈-trans (CoK.∘-cong₁ (fmorη-p₂ Γ (η .fobj (δ i)))) CoK.id-left
+
+    -- The corrected algebra absorbs the interpretation isomorphism.
+    absorb-a : ∀ {W : obj} (X : ℰP.prod Γ W ⇒ ℰI.fobj μ-objℰ P (extend δ A)) →
+               a ∘co (SIA .fwd ∘ X) ≈ alg ∘co X
+    absorb-a X =
+      ≈-trans (assoc _ _ _)
+        (∘-cong₂ (≈-trans (ℰP.pair-compose _ _ _ _)
+          (ℰP.pair-cong id-left
+            (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (SIA .bwd∘fwd≈id)) id-left)))))
+
+    β : ⦅⦆ℰ {P = P} {δ = δ} alg ∘co (inMapℰ P δ ∘ ℰP.p₂)
+        ≈ alg ∘co ℰMu.strong-fmor P (ℰMu.strong-extend-mor (λ i → ℰP.p₂) (⦅⦆ℰ {P = P} {δ = δ} alg))
+    β =
+      ≈-trans (CoK.∘-cong₂ (≈-sym (co-pure _ _)))
+        (≈-trans (≈-sym (CoK.assoc _ _ _))
+          (≈-trans (CoK.∘-cong₁ (M.foldR-β a))
+            (≈-trans (CoK.assoc _ _ _)
+              (≈-trans (CoK.∘-cong₂ (GM (M.foldR a)))
+                (absorb-a _)))))
+
+    η' : (h : ℰP.prod Γ (μ-objℰ P δ) ⇒ A) →
+         h ∘co (inMapℰ P δ ∘ ℰP.p₂) ≈ alg ∘co ℰMu.strong-fmor P (ℰMu.strong-extend-mor (λ i → ℰP.p₂) h) →
+         h ≈ ⦅⦆ℰ {P = P} {δ = δ} alg
+    η' h hyp = M.foldR-η a h sq
+      where
+        inR-split : M.inR ≈ inMapℰ P δ ∘ SIμ .bwd
+        inR-split =
+          ≈-sym (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (SIμ .fwd∘bwd≈id)) id-right))
+
+        sq : h ∘co (M.inR ∘ ℰP.p₂) ≈ a ∘co Gmap P δ̂η h
+        sq =
+          ≈-trans (CoK.∘-cong₂ (∘-cong₁ inR-split))
+            (≈-trans (CoK.∘-cong₂ (≈-sym (co-pure _ _)))
+              (≈-trans (≈-sym (CoK.assoc _ _ _))
+                (≈-trans (CoK.∘-cong₁ hyp)
+                  (≈-sym
+                    (≈-trans (CoK.∘-cong₂ (≈-sym (co-iso-cancel SIμ (GM h))))
+                      (≈-trans (≈-sym (CoK.assoc _ _ _))
+                        (CoK.∘-cong₁ (absorb-a _))))))))
+
+-- ℰ satisfies the initiality laws.
+MuLawsℰ : ℰI.HasMuLaws Muℰ
+MuLawsℰ .ℰI.HasMuLaws.⦅⦆-β = ⦅⦆Laws.β
+MuLawsℰ .ℰI.HasMuLaws.⦅⦆-η alg = ⦅⦆Laws.η' alg
diff --git a/agda/src/fam-mu-realisation/context.agda b/agda/src/fam-mu-realisation/context.agda
new file mode 100644
index 00000000..0f5f5a16
--- /dev/null
+++ b/agda/src/fam-mu-realisation/context.agda
@@ -0,0 +1,540 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- The co-Kleisli context calculus of realisation: objects and actions of
+-- the realised polynomial endofunctor, realisation of morphisms in an
+-- η-embedded context, and the in-context isomorphism algebra.
+
+open import Level using (Level; _⊔_)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import prop-setoid using (Setoid; module ≈-Reasoning)
+open import categories
+  using (Category; setoid→category; HasTerminal; HasProducts; HasExponentials;
+         HasStrongCoproducts; HasCoproducts; strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor; HasColimits)
+open import polynomial-functor using (Poly; extend; Poly-map)
+import fam
+import fam-mu-types
+import fam-realisation
+import polynomial-functor
+
+module fam-mu-realisation.context {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os (os ⊔ es)) → HasColimits (setoid→category A) ℰ)
+  (ℰT : HasTerminal ℰ) (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP)
+  (ℰSC : HasStrongCoproducts ℰ ℰP)
+  where
+
+open Category ℰ public
+open Functor public
+open Iso public
+open Poly public
+
+module ℰP = HasProducts ℰP
+module ℰT' = HasTerminal ℰT
+
+module FR = fam-realisation os (os ⊔ es) ℰC
+open FR using (realise; η; realise-η-iso; transpose; untranspose) public
+
+module FM = fam-mu-types os es ℰT ℰP
+module FamP = FM.Fam𝒞-P
+
+module FMu = FM.HasMu FM.hasMu
+module FamC = Category FM.cat
+module FamCoK {Γ̂ : FM.Obj} = Category (coKleisli-prod FM.products Γ̂)
+module FMuI = polynomial-functor.MuIso (FM.terminal ℰT) FM.products FM.strongCoproducts FM.hasMu FM.hasMuLaws
+
+module ℰI = polynomial-functor.Interp ℰT ℰP ℰSC
+open ℰI using (_∘co_) public
+
+module CoK {Γ : obj} = Category (coKleisli-prod ℰP Γ)
+
+-- The realised μ-carrier of the η-image polynomial.
+Creal : ∀ {n} → Poly ℰ (suc n) → (Fin n → FM.Obj) → obj
+Creal P δ̂ = realise .fobj (FM.μObj (Poly-map η P) δ̂)
+
+-- The realised polynomial endofunctor, object part: apply the η-image
+-- polynomial with A embedded at the bound variable, and realise.
+Greal : ∀ {n} → Poly ℰ (suc n) → (Fin n → FM.Obj) → obj → obj
+Greal P δ̂ A = realise .fobj (FM.fobj FM.μObj (Poly-map η P) (extend δ̂ (η .fobj A)))
+
+-- A Fam(ℰ)-product with an η-embedded context realises to the ℰ-product.
+prodη : ∀ (Γ : obj) (W : FM.Obj) →
+        Iso (realise .fobj (FamP.prod (η .fobj Γ) W)) (ℰP.prod Γ (realise .fobj W))
+prodη Γ W =
+  Iso-trans (FR.realise-products-iso ℰP ℰE (η .fobj Γ) W)
+    (ℰP.product-preserves-iso (realise-η-iso Γ) Iso-refl)
+
+-- The co-Kleisli action of realisation: a Fam(ℰ)-morphism from a product with
+-- an η-embedded context acts on realisations in that context.
+fmorη : ∀ (Γ : obj) (X : FM.Obj) {Y : FM.Obj} →
+        FM.Mor (FamP.prod (η .fobj Γ) X) Y → ℰP.prod Γ (realise .fobj X) ⇒ realise .fobj Y
+fmorη Γ X u = realise .fmor u ∘ prodη Γ X .bwd
+
+fmorη-cong : ∀ {Γ X Y} {u₁ u₂ : FM.Mor (FamP.prod (η .fobj Γ) X) Y} →
+             FamC._≈_ u₁ u₂ → fmorη Γ X u₁ ≈ fmorη Γ X u₂
+fmorη-cong u₁≃u₂ = ∘-cong₁ (realise .fmor-cong u₁≃u₂)
+
+-- Pair a context-preserving morphism with the context projection, with the
+-- projection pinned (prod is not injective, so it cannot be inferred).
+pairη : ∀ (Γ : obj) (X : FM.Obj) {Y : FM.Obj} →
+        FM.Mor (FamP.prod (η .fobj Γ) X) Y →
+        FM.Mor (FamP.prod (η .fobj Γ) X) (FamP.prod (η .fobj Γ) Y)
+pairη Γ X v = FamP.pair (FamP.p₁ {x = η .fobj Γ} {y = X}) v
+
+-- The bridging iso commutes with the product projections.
+prodη-p₁ : ∀ (Γ : obj) (X : FM.Obj) →
+           ℰP.p₁ ∘ prodη Γ X .fwd ≈ realise-η-iso Γ .fwd ∘ realise .fmor FamP.p₁
+prodη-p₁ Γ X =
+  begin
+    ℰP.p₁ ∘ (ℰP.prod-m (realise-η-iso Γ .fwd) (id _) ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd)
+  ≈˘⟨ assoc _ _ _ ⟩
+    (ℰP.p₁ ∘ ℰP.prod-m (realise-η-iso Γ .fwd) (id _)) ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd
+  ≈⟨ ∘-cong₁ (ℰP.pair-p₁ _ _) ⟩
+    (realise-η-iso Γ .fwd ∘ ℰP.p₁) ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd
+  ≈⟨ assoc _ _ _ ⟩
+    realise-η-iso Γ .fwd ∘ (ℰP.p₁ ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd)
+  ≈⟨ ∘-cong₂ (FR.realise-products-p₁ ℰP ℰE (η .fobj Γ) X) ⟩
+    realise-η-iso Γ .fwd ∘ realise .fmor FamP.p₁
+  ∎ where open ≈-Reasoning isEquiv
+
+prodη-p₂ : ∀ (Γ : obj) (X : FM.Obj) →
+           ℰP.p₂ ∘ prodη Γ X .fwd ≈ realise .fmor FamP.p₂
+prodη-p₂ Γ X =
+  begin
+    ℰP.p₂ ∘ (ℰP.prod-m (realise-η-iso Γ .fwd) (id _) ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd)
+  ≈˘⟨ assoc _ _ _ ⟩
+    (ℰP.p₂ ∘ ℰP.prod-m (realise-η-iso Γ .fwd) (id _)) ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd
+  ≈⟨ ∘-cong₁ (ℰP.pair-p₂ _ _) ⟩
+    (id _ ∘ ℰP.p₂) ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd
+  ≈⟨ ∘-cong₁ id-left ⟩
+    ℰP.p₂ ∘ FR.realise-products-iso ℰP ℰE (η .fobj Γ) X .fwd
+  ≈⟨ FR.realise-products-p₂ ℰP ℰE (η .fobj Γ) X ⟩
+    realise .fmor FamP.p₂
+  ∎ where open ≈-Reasoning isEquiv
+
+-- Realisation of a context-preserving pair against the bridging iso.
+prodη-pair : ∀ (Γ : obj) (X : FM.Obj) {Y : FM.Obj} (v : FM.Mor (FamP.prod (η .fobj Γ) X) Y) →
+             realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd
+             ≈ prodη Γ Y .bwd ∘ ℰP.pair (ℰP.p₁ {Γ} {realise .fobj X}) (fmorη Γ X v)
+prodη-pair Γ X {Y} v =
+  ≈-trans (≈-sym id-left)
+    (≈-trans (∘-cong₁ (≈-sym (prodη Γ Y .bwd∘fwd≈id)))
+      (≈-trans (assoc _ _ _) (∘-cong₂ core)))
+  where
+    core : prodη Γ Y .fwd ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd)
+           ≈ ℰP.pair (ℰP.p₁ {Γ} {realise .fobj X}) (fmorη Γ X v)
+    core =
+      ≈-trans (≈-sym (ℰP.pair-ext {y = Γ} {z = realise .fobj Y} _)) (ℰP.pair-cong core-p₁ core-p₂)
+      where
+        core-p₁ : ℰP.p₁ {Γ} {realise .fobj Y} ∘ (prodη Γ Y .fwd ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd))
+                  ≈ ℰP.p₁ {Γ} {realise .fobj X}
+        core-p₁ =
+          begin
+            ℰP.p₁ {Γ} {realise .fobj Y} ∘ (prodη Γ Y .fwd ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd))
+          ≈˘⟨ assoc _ _ _ ⟩
+            (ℰP.p₁ {Γ} {realise .fobj Y} ∘ prodη Γ Y .fwd) ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd)
+          ≈⟨ ∘-cong₁ (prodη-p₁ Γ Y) ⟩
+            (realise-η-iso Γ .fwd ∘ realise .fmor FamP.p₁) ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd)
+          ≈⟨ assoc _ _ _ ⟩
+            realise-η-iso Γ .fwd ∘ (realise .fmor FamP.p₁ ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd))
+          ≈˘⟨ ∘-cong₂ (assoc _ _ _) ⟩
+            realise-η-iso Γ .fwd ∘ ((realise .fmor FamP.p₁ ∘ realise .fmor (pairη Γ X v)) ∘ prodη Γ X .bwd)
+          ≈˘⟨ ∘-cong₂ (∘-cong₁ (realise .fmor-comp _ _)) ⟩
+            realise-η-iso Γ .fwd ∘ (realise .fmor (FM.Mor-∘ FamP.p₁ (pairη Γ X v)) ∘ prodη Γ X .bwd)
+          ≈⟨ ∘-cong₂ (∘-cong₁ (realise .fmor-cong (FamP.pair-p₁ _ _))) ⟩
+            realise-η-iso Γ .fwd ∘ (realise .fmor (FamP.p₁ {x = η .fobj Γ} {y = X}) ∘ prodη Γ X .bwd)
+          ≈˘⟨ assoc _ _ _ ⟩
+            (realise-η-iso Γ .fwd ∘ realise .fmor (FamP.p₁ {x = η .fobj Γ} {y = X})) ∘ prodη Γ X .bwd
+          ≈˘⟨ ∘-cong₁ (prodη-p₁ Γ X) ⟩
+            (ℰP.p₁ {Γ} {realise .fobj X} ∘ prodη Γ X .fwd) ∘ prodη Γ X .bwd
+          ≈⟨ assoc _ _ _ ⟩
+            ℰP.p₁ {Γ} {realise .fobj X} ∘ (prodη Γ X .fwd ∘ prodη Γ X .bwd)
+          ≈⟨ ∘-cong₂ (prodη Γ X .fwd∘bwd≈id) ⟩
+            ℰP.p₁ {Γ} {realise .fobj X} ∘ id _
+          ≈⟨ id-right ⟩
+            ℰP.p₁ {Γ} {realise .fobj X}
+          ∎ where open ≈-Reasoning isEquiv
+
+        core-p₂ : ℰP.p₂ {Γ} {realise .fobj Y} ∘ (prodη Γ Y .fwd ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd))
+                  ≈ fmorη Γ X v
+        core-p₂ =
+          begin
+            ℰP.p₂ {Γ} {realise .fobj Y} ∘ (prodη Γ Y .fwd ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd))
+          ≈˘⟨ assoc _ _ _ ⟩
+            (ℰP.p₂ {Γ} {realise .fobj Y} ∘ prodη Γ Y .fwd) ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd)
+          ≈⟨ ∘-cong₁ (prodη-p₂ Γ Y) ⟩
+            realise .fmor FamP.p₂ ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd)
+          ≈˘⟨ assoc _ _ _ ⟩
+            (realise .fmor FamP.p₂ ∘ realise .fmor (pairη Γ X v)) ∘ prodη Γ X .bwd
+          ≈˘⟨ ∘-cong₁ (realise .fmor-comp _ _) ⟩
+            realise .fmor (FM.Mor-∘ FamP.p₂ (pairη Γ X v)) ∘ prodη Γ X .bwd
+          ≈⟨ ∘-cong₁ (realise .fmor-cong (FamP.pair-p₂ _ _)) ⟩
+            realise .fmor v ∘ prodη Γ X .bwd
+          ∎ where open ≈-Reasoning isEquiv
+
+-- Realisation is a co-Kleisli functor: it sends composition in context over
+-- Fam(ℰ) to composition in context over ℰ.
+fmorη-∘co : ∀ (Γ : obj) (X : FM.Obj) {Y Z : FM.Obj}
+            (u : FM.Mor (FamP.prod (η .fobj Γ) Y) Z)
+            (v : FM.Mor (FamP.prod (η .fobj Γ) X) Y) →
+            fmorη Γ X (FM.Mor-∘ u (pairη Γ X v)) ≈ fmorη Γ Y u ∘co fmorη Γ X v
+fmorη-∘co Γ X {Y} {Z} u v =
+  begin
+    realise .fmor (FM.Mor-∘ u (pairη Γ X v)) ∘ prodη Γ X .bwd
+  ≈⟨ ∘-cong₁ (realise .fmor-comp _ _) ⟩
+    (realise .fmor u ∘ realise .fmor (pairη Γ X v)) ∘ prodη Γ X .bwd
+  ≈⟨ assoc _ _ _ ⟩
+    realise .fmor u ∘ (realise .fmor (pairη Γ X v) ∘ prodη Γ X .bwd)
+  ≈⟨ ∘-cong₂ (prodη-pair Γ X v) ⟩
+    realise .fmor u ∘ (prodη Γ Y .bwd ∘ ℰP.pair (ℰP.p₁ {Γ} {realise .fobj X}) (fmorη Γ X v))
+  ≈˘⟨ assoc _ _ _ ⟩
+    (realise .fmor u ∘ prodη Γ Y .bwd) ∘ ℰP.pair (ℰP.p₁ {Γ} {realise .fobj X}) (fmorη Γ X v)
+  ∎ where open ≈-Reasoning isEquiv
+
+-- The context projection realises to the projection.
+fmorη-p₂ : ∀ (Γ : obj) (X : FM.Obj) →
+           fmorη Γ X (FamP.p₂ {x = η .fobj Γ} {y = X}) ≈ ℰP.p₂
+fmorη-p₂ Γ X =
+  begin
+    realise .fmor (FamP.p₂ {x = η .fobj Γ} {y = X}) ∘ prodη Γ X .bwd
+  ≈˘⟨ ∘-cong₁ (prodη-p₂ Γ X) ⟩
+    (ℰP.p₂ ∘ prodη Γ X .fwd) ∘ prodη Γ X .bwd
+  ≈⟨ assoc _ _ _ ⟩
+    ℰP.p₂ ∘ (prodη Γ X .fwd ∘ prodη Γ X .bwd)
+  ≈⟨ ∘-cong₂ (prodη Γ X .fwd∘bwd≈id) ⟩
+    ℰP.p₂ ∘ id _
+  ≈⟨ id-right ⟩
+    ℰP.p₂
+  ∎ where open ≈-Reasoning isEquiv
+
+-- A pure Fam(ℰ)-morphism precomposed with the projection realises purely.
+fmorη-pure : ∀ (Γ : obj) (X : FM.Obj) {Y : FM.Obj} (w : FM.Mor X Y) →
+             fmorη Γ X (FM.Mor-∘ w (FamP.p₂ {x = η .fobj Γ} {y = X}))
+             ≈ realise .fmor w ∘ ℰP.p₂
+fmorη-pure Γ X w =
+  begin
+    realise .fmor (FM.Mor-∘ w (FamP.p₂ {x = η .fobj Γ} {y = X})) ∘ prodη Γ X .bwd
+  ≈⟨ ∘-cong₁ (realise .fmor-comp _ _) ⟩
+    (realise .fmor w ∘ realise .fmor (FamP.p₂ {x = η .fobj Γ} {y = X})) ∘ prodη Γ X .bwd
+  ≈⟨ assoc _ _ _ ⟩
+    realise .fmor w ∘ (realise .fmor (FamP.p₂ {x = η .fobj Γ} {y = X}) ∘ prodη Γ X .bwd)
+  ≈⟨ ∘-cong₂ (fmorη-p₂ Γ X) ⟩
+    realise .fmor w ∘ ℰP.p₂
+  ∎ where open ≈-Reasoning isEquiv
+
+-- Realising an untransposed morphism and collapsing the target recovers it.
+counit-fmorη : ∀ (Γ : obj) (X : FM.Obj) {A : obj}
+               (g : realise .fobj (FamP.prod (η .fobj Γ) X) ⇒ A) →
+               realise-η-iso A .fwd ∘ fmorη Γ X (untranspose g)
+               ≈ g ∘ prodη Γ X .bwd
+counit-fmorη Γ X {A} g =
+  begin
+    realise-η-iso A .fwd ∘ (realise .fmor (untranspose g) ∘ prodη Γ X .bwd)
+  ≈˘⟨ assoc _ _ _ ⟩
+    (realise-η-iso A .fwd ∘ realise .fmor (untranspose g)) ∘ prodη Γ X .bwd
+  ≈˘⟨ ∘-cong₁ (FR.transpose-realise (untranspose g)) ⟩
+    transpose (untranspose g) ∘ prodη Γ X .bwd
+  ≈⟨ ∘-cong₁ (FR.transpose-untranspose g) ⟩
+    g ∘ prodη Γ X .bwd
+  ∎ where open ≈-Reasoning isEquiv
+
+-- Composition in context of pure morphisms.
+co-pure : ∀ {Γ X Y Z : obj} (x : Y ⇒ Z) (y : X ⇒ Y) →
+          (x ∘ ℰP.p₂ {Γ} {Y}) ∘co (y ∘ ℰP.p₂) ≈ (x ∘ y) ∘ ℰP.p₂
+co-pure x y =
+  ≈-trans (assoc _ _ _)
+    (≈-trans (∘-cong₂ (ℰP.pair-p₂ _ _)) (≈-sym (assoc _ _ _)))
+
+-- Cancel an isomorphism applied in context on the right of a composition.
+co-iso-cancel : ∀ {Γ X Y Z : obj} (I : Iso X Y)
+                {u : ℰP.prod Γ Y ⇒ Z} {v : ℰP.prod Γ X ⇒ Z} →
+                u ∘co (I .fwd ∘ ℰP.p₂) ≈ v → v ∘co (I .bwd ∘ ℰP.p₂) ≈ u
+co-iso-cancel I {u} {v} eq =
+  begin
+    v ∘co (I .bwd ∘ ℰP.p₂)
+  ≈˘⟨ CoK.∘-cong₁ eq ⟩
+    (u ∘co (I .fwd ∘ ℰP.p₂)) ∘co (I .bwd ∘ ℰP.p₂)
+  ≈⟨ CoK.assoc _ _ _ ⟩
+    u ∘co ((I .fwd ∘ ℰP.p₂) ∘co (I .bwd ∘ ℰP.p₂))
+  ≈⟨ CoK.∘-cong₂ (co-pure (I .fwd) (I .bwd)) ⟩
+    u ∘co ((I .fwd ∘ I .bwd) ∘ ℰP.p₂)
+  ≈⟨ CoK.∘-cong₂ (∘-cong₁ (I .fwd∘bwd≈id)) ⟩
+    u ∘co (id _ ∘ ℰP.p₂)
+  ≈⟨ CoK.∘-cong₂ id-left ⟩
+    u ∘co ℰP.p₂
+  ≈⟨ CoK.id-right ⟩
+    u
+  ∎ where open ≈-Reasoning isEquiv
+
+-- Move an isomorphism across an equation.
+iso-shuffle : ∀ {X Y Z : obj} (I : Iso Y Z) (f : X ⇒ Y) (g : X ⇒ Z) →
+              I .fwd ∘ f ≈ g → f ≈ I .bwd ∘ g
+iso-shuffle I f g eq =
+  ≈-trans (≈-sym id-left)
+    (≈-trans (∘-cong₁ (≈-sym (I .bwd∘fwd≈id)))
+      (≈-trans (assoc _ _ _) (∘-cong₂ eq)))
+
+-- Realisation in context is injective on morphisms into embedded objects.
+fmorη-inj : ∀ (Γ : obj) (X : FM.Obj) {A : obj}
+            (u v : FM.Mor (FamP.prod (η .fobj Γ) X) (η .fobj A)) →
+            fmorη Γ X u ≈ fmorη Γ X v → FamC._≈_ u v
+fmorη-inj Γ X {A} u v eq =
+  FM.≃-isEquivalence .prop-setoid.IsEquivalence.trans
+    (FM.≃-isEquivalence .prop-setoid.IsEquivalence.sym (FR.untranspose-transpose u))
+    (FM.≃-isEquivalence .prop-setoid.IsEquivalence.trans
+      (FR.untranspose-cong tr-eq)
+      (FR.untranspose-transpose v))
+  where
+    real-eq : realise .fmor u ≈ realise .fmor v
+    real-eq =
+      begin
+        realise .fmor u
+      ≈˘⟨ id-right ⟩
+        realise .fmor u ∘ id _
+      ≈˘⟨ ∘-cong₂ (prodη Γ X .bwd∘fwd≈id) ⟩
+        realise .fmor u ∘ (prodη Γ X .bwd ∘ prodη Γ X .fwd)
+      ≈˘⟨ assoc _ _ _ ⟩
+        fmorη Γ X u ∘ prodη Γ X .fwd
+      ≈⟨ ∘-cong₁ eq ⟩
+        fmorη Γ X v ∘ prodη Γ X .fwd
+      ≈⟨ assoc _ _ _ ⟩
+        realise .fmor v ∘ (prodη Γ X .bwd ∘ prodη Γ X .fwd)
+      ≈⟨ ∘-cong₂ (prodη Γ X .bwd∘fwd≈id) ⟩
+        realise .fmor v ∘ id _
+      ≈⟨ id-right ⟩
+        realise .fmor v
+      ∎ where open ≈-Reasoning isEquiv
+
+    tr-eq : transpose u ≈ transpose v
+    tr-eq =
+      ≈-trans (FR.transpose-realise u)
+        (≈-trans (∘-cong₂ real-eq) (≈-sym (FR.transpose-realise v)))
+
+-- The pairing of the projections is the identity.
+pair-p₁p₂-id : ∀ {Γ A : obj} → ℰP.pair (ℰP.p₁ {Γ} {A}) ℰP.p₂ ≈ id _
+pair-p₁p₂-id =
+  ≈-trans (ℰP.pair-cong (≈-sym id-right) (≈-sym id-right)) (ℰP.pair-ext (id _))
+
+-- Move an isomorphism across an equation, and cancel one.
+iso-mono : ∀ {X Y Z : obj} (I : Iso Y Z) {f g : X ⇒ Y} →
+           I .fwd ∘ f ≈ I .fwd ∘ g → f ≈ g
+iso-mono I {f} {g} eq =
+  ≈-trans (iso-shuffle I _ _ eq)
+    (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (I .bwd∘fwd≈id)) id-left))
+
+-- Realising a morphism transposed to Fam(ℰ) and collapsing recovers it.
+absorb : ∀ {Γ A : obj} (X : FM.Obj) (g : ℰP.prod Γ (realise .fobj X) ⇒ A) →
+         realise-η-iso A .fwd ∘ fmorη Γ X (untranspose (g ∘ prodη Γ X .fwd)) ≈ g
+absorb {Γ} {A} X g =
+  ≈-trans (counit-fmorη Γ X _)
+    (≈-trans (assoc _ _ _)
+      (≈-trans (∘-cong₂ (prodη Γ X .fwd∘bwd≈id)) id-right))
+
+-- Transpose a context morphism between plain objects into Fam(ℰ), correcting
+-- the domain by the counit.
+ctxη : ∀ (Γ A₀ : obj) {A : obj} → (ℰP.prod Γ A₀ ⇒ A) →
+       FM.Mor (FamP.prod (η .fobj Γ) (η .fobj A₀)) (η .fobj A)
+ctxη Γ A₀ h = untranspose
+  (h ∘ (ℰP.prod-m (id _) (realise-η-iso A₀ .fwd) ∘ prodη Γ (η .fobj A₀) .fwd))
+
+ctxη-counit : ∀ (Γ A₀ : obj) {A : obj} (h : ℰP.prod Γ A₀ ⇒ A) →
+              realise-η-iso A .fwd ∘ fmorη Γ (η .fobj A₀) (ctxη Γ A₀ h)
+              ≈ h ∘ ℰP.prod-m (id _) (realise-η-iso A₀ .fwd)
+ctxη-counit Γ A₀ {A} h =
+  ≈-trans (∘-cong₂ (fmorη-cong (FR.untranspose-cong (≈-sym (assoc _ _ _)))))
+    (≈-trans (absorb (η .fobj A₀) (h ∘ ℰP.prod-m (id _) (realise-η-iso A₀ .fwd))) ≈-refl)
+
+-- The transposed context morphism against the counit inverses.
+ctxη-counit-sq : ∀ (Γ A₀ : obj) {A : obj} (h : ℰP.prod Γ A₀ ⇒ A) →
+                 fmorη Γ (η .fobj A₀) (ctxη Γ A₀ h) ∘co (realise-η-iso A₀ .bwd ∘ ℰP.p₂)
+                 ≈ realise-η-iso A .bwd ∘ h
+ctxη-counit-sq Γ A₀ {A} h =
+  begin
+    fmorη Γ (η .fobj A₀) (ctxη Γ A₀ h) ∘co (realise-η-iso A₀ .bwd ∘ ℰP.p₂)
+  ≈⟨ CoK.∘-cong₁ (iso-shuffle (realise-η-iso A) _ _ (ctxη-counit Γ A₀ h)) ⟩
+    (realise-η-iso A .bwd ∘ (h ∘ ℰP.prod-m (id _) (realise-η-iso A₀ .fwd))) ∘co (realise-η-iso A₀ .bwd ∘ ℰP.p₂)
+  ≈⟨ assoc _ _ _ ⟩
+    realise-η-iso A .bwd ∘ ((h ∘ ℰP.prod-m (id _) (realise-η-iso A₀ .fwd)) ∘ ℰP.pair ℰP.p₁ (realise-η-iso A₀ .bwd ∘ ℰP.p₂))
+  ≈⟨ ∘-cong₂ (assoc _ _ _) ⟩
+    realise-η-iso A .bwd ∘ (h ∘ (ℰP.prod-m (id _) (realise-η-iso A₀ .fwd) ∘ ℰP.pair ℰP.p₁ (realise-η-iso A₀ .bwd ∘ ℰP.p₂)))
+  ≈⟨ ∘-cong₂ (∘-cong₂ (ℰP.pair-compose _ _ _ _)) ⟩
+    realise-η-iso A .bwd ∘ (h ∘ ℰP.pair (id _ ∘ ℰP.p₁) (realise-η-iso A₀ .fwd ∘ (realise-η-iso A₀ .bwd ∘ ℰP.p₂)))
+  ≈⟨ ∘-cong₂ (∘-cong₂ (ℰP.pair-cong id-left (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (realise-η-iso A₀ .fwd∘bwd≈id)) id-left)))) ⟩
+    realise-η-iso A .bwd ∘ (h ∘ ℰP.pair ℰP.p₁ ℰP.p₂)
+  ≈⟨ ∘-cong₂ (≈-trans (∘-cong₂ pair-p₁p₂-id) id-right) ⟩
+    realise-η-iso A .bwd ∘ h
+  ∎ where open ≈-Reasoning isEquiv
+
+-- The strong functorial action of the realised endofunctor: transpose the
+-- context morphism to Fam(ℰ), act there, and realise.
+Gmap : ∀ {n} (P : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj) {Γ A B} →
+       (ℰP.prod Γ A ⇒ B) → ℰP.prod Γ (Greal P δ̂ A) ⇒ Greal P δ̂ B
+Gmap P δ̂ {Γ} {A} {B} h =
+  realise .fmor
+    (FMu.strong-fmor (Poly-map η P) (FMu.strong-extend-mor (λ i → FamP.p₂) (ctxη Γ A h)))
+    ∘ prodη Γ (FM.fobj FM.μObj (Poly-map η P) (extend δ̂ (η .fobj A))) .bwd
+
+-- Componentwise naturality squares for identity and projection components.
+sq-refl : ∀ {Γ : obj} {X̂ Ŷ : FM.Obj} (u : FM.Mor (FamP.prod (η .fobj Γ) X̂) Ŷ) →
+          fmorη Γ X̂ u ∘co (Iso-refl .fwd ∘ ℰP.p₂) ≈ Iso-refl .fwd ∘ fmorη Γ X̂ u
+sq-refl {Γ} {X̂} u =
+  ≈-trans (∘-cong₂ (ℰP.pair-cong ≈-refl id-left))
+    (≈-trans (∘-cong₂ pair-p₁p₂-id) (≈-trans id-right (≈-sym id-left)))
+
+sq-p₂ : ∀ {Γ : obj} {X̂ Ŷ : FM.Obj} (I : Iso (realise .fobj X̂) (realise .fobj Ŷ)) →
+        fmorη Γ Ŷ (FamP.p₂ {x = η .fobj Γ} {y = Ŷ}) ∘co (I .fwd ∘ ℰP.p₂)
+        ≈ I .fwd ∘ fmorη Γ X̂ (FamP.p₂ {x = η .fobj Γ} {y = X̂})
+sq-p₂ {Γ} {X̂} {Ŷ} I =
+  ≈-trans (CoK.∘-cong₁ (fmorη-p₂ Γ Ŷ))
+    (≈-trans CoK.id-left (≈-sym (∘-cong₂ (fmorη-p₂ Γ X̂))))
+
+-- The realised strong action is a co-Kleisli functor.
+private
+  ctxη-p₂ : ∀ (Γ A : obj) → FamC._≈_ (ctxη Γ A ℰP.p₂) (FamP.p₂ {x = η .fobj Γ} {y = η .fobj A})
+  ctxη-p₂ Γ A = fmorη-inj Γ (η .fobj A) _ _
+    (iso-mono (realise-η-iso A)
+      (≈-trans (ctxη-counit Γ A ℰP.p₂)
+        (≈-trans (ℰP.pair-p₂ _ _)
+          (≈-sym (∘-cong₂ (fmorη-p₂ Γ (η .fobj A)))))))
+
+  ctxη-∘co : ∀ (Γ A B C₀ : obj) (h₂ : ℰP.prod Γ B ⇒ C₀) (h₁ : ℰP.prod Γ A ⇒ B) →
+             FamC._≈_ (ctxη Γ A (h₂ ∘co h₁))
+               (FM.Mor-∘ (ctxη Γ B h₂) (pairη Γ (η .fobj A) (ctxη Γ A h₁)))
+  ctxη-∘co Γ A B C₀ h₂ h₁ = fmorη-inj Γ (η .fobj A) _ _
+    (iso-mono (realise-η-iso C₀) (≈-trans lhs (≈-sym rhs)))
+    where
+      lhs : realise-η-iso C₀ .fwd ∘ fmorη Γ (η .fobj A) (ctxη Γ A (h₂ ∘co h₁))
+            ≈ h₂ ∘ ℰP.pair ℰP.p₁ (h₁ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd))
+      lhs =
+        begin
+          realise-η-iso C₀ .fwd ∘ fmorη Γ (η .fobj A) (ctxη Γ A (h₂ ∘co h₁))
+        ≈⟨ ctxη-counit Γ A (h₂ ∘co h₁) ⟩
+          (h₂ ∘ ℰP.pair ℰP.p₁ h₁) ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd)
+        ≈⟨ assoc _ _ _ ⟩
+          h₂ ∘ (ℰP.pair ℰP.p₁ h₁ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd))
+        ≈⟨ ∘-cong₂ (ℰP.pair-natural _ _ _) ⟩
+          h₂ ∘ ℰP.pair (ℰP.p₁ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd)) (h₁ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd))
+        ≈⟨ ∘-cong₂ (ℰP.pair-cong (≈-trans (ℰP.pair-p₁ _ _) id-left) ≈-refl) ⟩
+          h₂ ∘ ℰP.pair ℰP.p₁ (h₁ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd))
+        ∎ where open ≈-Reasoning isEquiv
+
+      rhs : realise-η-iso C₀ .fwd ∘ fmorη Γ (η .fobj A) (FM.Mor-∘ (ctxη Γ B h₂) (pairη Γ (η .fobj A) (ctxη Γ A h₁)))
+            ≈ h₂ ∘ ℰP.pair ℰP.p₁ (h₁ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd))
+      rhs =
+        begin
+          realise-η-iso C₀ .fwd ∘ fmorη Γ (η .fobj A) (FM.Mor-∘ (ctxη Γ B h₂) (pairη Γ (η .fobj A) (ctxη Γ A h₁)))
+        ≈⟨ ∘-cong₂ (fmorη-∘co Γ (η .fobj A) (ctxη Γ B h₂) (ctxη Γ A h₁)) ⟩
+          realise-η-iso C₀ .fwd ∘ (fmorη Γ (η .fobj B) (ctxη Γ B h₂) ∘ ℰP.pair ℰP.p₁ (fmorη Γ (η .fobj A) (ctxη Γ A h₁)))
+        ≈˘⟨ assoc _ _ _ ⟩
+          (realise-η-iso C₀ .fwd ∘ fmorη Γ (η .fobj B) (ctxη Γ B h₂)) ∘ ℰP.pair ℰP.p₁ (fmorη Γ (η .fobj A) (ctxη Γ A h₁))
+        ≈⟨ ∘-cong₁ (ctxη-counit Γ B h₂) ⟩
+          (h₂ ∘ ℰP.prod-m (id _) (realise-η-iso B .fwd)) ∘ ℰP.pair ℰP.p₁ (fmorη Γ (η .fobj A) (ctxη Γ A h₁))
+        ≈⟨ assoc _ _ _ ⟩
+          h₂ ∘ (ℰP.prod-m (id _) (realise-η-iso B .fwd) ∘ ℰP.pair ℰP.p₁ (fmorη Γ (η .fobj A) (ctxη Γ A h₁)))
+        ≈⟨ ∘-cong₂ (ℰP.pair-compose _ _ _ _) ⟩
+          h₂ ∘ ℰP.pair (id _ ∘ ℰP.p₁) (realise-η-iso B .fwd ∘ fmorη Γ (η .fobj A) (ctxη Γ A h₁))
+        ≈⟨ ∘-cong₂ (ℰP.pair-cong id-left (ctxη-counit Γ A h₁)) ⟩
+          h₂ ∘ ℰP.pair ℰP.p₁ (h₁ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd))
+        ∎ where open ≈-Reasoning isEquiv
+
+Gmap-id : ∀ {n} (P : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj) {Γ A : obj} →
+          Gmap P δ̂ {Γ} {A} {A} ℰP.p₂ ≈ ℰP.p₂
+Gmap-id P δ̂ {Γ} {A} =
+  ≈-trans (fmorη-cong (FMuI.strong-fmor-cong (Poly-map η P) eqs))
+    (≈-trans (fmorη-cong (FMuI.strong-fmor-p₂ (Poly-map η P)))
+      (fmorη-p₂ Γ (FM.fobj FM.μObj (Poly-map η P) (extend δ̂ (η .fobj A)))))
+  where
+    eqs : ∀ i → FamC._≈_
+           (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ A ℰP.p₂) i)
+           (FamP.p₂ {x = η .fobj Γ} {y = extend δ̂ (η .fobj A) i})
+    eqs Fin.zero    = ctxη-p₂ Γ A
+    eqs (Fin.suc i) = FamC.≈-refl
+
+Gmap-∘co : ∀ {n} (P : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj) {Γ A B C₀ : obj}
+           (h₂ : ℰP.prod Γ B ⇒ C₀) (h₁ : ℰP.prod Γ A ⇒ B) →
+           Gmap P δ̂ (h₂ ∘co h₁) ≈ Gmap P δ̂ h₂ ∘co Gmap P δ̂ h₁
+Gmap-∘co P δ̂ {Γ} {A} {B} {C₀} h₂ h₁ =
+  ≈-trans (fmorη-cong (FMuI.strong-fmor-cong (Poly-map η P) eqs))
+    (≈-trans (fmorη-cong (FamC.≈-sym (FMuI.strong-fmor-comp (Poly-map η P) _ _)))
+      (fmorη-∘co Γ (FM.fobj FM.μObj (Poly-map η P) (extend δ̂ (η .fobj A)))
+        (FMu.strong-fmor (Poly-map η P) (FMu.strong-extend-mor (λ i → FamP.p₂) (ctxη Γ B h₂)))
+        (FMu.strong-fmor (Poly-map η P) (FMu.strong-extend-mor (λ i → FamP.p₂) (ctxη Γ A h₁)))))
+  where
+    eqs : ∀ i → FamC._≈_
+           (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ A (h₂ ∘co h₁)) i)
+           (FM.Mor-∘ (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ B h₂) i)
+             (FamP.pair FamP.p₁ (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ A h₁) i)))
+    eqs Fin.zero    = ctxη-∘co Γ A B C₀ h₂ h₁
+    eqs (Fin.suc i) = FamC.≈-sym FamCoK.id-left
+
+-- Congruence of the realised strong action.
+Gmap-cong : ∀ {n} (P : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj) {Γ A B : obj}
+            {h₁ h₂ : ℰP.prod Γ A ⇒ B} → h₁ ≈ h₂ → Gmap P δ̂ h₁ ≈ Gmap P δ̂ h₂
+Gmap-cong P δ̂ {Γ} {A} {B} {h₁} {h₂} e =
+  ∘-cong₁ (realise .fmor-cong (FMuI.strong-fmor-cong (Poly-map η P) eqs))
+  where
+    eqs : ∀ i → FamC._≈_
+            (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ A h₁) i)
+            (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ A h₂) i)
+    eqs Fin.zero    = FR.untranspose-cong (∘-cong₁ e)
+    eqs (Fin.suc i) = FamC.≈-refl
+
+-- A transposed morphism squares with the counits against its own counit form.
+fmorη-ctxη-square : ∀ (Γ : obj) (X̂ Ŷ : FM.Obj) (w : FM.Mor (FamP.prod (η .fobj Γ) X̂) Ŷ) →
+                    fmorη Γ X̂ w ∘co (realise-η-iso (realise .fobj X̂) .fwd ∘ ℰP.p₂)
+                    ≈ realise-η-iso (realise .fobj Ŷ) .fwd ∘ fmorη Γ (η .fobj (realise .fobj X̂)) (ctxη Γ (realise .fobj X̂) (fmorη Γ X̂ w))
+fmorη-ctxη-square Γ X̂ Ŷ w =
+  ≈-sym (≈-trans (ctxη-counit Γ (realise .fobj X̂) (fmorη Γ X̂ w))
+    (∘-cong₂ (ℰP.pair-cong id-left ≈-refl)))
+
+-- Postcomposition with a pure morphism under realisation in context.
+fmorη-post : ∀ (Γ : obj) (X : FM.Obj) {Y Z : FM.Obj} (w : FM.Mor Y Z)
+             (u : FM.Mor (FamP.prod (η .fobj Γ) X) Y) →
+             fmorη Γ X (FM.Mor-∘ w u) ≈ realise .fmor w ∘ fmorη Γ X u
+fmorη-post Γ X w u =
+  ≈-trans (∘-cong₁ (realise .fmor-comp _ _)) (assoc _ _ _)
+
+-- Cancel an isomorphism applied backwards in context on the right.
+co-iso-epi : ∀ {Γ X Y Z : obj} (I : Iso X Y)
+             {u v : ℰP.prod Γ X ⇒ Z} →
+             (u ∘co (I .bwd ∘ ℰP.p₂) ≈ v ∘co (I .bwd ∘ ℰP.p₂)) → u ≈ v
+co-iso-epi I {u} {v} eq =
+  begin
+    u
+  ≈˘⟨ CoK.id-right ⟩
+    u ∘co ℰP.p₂
+  ≈˘⟨ CoK.∘-cong₂ (≈-trans (co-pure _ _) (≈-trans (∘-cong₁ (I .bwd∘fwd≈id)) id-left)) ⟩
+    u ∘co ((I .bwd ∘ ℰP.p₂) ∘co (I .fwd ∘ ℰP.p₂))
+  ≈˘⟨ CoK.assoc _ _ _ ⟩
+    (u ∘co (I .bwd ∘ ℰP.p₂)) ∘co (I .fwd ∘ ℰP.p₂)
+  ≈⟨ CoK.∘-cong₁ eq ⟩
+    (v ∘co (I .bwd ∘ ℰP.p₂)) ∘co (I .fwd ∘ ℰP.p₂)
+  ≈⟨ CoK.assoc _ _ _ ⟩
+    v ∘co ((I .bwd ∘ ℰP.p₂) ∘co (I .fwd ∘ ℰP.p₂))
+  ≈⟨ CoK.∘-cong₂ (≈-trans (co-pure _ _) (≈-trans (∘-cong₁ (I .bwd∘fwd≈id)) id-left)) ⟩
+    v ∘co ℰP.p₂
+  ≈⟨ CoK.id-right ⟩
+    v
+  ∎ where open ≈-Reasoning isEquiv
+
+-- Move an isomorphism in context across an equation.
+co-iso-move : ∀ {Γ X Y Z : obj} (I : Iso X Y)
+              {u : ℰP.prod Γ Y ⇒ Z} {v : ℰP.prod Γ X ⇒ Z} →
+              u ≈ v ∘co (I .bwd ∘ ℰP.p₂) → u ∘co (I .fwd ∘ ℰP.p₂) ≈ v
+co-iso-move I {u} {v} eq =
+  ≈-trans (CoK.∘-cong₁ eq)
+    (≈-trans (CoK.assoc _ _ _)
+      (≈-trans (CoK.∘-cong₂ (≈-trans (co-pure _ _) (≈-trans (∘-cong₁ (I .bwd∘fwd≈id)) id-left)))
+        CoK.id-right))
+
+-- Cancel a projection from the terminal context.
+p₂-cancel : ∀ {X Z : obj} {f g : X ⇒ Z} →
+            (f ∘ ℰP.p₂ {ℰT'.witness} {X} ≈ g ∘ ℰP.p₂) → f ≈ g
+p₂-cancel {X} {Z} {f} {g} eq =
+  ≈-trans (≈-sym id-right)
+    (≈-trans (∘-cong₂ (≈-sym (ℰP.pair-p₂ ℰT'.to-terminal (id _))))
+      (≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong₁ eq)
+          (≈-trans (assoc _ _ _)
+            (≈-trans (∘-cong₂ (ℰP.pair-p₂ ℰT'.to-terminal (id _))) id-right)))))
diff --git a/agda/src/fam-mu-realisation/initial.agda b/agda/src/fam-mu-realisation/initial.agda
new file mode 100644
index 00000000..1c919701
--- /dev/null
+++ b/agda/src/fam-mu-realisation/initial.agda
@@ -0,0 +1,296 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- The initial-algebra package carried by a realised μ-object, against an
+-- assumed invariance family for its polynomial.
+
+open import Level using (Level; _⊔_)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import prop-setoid using (Setoid; module ≈-Reasoning)
+open import categories
+  using (Category; setoid→category; HasTerminal; HasProducts; HasExponentials;
+         HasStrongCoproducts; HasCoproducts; strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor; HasColimits)
+open import polynomial-functor using (Poly; extend; Poly-map)
+import fam
+import fam-mu-types
+import fam-realisation
+import polynomial-functor
+import fam-mu-realisation.invariance
+
+module fam-mu-realisation.initial {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os (os ⊔ es)) → HasColimits (setoid→category A) ℰ)
+  (ℰT : HasTerminal ℰ) (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP)
+  (ℰSC : HasStrongCoproducts ℰ ℰP)
+  where
+
+open fam-mu-realisation.invariance os es ℰC ℰT ℰP ℰE ℰSC public
+
+-- The initial-algebra package for a polynomial, against an assumed invariance
+-- family and its naturality with respect to the strong action. The algebra
+-- map realises the Fam(ℰ) algebra map and corrects the bound-variable entry
+-- by invariance; the fold transposes the algebra to Fam(ℰ), folds there, and
+-- transposes back; β follows from the Fam(ℰ) β law pushed through the
+-- co-Kleisli functoriality of realisation.
+module Initiality {n} (P : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj)
+    (CP : InvarianceAt P)
+  where
+
+  open InvarianceAt CP using () renaming (iso to Kiso'; natural to Knat)
+
+  private
+    P̂ = Poly-map η P
+    μ̂ = FM.μObj P̂ δ̂
+
+    F^ : FM.Obj → FM.Obj
+    F^ Ŷ = FM.fobj FM.μObj P̂ (extend δ̂ Ŷ)
+
+  inIsos : ∀ i → Iso (realise .fobj (extend δ̂ (η .fobj (Creal P δ̂)) i))
+                     (realise .fobj (extend δ̂ (FM.μObj (Poly-map η P) δ̂) i))
+  inIsos Fin.zero    = realise-η-iso (Creal P δ̂)
+  inIsos (Fin.suc i) = Iso-refl
+
+  private
+
+    bF : ∀ {Γ A} → (ℰP.prod Γ (Greal P δ̂ A) ⇒ A) → FM.Mor (FamP.prod (η .fobj Γ) (F^ (η .fobj A))) (η .fobj A)
+    bF {Γ} {A} a = untranspose (a ∘ prodη Γ (F^ (η .fobj A)) .fwd)
+
+  inR : Greal P δ̂ (Creal P δ̂) ⇒ Creal P δ̂
+  inR = realise .fmor (FMu.inMap P̂ δ̂) ∘
+        Kiso' (extend δ̂ (η .fobj (Creal P δ̂))) (extend δ̂ μ̂) inIsos .fwd
+
+  foldR : ∀ {Γ A} → (ℰP.prod Γ (Greal P δ̂ A) ⇒ A) → ℰP.prod Γ (Creal P δ̂) ⇒ A
+  foldR {Γ} {A} a = transpose (FMu.⦅_⦆ {P = P̂} {δ = δ̂} (bF a)) ∘ prodη Γ μ̂ .bwd
+
+  private
+    -- The fold in counit-and-realisation form.
+    foldR-real : ∀ {Γ A} (a : ℰP.prod Γ (Greal P δ̂ A) ⇒ A) →
+                 foldR a ≈ realise-η-iso A .fwd ∘ fmorη Γ μ̂ (FMu.⦅_⦆ {P = P̂} {δ = δ̂} (bF a))
+    foldR-real {Γ} {A} a =
+      ≈-trans (∘-cong₁ (FR.transpose-realise _)) (assoc _ _ _)
+
+    -- The context morphism Gmap acts with, for a morphism out of the carrier.
+    h~ : ∀ {Γ A} → (ℰP.prod Γ (Creal P δ̂) ⇒ A) →
+         FM.Mor (FamP.prod (η .fobj Γ) (η .fobj (Creal P δ̂))) (η .fobj A)
+    h~ {Γ} {A} h = ctxη Γ (Creal P δ̂) h
+
+    -- Compatibility of a transposed morphism with the counit component of the
+    -- invariance, given its counit form.
+    compat-zero : ∀ {Γ A} (u : FM.Mor (FamP.prod (η .fobj Γ) μ̂) (η .fobj A))
+                  (h : ℰP.prod Γ (Creal P δ̂) ⇒ A) →
+                  (realise-η-iso A .fwd ∘ fmorη Γ μ̂ u ≈ h) →
+                  fmorη Γ μ̂ u ∘co (realise-η-iso (Creal P δ̂) .fwd ∘ ℰP.p₂)
+                  ≈ fmorη Γ (η .fobj (Creal P δ̂)) (h~ h)
+    compat-zero {Γ} {A} u h hyp =
+      ≈-trans (iso-shuffle (realise-η-iso A) _ _ middle)
+        (≈-trans (≈-sym (assoc _ _ _))
+          (≈-trans (∘-cong₁ (realise-η-iso A .bwd∘fwd≈id)) id-left))
+      where
+        cA = realise-η-iso A .fwd
+        cC = realise-η-iso (Creal P δ̂) .fwd
+
+        left : cA ∘ (fmorη Γ μ̂ u ∘co (cC ∘ ℰP.p₂)) ≈ h ∘ ℰP.prod-m (id _) cC
+        left =
+          ≈-trans (≈-sym (assoc _ _ _))
+            (≈-trans (∘-cong₁ hyp)
+              (∘-cong₂ (ℰP.pair-cong (≈-sym id-left) ≈-refl)))
+
+        right : cA ∘ fmorη Γ (η .fobj (Creal P δ̂)) (h~ h) ≈ h ∘ ℰP.prod-m (id _) cC
+        right =
+          ≈-trans (counit-fmorη Γ (η .fobj (Creal P δ̂)) _)
+            (≈-trans (assoc _ _ _)
+              (∘-cong₂ (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (prodη Γ (η .fobj (Creal P δ̂)) .fwd∘bwd≈id)) id-right))))
+
+        middle : cA ∘ (fmorη Γ μ̂ u ∘co (cC ∘ ℰP.p₂)) ≈ cA ∘ fmorη Γ (η .fobj (Creal P δ̂)) (h~ h)
+        middle = ≈-trans left (≈-sym right)
+
+    compat-suc : ∀ {Γ : obj} (i : Fin n) →
+                 fmorη Γ (δ̂ i) (FamP.p₂ {x = η .fobj Γ} {y = δ̂ i}) ∘co (Iso-refl .fwd ∘ ℰP.p₂)
+                 ≈ fmorη Γ (δ̂ i) (FamP.p₂ {x = η .fobj Γ} {y = δ̂ i})
+    compat-suc {Γ} i =
+      ≈-trans (∘-cong₂ (ℰP.pair-cong ≈-refl id-left))
+        (≈-trans (∘-cong₂ pair-p₁p₂-id) id-right)
+
+    -- The invariance-naturality square for a Fam(ℰ) morphism in counit form.
+    key : ∀ {Γ A} (u : FM.Mor (FamP.prod (η .fobj Γ) μ̂) (η .fobj A))
+          (h : ℰP.prod Γ (Creal P δ̂) ⇒ A) →
+          (realise-η-iso A .fwd ∘ fmorη Γ μ̂ u ≈ h) →
+          fmorη Γ (F^ μ̂) (FMu.strong-fmor P̂ (FMu.strong-extend-mor (λ i → FamP.p₂) u))
+            ∘co (Kiso' (extend δ̂ (η .fobj (Creal P δ̂))) (extend δ̂ μ̂) inIsos .fwd ∘ ℰP.p₂)
+          ≈ Gmap P δ̂ h
+    key {Γ} {A} u h hyp =
+      ≈-trans
+        (Knat (extend δ̂ (η .fobj (Creal P δ̂))) (extend δ̂ μ̂) inIsos (λ i → Iso-refl)
+          (FMu.strong-extend-mor (λ i → FamP.p₂) (h~ h))
+          (FMu.strong-extend-mor (λ i → FamP.p₂) u)
+          compats)
+        (≈-trans (∘-cong₁ (invariance-refl P CP (extend δ̂ (η .fobj A)) (λ i → Iso-refl) (λ i → ≈-refl))) id-left)
+      where
+        compats : ∀ i → fmorη Γ (extend δ̂ μ̂ i) (FMu.strong-extend-mor (λ j → FamP.p₂) u i) ∘co (inIsos i .fwd ∘ ℰP.p₂)
+                  ≈ Iso-refl .fwd ∘ fmorη Γ (extend δ̂ (η .fobj (Creal P δ̂)) i) (FMu.strong-extend-mor (λ j → FamP.p₂) (h~ h) i)
+        compats Fin.zero    = ≈-trans (compat-zero u h hyp) (≈-sym id-left)
+        compats (Fin.suc i) = ≈-trans (compat-suc i) (≈-sym id-left)
+
+  foldR-β : ∀ {Γ A} (a : ℰP.prod Γ (Greal P δ̂ A) ⇒ A) →
+            foldR a ∘co (inR ∘ ℰP.p₂) ≈ a ∘co Gmap P δ̂ (foldR a)
+  foldR-β {Γ} {A} a =
+    begin
+      foldR a ∘co (inR ∘ ℰP.p₂)
+    ≈⟨ CoK.∘-cong (foldR-real a) split ⟩
+      (cA ∘ Φ⦅b⦆) ∘co ((Rin ∘ ℰP.p₂) ∘co (K ∘ ℰP.p₂))
+    ≈˘⟨ CoK.assoc _ _ _ ⟩
+      ((cA ∘ Φ⦅b⦆) ∘co (Rin ∘ ℰP.p₂)) ∘co (K ∘ ℰP.p₂)
+    ≈⟨ CoK.∘-cong₁ step₁ ⟩
+      (cA ∘ fmorη Γ (F^ μ̂) (FM.Mor-∘ ⦅b⦆ (pairη Γ (F^ μ̂) (FM.Mor-∘ (FMu.inMap P̂ δ̂) p₂F)))) ∘co (K ∘ ℰP.p₂)
+    ≈⟨ CoK.∘-cong₁ (∘-cong₂ (fmorη-cong (FM.hasMuLaws .FM.HasMuLaws.⦅⦆-β (bF a)))) ⟩
+      (cA ∘ fmorη Γ (F^ μ̂) (FM.Mor-∘ (bF a) (pairη Γ (F^ μ̂) sfB))) ∘co (K ∘ ℰP.p₂)
+    ≈⟨ CoK.∘-cong₁ (∘-cong₂ (fmorη-∘co Γ (F^ μ̂) (bF a) sfB)) ⟩
+      (cA ∘ (fmorη Γ (F^ (η .fobj A)) (bF a) ∘co fmorη Γ (F^ μ̂) sfB)) ∘co (K ∘ ℰP.p₂)
+    ≈˘⟨ CoK.∘-cong₁ (assoc _ _ _) ⟩
+      ((cA ∘ fmorη Γ (F^ (η .fobj A)) (bF a)) ∘co fmorη Γ (F^ μ̂) sfB) ∘co (K ∘ ℰP.p₂)
+    ≈⟨ CoK.∘-cong₁ (CoK.∘-cong₁ (absorb (F^ (η .fobj A)) a)) ⟩
+      (a ∘co fmorη Γ (F^ μ̂) sfB) ∘co (K ∘ ℰP.p₂)
+    ≈⟨ CoK.assoc _ _ _ ⟩
+      a ∘co (fmorη Γ (F^ μ̂) sfB ∘co (K ∘ ℰP.p₂))
+    ≈⟨ CoK.∘-cong₂ (key ⦅b⦆ (foldR a) (≈-sym (foldR-real a))) ⟩
+      a ∘co Gmap P δ̂ (foldR a)
+    ∎
+    where
+      open ≈-Reasoning isEquiv
+
+      ⦅b⦆ = FMu.⦅_⦆ {P = P̂} {δ = δ̂} (bF a)
+      cA = realise-η-iso A .fwd
+      Φ⦅b⦆ = fmorη Γ μ̂ ⦅b⦆
+      Rin = realise .fmor (FMu.inMap P̂ δ̂)
+      K = Kiso' (extend δ̂ (η .fobj (Creal P δ̂))) (extend δ̂ μ̂) inIsos .fwd
+      p₂F = FamP.p₂ {x = η .fobj Γ} {y = F^ μ̂}
+      sfB = FMu.strong-fmor P̂ (FMu.strong-extend-mor (λ i → FamP.p₂) ⦅b⦆)
+
+      split : inR ∘ ℰP.p₂ ≈ (Rin ∘ ℰP.p₂) ∘co (K ∘ ℰP.p₂)
+      split = ≈-sym (co-pure Rin K)
+
+      step₁ : (cA ∘ Φ⦅b⦆) ∘co (Rin ∘ ℰP.p₂)
+              ≈ cA ∘ fmorη Γ (F^ μ̂) (FM.Mor-∘ ⦅b⦆ (pairη Γ (F^ μ̂) (FM.Mor-∘ (FMu.inMap P̂ δ̂) p₂F)))
+      step₁ =
+        ≈-trans (assoc _ _ _)
+          (∘-cong₂
+            (≈-sym (≈-trans (fmorη-∘co Γ (F^ μ̂) ⦅b⦆ (FM.Mor-∘ (FMu.inMap P̂ δ̂) p₂F))
+              (CoK.∘-cong₂ (fmorη-pure Γ (F^ μ̂) (FMu.inMap P̂ δ̂))))))
+
+  foldR-η : ∀ {Γ A} (a : ℰP.prod Γ (Greal P δ̂ A) ⇒ A) (h : ℰP.prod Γ (Creal P δ̂) ⇒ A) →
+            (h ∘co (inR ∘ ℰP.p₂) ≈ a ∘co Gmap P δ̂ h) → h ≈ foldR a
+  foldR-η {Γ} {A} a h square =
+    ≈-trans (≈-sym (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (prodη Γ μ̂ .fwd∘bwd≈id)) id-right)))
+      (≈-trans (∘-cong₁ (≈-sym (FR.transpose-untranspose _)))
+        (∘-cong₁ (FR.transpose-cong famSquare')))
+    where
+      ĥ = untranspose (h ∘ prodη Γ μ̂ .fwd)
+      cA = realise-η-iso A .fwd
+      Rin = realise .fmor (FMu.inMap P̂ δ̂)
+      Kiso = Kiso' (extend δ̂ (η .fobj (Creal P δ̂))) (extend δ̂ μ̂) inIsos
+      p₂F = FamP.p₂ {x = η .fobj Γ} {y = F^ μ̂}
+      sfH = FMu.strong-fmor P̂ (FMu.strong-extend-mor (λ i → FamP.p₂) ĥ)
+
+      hypĥ : cA ∘ fmorη Γ μ̂ ĥ ≈ h
+      hypĥ = absorb μ̂ h
+
+      -- The given square, with the invariance cancelled and the algebra map bare.
+      square' : h ∘co (Rin ∘ ℰP.p₂) ≈ a ∘co fmorη Γ (F^ μ̂) sfH
+      square' =
+        begin
+          h ∘co (Rin ∘ ℰP.p₂)
+        ≈˘⟨ co-iso-cancel Kiso (≈-trans (≈-trans (CoK.assoc _ _ _) (CoK.∘-cong₂ (co-pure {Γ = Γ} Rin (Kiso .fwd)))) square) ⟩
+          (a ∘co Gmap P δ̂ h) ∘co (Kiso .bwd ∘ ℰP.p₂)
+        ≈⟨ CoK.assoc _ _ _ ⟩
+          a ∘co (Gmap P δ̂ h ∘co (Kiso .bwd ∘ ℰP.p₂))
+        ≈⟨ CoK.∘-cong₂ (co-iso-cancel Kiso (key ĥ h hypĥ)) ⟩
+          a ∘co fmorη Γ (F^ μ̂) sfH
+        ∎ where open ≈-Reasoning isEquiv
+
+      famSquare : FamC._≈_
+                    (FM.Mor-∘ ĥ (pairη Γ (F^ μ̂) (FM.Mor-∘ (FMu.inMap P̂ δ̂) p₂F)))
+                    (FM.Mor-∘ (bF a) (pairη Γ (F^ μ̂) sfH))
+      famSquare = fmorη-inj Γ (F^ μ̂) _ _ imgEq
+        where
+          inner : cA ∘ (fmorη Γ μ̂ ĥ ∘co (Rin ∘ ℰP.p₂)) ≈ a ∘co fmorη Γ (F^ μ̂) sfH
+          inner =
+            ≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong₁ hypĥ) square')
+
+          imgEq : fmorη Γ (F^ μ̂) (FM.Mor-∘ ĥ (pairη Γ (F^ μ̂) (FM.Mor-∘ (FMu.inMap P̂ δ̂) p₂F)))
+                  ≈ fmorη Γ (F^ μ̂) (FM.Mor-∘ (bF a) (pairη Γ (F^ μ̂) sfH))
+          imgEq =
+            begin
+              fmorη Γ (F^ μ̂) (FM.Mor-∘ ĥ (pairη Γ (F^ μ̂) (FM.Mor-∘ (FMu.inMap P̂ δ̂) p₂F)))
+            ≈⟨ ≈-trans (fmorη-∘co Γ (F^ μ̂) ĥ _) (CoK.∘-cong₂ (fmorη-pure Γ (F^ μ̂) (FMu.inMap P̂ δ̂))) ⟩
+              fmorη Γ μ̂ ĥ ∘co (Rin ∘ ℰP.p₂)
+            ≈⟨ iso-shuffle (realise-η-iso A) _ _ inner ⟩
+              realise-η-iso A .bwd ∘ (a ∘co fmorη Γ (F^ μ̂) sfH)
+            ≈˘⟨ assoc _ _ _ ⟩
+              (realise-η-iso A .bwd ∘ a) ∘co fmorη Γ (F^ μ̂) sfH
+            ≈˘⟨ CoK.∘-cong₁ (iso-shuffle (realise-η-iso A) _ _ (absorb (F^ (η .fobj A)) a)) ⟩
+              fmorη Γ (F^ (η .fobj A)) (bF a) ∘co fmorη Γ (F^ μ̂) sfH
+            ≈˘⟨ fmorη-∘co Γ (F^ μ̂) (bF a) sfH ⟩
+              fmorη Γ (F^ μ̂) (FM.Mor-∘ (bF a) (pairη Γ (F^ μ̂) sfH))
+            ∎ where open ≈-Reasoning isEquiv
+
+      famSquare' : FamC._≈_ ĥ (FMu.⦅_⦆ {P = P̂} {δ = δ̂} (bF a))
+      famSquare' = FM.hasMuLaws .FM.HasMuLaws.⦅⦆-η (bF a) ĥ famSquare
+
+  foldR-cong : ∀ {Γ A} {a₁ a₂ : ℰP.prod Γ (Greal P δ̂ A) ⇒ A} →
+               a₁ ≈ a₂ → foldR a₁ ≈ foldR a₂
+  foldR-cong {Γ} {A} {a₁} {a₂} e =
+    ∘-cong₁ (FR.transpose-cong (FMuI.⦅⦆-cong P̂ δ̂ (FR.untranspose-cong (∘-cong₁ e))))
+
+
+-- Plain-context conversions at the terminal object.
+
+sect-p₂ : ∀ {X : obj} → ℰP.pair (ℰT'.to-terminal {X}) (id X) ∘ ℰP.p₂ {ℰT'.witness} {X} ≈ id _
+sect-p₂ {X} =
+  ≈-trans (ℰP.pair-natural _ _ _)
+    (≈-trans (ℰP.pair-cong (ℰT'.to-terminal-unique _ _) id-left) pair-p₁p₂-id)
+
+-- The plain form of a fold in the terminal context commutes with the algebra
+-- map, against the plain form of the realised strong action.
+plain-β : ∀ {n} (Q : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj) (CQ : InvarianceAt Q) {D : obj}
+          (c : ℰP.prod ℰT'.witness (Greal Q δ̂ D) ⇒ D) →
+          (Initiality.foldR Q δ̂ CQ c ∘ ℰP.pair ℰT'.to-terminal (id _)) ∘ Initiality.inR Q δ̂ CQ
+          ≈ c ∘ ℰP.pair ℰT'.to-terminal (Gmap Q δ̂ (Initiality.foldR Q δ̂ CQ c) ∘ ℰP.pair ℰT'.to-terminal (id _))
+plain-β Q δ̂ CQ {D} c =
+  ≈-trans left
+    (≈-trans (≈-sym lhs-sect)
+      (≈-trans (∘-cong₁ (M.foldR-β {Γ = ℰT'.witness} c)) rhs-sect))
+  where
+    module M = Initiality Q δ̂ CQ
+
+    left : (M.foldR c ∘ ℰP.pair ℰT'.to-terminal (id _)) ∘ M.inR
+           ≈ M.foldR c ∘ ℰP.pair ℰT'.to-terminal M.inR
+    left =
+      ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (ℰP.pair-natural _ _ _))
+          (∘-cong₂ (ℰP.pair-cong (ℰT'.to-terminal-unique _ _) id-left)))
+
+    lhs-sect : (M.foldR c ∘co (M.inR ∘ ℰP.p₂)) ∘ ℰP.pair ℰT'.to-terminal (id _)
+               ≈ M.foldR c ∘ ℰP.pair ℰT'.to-terminal M.inR
+    lhs-sect =
+      ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (ℰP.pair-natural _ _ _))
+          (∘-cong₂ (ℰP.pair-cong (ℰT'.to-terminal-unique _ _)
+            (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (ℰP.pair-p₂ _ _)) id-right)))))
+
+    rhs-sect : (c ∘co Gmap Q δ̂ (M.foldR c)) ∘ ℰP.pair ℰT'.to-terminal (id _)
+               ≈ c ∘ ℰP.pair ℰT'.to-terminal (Gmap Q δ̂ (M.foldR c) ∘ ℰP.pair ℰT'.to-terminal (id _))
+    rhs-sect =
+      ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (ℰP.pair-natural _ _ _))
+          (∘-cong₂ (ℰP.pair-cong (ℰT'.to-terminal-unique _ _) ≈-refl)))
+
+-- The realised algebra map, recovered from the invariance form of inR.
+inR-K : ∀ {n} (Q : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj) (CQ : InvarianceAt Q) →
+        realise .fmor (FMu.inMap (Poly-map η Q) δ̂)
+        ≈ Initiality.inR Q δ̂ CQ ∘
+           CQ .iso (extend δ̂ (η .fobj (Creal Q δ̂))) (extend δ̂ (FM.μObj (Poly-map η Q) δ̂)) (Initiality.inIsos Q δ̂ CQ) .bwd
+inR-K Q δ̂ CQ =
+  ≈-sym (≈-trans (assoc _ _ _)
+    (≈-trans (∘-cong₂ (CQ .iso _ _ (Initiality.inIsos Q δ̂ CQ) .fwd∘bwd≈id)) id-right))
diff --git a/agda/src/fam-mu-realisation/invariance.agda b/agda/src/fam-mu-realisation/invariance.agda
new file mode 100644
index 00000000..104b3bad
--- /dev/null
+++ b/agda/src/fam-mu-realisation/invariance.agda
@@ -0,0 +1,690 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- The invariance interface: realisation of the polynomial interpretation is
+-- invariant under replacing environment entries by families with isomorphic
+-- realisations, naturally in the strong action, compatibly with identities
+-- and composition. Cases: constants, variables, sums and products.
+
+open import Level using (Level; _⊔_)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import prop-setoid using (Setoid; module ≈-Reasoning)
+open import categories
+  using (Category; setoid→category; HasTerminal; HasProducts; HasExponentials;
+         HasStrongCoproducts; HasCoproducts; strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor; HasColimits)
+open import polynomial-functor using (Poly; extend; Poly-map)
+import fam
+import fam-mu-types
+import fam-realisation
+import polynomial-functor
+import fam-mu-realisation.pure
+
+module fam-mu-realisation.invariance {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os (os ⊔ es)) → HasColimits (setoid→category A) ℰ)
+  (ℰT : HasTerminal ℰ) (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP)
+  (ℰSC : HasStrongCoproducts ℰ ℰP)
+  where
+
+open fam-mu-realisation.pure os es ℰC ℰT ℰP ℰE ℰSC public
+
+-- The invariance interface for a polynomial: realisation of its application is
+-- invariant under replacing environment entries by families with isomorphic
+-- realisations, naturally in the strong action, and trivially so at identical
+-- environments.
+record InvarianceAt {n} (P : Poly ℰ n) : Set (o ⊔ m ⊔ e ⊔ Level.suc os ⊔ Level.suc es) where
+  field
+    iso : (δ̂₁ δ̂₂ : Fin n → FM.Obj) →
+          (∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i))) →
+          Iso (realise .fobj (FM.fobj FM.μObj (Poly-map η P) δ̂₁))
+              (realise .fobj (FM.fobj FM.μObj (Poly-map η P) δ̂₂))
+    natural : ∀ {Γ : obj} {ε̂₁ ε̂₂ : Fin n → FM.Obj}
+              (δ̂₁ δ̂₂ : Fin n → FM.Obj)
+              (isosδ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+              (isosε : ∀ i → Iso (realise .fobj (ε̂₁ i)) (realise .fobj (ε̂₂ i)))
+              (gs₁ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₁ i)) (ε̂₁ i))
+              (gs₂ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₂ i)) (ε̂₂ i)) →
+              (∀ i → fmorη Γ (δ̂₂ i) (gs₂ i) ∘co (isosδ i .fwd ∘ ℰP.p₂)
+                     ≈ isosε i .fwd ∘ fmorη Γ (δ̂₁ i) (gs₁ i)) →
+              fmorη Γ (FM.fobj FM.μObj (Poly-map η P) δ̂₂) (FMu.strong-fmor (Poly-map η P) gs₂)
+                ∘co (iso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)
+              ≈ iso _ _ isosε .fwd ∘ fmorη Γ (FM.fobj FM.μObj (Poly-map η P) δ̂₁) (FMu.strong-fmor (Poly-map η P) gs₁)
+    comp : ∀ (δ̂₁ δ̂₂ δ̂₃ : Fin n → FM.Obj)
+           (isos₁₂ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+           (isos₂₃ : ∀ i → Iso (realise .fobj (δ̂₂ i)) (realise .fobj (δ̂₃ i))) →
+           iso δ̂₁ δ̂₃ (λ i → Iso-trans (isos₁₂ i) (isos₂₃ i)) .fwd
+           ≈ iso δ̂₂ δ̂₃ isos₂₃ .fwd ∘ iso δ̂₁ δ̂₂ isos₁₂ .fwd
+
+open InvarianceAt public
+
+-- The invariance interface at constants and variables.
+invariance-const : ∀ {n} (A : obj) → InvarianceAt {n} (const A)
+invariance-const A .iso δ̂₁ δ̂₂ isos = Iso-refl
+invariance-const A .natural δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs = sq-refl _
+invariance-const A .comp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃ = ≈-sym id-left
+
+invariance-var : ∀ {n} (i : Fin n) → InvarianceAt {n} (var i)
+invariance-var i .iso δ̂₁ δ̂₂ isos = isos i
+invariance-var i .natural δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs = sqs i
+invariance-var i .comp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃ = ≈-refl
+
+-- Invariance isomorphisms at pointwise-equal isomorphism families are equal.
+invariance-ext : ∀ {n} (Q : Poly ℰ n) (CQ' : InvarianceAt Q) (δ̂₁ δ̂₂ : Fin n → FM.Obj)
+               (isos isos' : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i))) →
+               (∀ i → isos i .fwd ≈ isos' i .fwd) →
+               CQ' .iso δ̂₁ δ̂₂ isos .fwd ≈ CQ' .iso δ̂₁ δ̂₂ isos' .fwd
+invariance-ext {n} Q CQ' δ̂₁ δ̂₂ isos isos' hyps =
+  p₂-cancel (≈-trans (≈-sym strip₁) (≈-trans (CQ' .natural δ̂₁ δ̂₂ isos isos' (λ i → FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₁ i}) (λ i → FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₂ i}) sqs) strip₂))
+  where
+    strip₁ : fmorη ℰT'.witness (FM.fobj FM.μObj (Poly-map η Q) δ̂₂) (FMu.strong-fmor (Poly-map η Q) (λ i → FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₂ i}))
+              ∘co (CQ' .iso δ̂₁ δ̂₂ isos .fwd ∘ ℰP.p₂)
+             ≈ CQ' .iso δ̂₁ δ̂₂ isos .fwd ∘ ℰP.p₂
+    strip₁ =
+      ≈-trans (CoK.∘-cong₁ (≈-trans (fmorη-cong (FMuI.strong-fmor-p₂ (Poly-map η Q))) (fmorη-p₂ ℰT'.witness _)))
+        (CoK.id-left {Γ = ℰT'.witness})
+
+    strip₂ : CQ' .iso δ̂₁ δ̂₂ isos' .fwd
+              ∘ fmorη ℰT'.witness (FM.fobj FM.μObj (Poly-map η Q) δ̂₁) (FMu.strong-fmor (Poly-map η Q) (λ i → FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₁ i}))
+             ≈ CQ' .iso δ̂₁ δ̂₂ isos' .fwd ∘ ℰP.p₂
+    strip₂ =
+      ∘-cong₂ (≈-trans (fmorη-cong (FMuI.strong-fmor-p₂ (Poly-map η Q))) (fmorη-p₂ ℰT'.witness _))
+
+    sqs : ∀ i → fmorη ℰT'.witness (δ̂₂ i) (FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₂ i}) ∘co (isos i .fwd ∘ ℰP.p₂)
+                ≈ isos' i .fwd ∘ fmorη ℰT'.witness (δ̂₁ i) (FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₁ i})
+    sqs i =
+      ≈-trans (CoK.∘-cong₁ (fmorη-p₂ ℰT'.witness (δ̂₂ i)))
+        (≈-trans (CoK.id-left {Γ = ℰT'.witness})
+          (≈-trans (∘-cong₁ (hyps i))
+            (≈-sym (∘-cong₂ (fmorη-p₂ ℰT'.witness (δ̂₁ i))))))
+
+-- Invariance at pointwise-identity isomorphisms is the identity: by
+-- extensionality it is the invariance at reflexivity families, which is
+-- idempotent by composition coherence, and an idempotent isomorphism is the
+-- identity.
+invariance-refl : ∀ {n} (Q : Poly ℰ n) (CQ' : InvarianceAt Q) (δ̂ : Fin n → FM.Obj)
+                (isos : ∀ i → Iso (realise .fobj (δ̂ i)) (realise .fobj (δ̂ i))) →
+                (∀ i → isos i .fwd ≈ id _) →
+                CQ' .iso δ̂ δ̂ isos .fwd ≈ id _
+invariance-refl Q CQ' δ̂ isos hyps =
+  ≈-trans (invariance-ext Q CQ' δ̂ δ̂ isos (λ i → Iso-refl) hyps)
+    (≈-trans (≈-sym id-right)
+      (≈-trans (∘-cong₂ (≈-sym (CQ' .iso δ̂ δ̂ (λ i → Iso-refl) .fwd∘bwd≈id)))
+        (≈-trans (≈-sym (assoc _ _ _))
+          (≈-trans (∘-cong₁ idem) (CQ' .iso δ̂ δ̂ (λ i → Iso-refl) .fwd∘bwd≈id)))))
+  where
+    idem : CQ' .iso δ̂ δ̂ (λ i → Iso-refl) .fwd ∘ CQ' .iso δ̂ δ̂ (λ i → Iso-refl) .fwd
+           ≈ CQ' .iso δ̂ δ̂ (λ i → Iso-refl) .fwd
+    idem =
+      ≈-trans (≈-sym (CQ' .comp δ̂ δ̂ δ̂ (λ i → Iso-refl) (λ i → Iso-refl)))
+        (invariance-ext Q CQ' δ̂ δ̂ (λ i → Iso-trans Iso-refl Iso-refl) (λ i → Iso-refl) (λ i → id-left))
+
+-- Two composite invariance paths with pointwise-equal composite agreements
+-- coincide.
+invariance-path-eq : ∀ {n} (Q : Poly ℰ n) (CQ' : InvarianceAt Q)
+                   (δ̂₁ δ̂₂ δ̂₂' δ̂₃ : Fin n → FM.Obj)
+                   (as₁ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+                   (as₂ : ∀ i → Iso (realise .fobj (δ̂₂ i)) (realise .fobj (δ̂₃ i)))
+                   (bs₁ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂' i)))
+                   (bs₂ : ∀ i → Iso (realise .fobj (δ̂₂' i)) (realise .fobj (δ̂₃ i))) →
+                   (∀ i → Iso-trans (as₁ i) (as₂ i) .fwd ≈ Iso-trans (bs₁ i) (bs₂ i) .fwd) →
+                   CQ' .iso _ _ as₂ .fwd ∘ CQ' .iso _ _ as₁ .fwd
+                   ≈ CQ' .iso _ _ bs₂ .fwd ∘ CQ' .iso _ _ bs₁ .fwd
+invariance-path-eq Q CQ' δ̂₁ δ̂₂ δ̂₂' δ̂₃ as₁ as₂ bs₁ bs₂ pw =
+  ≈-trans (≈-sym (CQ' .comp δ̂₁ δ̂₂ δ̂₃ as₁ as₂))
+    (≈-trans (invariance-ext Q CQ' δ̂₁ δ̂₃ _ _ pw) (CQ' .comp δ̂₁ δ̂₂' δ̂₃ bs₁ bs₂))
+
+-- Coproduct machinery for the sum case of the invariance.
+ℰCP = strong-coproducts→coproducts ℰT ℰSC
+module ℰCPm = HasCoproducts ℰCP
+module ℰSCm = HasStrongCoproducts ℰSC
+module FSC = HasStrongCoproducts FM.strongCoproducts
+module FCP = HasCoproducts FM.coproducts
+
+K⊕ : ∀ (X̂ Ŷ : FM.Obj) → Iso (realise .fobj (FCP.coprod X̂ Ŷ))
+                            (ℰCPm.coprod (realise .fobj X̂) (realise .fobj Ŷ))
+K⊕ X̂ Ŷ = FR.realise-coproducts-iso ℰCP X̂ Ŷ
+
+K⊕-in₁ : ∀ (X̂ Ŷ : FM.Obj) → K⊕ X̂ Ŷ .bwd ∘ ℰSCm.in₁ ≈ realise .fmor FCP.in₁
+K⊕-in₁ X̂ Ŷ = ℰCPm.copair-in₁ _ _
+
+K⊕-in₂ : ∀ (X̂ Ŷ : FM.Obj) → K⊕ X̂ Ŷ .bwd ∘ ℰSCm.in₂ ≈ realise .fmor FCP.in₂
+K⊕-in₂ X̂ Ŷ = ℰCPm.copair-in₂ _ _
+
+K⊕-in₁' : ∀ (X̂ Ŷ : FM.Obj) → K⊕ X̂ Ŷ .fwd ∘ realise .fmor FCP.in₁ ≈ ℰSCm.in₁
+K⊕-in₁' X̂ Ŷ =
+  ≈-trans (∘-cong₂ (≈-sym (K⊕-in₁ X̂ Ŷ)))
+    (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (K⊕ X̂ Ŷ .fwd∘bwd≈id)) id-left))
+
+K⊕-in₂' : ∀ (X̂ Ŷ : FM.Obj) → K⊕ X̂ Ŷ .fwd ∘ realise .fmor FCP.in₂ ≈ ℰSCm.in₂
+K⊕-in₂' X̂ Ŷ =
+  ≈-trans (∘-cong₂ (≈-sym (K⊕-in₂ X̂ Ŷ)))
+    (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (K⊕ X̂ Ŷ .fwd∘bwd≈id)) id-left))
+
+-- Strong copair against a coproduct of morphisms, in context.
+scopair-coprod-m : ∀ {Γ X₁ X₂ Y₁ Y₂ Z : obj}
+                   (a : ℰP.prod Γ Y₁ ⇒ Z) (b : ℰP.prod Γ Y₂ ⇒ Z)
+                   (f : X₁ ⇒ Y₁) (g : X₂ ⇒ Y₂) →
+                   ℰSCm.copair a b ∘co (ℰCPm.coprod-m f g ∘ ℰP.p₂)
+                   ≈ ℰSCm.copair (a ∘co (f ∘ ℰP.p₂)) (b ∘co (g ∘ ℰP.p₂))
+scopair-coprod-m {Γ} a b f g =
+  ≈-trans (≈-sym (ℰSCm.copair-ext _)) (ℰSCm.copair-cong c₁ c₂)
+  where
+    c₁ : (ℰSCm.copair a b ∘co (ℰCPm.coprod-m f g ∘ ℰP.p₂)) ∘ ℰP.pair ℰP.p₁ (ℰSCm.in₁ ∘ ℰP.p₂)
+         ≈ a ∘co (f ∘ ℰP.p₂)
+    c₁ =
+      begin
+        (ℰSCm.copair a b ∘co (ℰCPm.coprod-m f g ∘ ℰP.p₂)) ∘co (ℰSCm.in₁ ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        ℰSCm.copair a b ∘co ((ℰCPm.coprod-m f g ∘ ℰP.p₂) ∘co (ℰSCm.in₁ ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        ℰSCm.copair a b ∘co ((ℰCPm.coprod-m f g ∘ ℰSCm.in₁) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₂ (∘-cong₁ (ℰCPm.copair-in₁ _ _)) ⟩
+        ℰSCm.copair a b ∘co ((ℰSCm.in₁ ∘ f) ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        ℰSCm.copair a b ∘co ((ℰSCm.in₁ ∘ ℰP.p₂) ∘co (f ∘ ℰP.p₂))
+      ≈˘⟨ CoK.assoc _ _ _ ⟩
+        (ℰSCm.copair a b ∘co (ℰSCm.in₁ ∘ ℰP.p₂)) ∘co (f ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (ℰSCm.copair-in₁ a b) ⟩
+        a ∘co (f ∘ ℰP.p₂)
+      ∎ where open ≈-Reasoning isEquiv
+
+    c₂ : (ℰSCm.copair a b ∘co (ℰCPm.coprod-m f g ∘ ℰP.p₂)) ∘ ℰP.pair ℰP.p₁ (ℰSCm.in₂ ∘ ℰP.p₂)
+         ≈ b ∘co (g ∘ ℰP.p₂)
+    c₂ =
+      begin
+        (ℰSCm.copair a b ∘co (ℰCPm.coprod-m f g ∘ ℰP.p₂)) ∘co (ℰSCm.in₂ ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        ℰSCm.copair a b ∘co ((ℰCPm.coprod-m f g ∘ ℰP.p₂) ∘co (ℰSCm.in₂ ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        ℰSCm.copair a b ∘co ((ℰCPm.coprod-m f g ∘ ℰSCm.in₂) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₂ (∘-cong₁ (ℰCPm.copair-in₂ _ _)) ⟩
+        ℰSCm.copair a b ∘co ((ℰSCm.in₂ ∘ g) ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        ℰSCm.copair a b ∘co ((ℰSCm.in₂ ∘ ℰP.p₂) ∘co (g ∘ ℰP.p₂))
+      ≈˘⟨ CoK.assoc _ _ _ ⟩
+        (ℰSCm.copair a b ∘co (ℰSCm.in₂ ∘ ℰP.p₂)) ∘co (g ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (ℰSCm.copair-in₂ a b) ⟩
+        b ∘co (g ∘ ℰP.p₂)
+      ∎ where open ≈-Reasoning isEquiv
+
+-- Realisation in context sends the strong copair to the strong copair, across
+-- the coproduct comparison iso.
+fmorη-scopair : ∀ (Γ : obj) (X̂ Ŷ : FM.Obj) {Ẑ : FM.Obj}
+                (u : FM.Mor (FamP.prod (η .fobj Γ) X̂) Ẑ)
+                (v : FM.Mor (FamP.prod (η .fobj Γ) Ŷ) Ẑ) →
+                fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co (K⊕ X̂ Ŷ .bwd ∘ ℰP.p₂)
+                ≈ ℰSCm.copair (fmorη Γ X̂ u) (fmorη Γ Ŷ v)
+fmorη-scopair Γ X̂ Ŷ {Ẑ} u v =
+  ≈-trans (≈-sym (ℰSCm.copair-ext _)) (ℰSCm.copair-cong c₁ c₂)
+  where
+    c₁ : (fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co (K⊕ X̂ Ŷ .bwd ∘ ℰP.p₂)) ∘ ℰP.pair ℰP.p₁ (ℰSCm.in₁ ∘ ℰP.p₂)
+         ≈ fmorη Γ X̂ u
+    c₁ =
+      begin
+        (fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co (K⊕ X̂ Ŷ .bwd ∘ ℰP.p₂)) ∘co (ℰSCm.in₁ ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co ((K⊕ X̂ Ŷ .bwd ∘ ℰP.p₂) ∘co (ℰSCm.in₁ ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co ((K⊕ X̂ Ŷ .bwd ∘ ℰSCm.in₁) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₂ (∘-cong₁ (K⊕-in₁ X̂ Ŷ)) ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co (realise .fmor FCP.in₁ ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₂ (fmorη-pure Γ X̂ FCP.in₁) ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co fmorη Γ X̂ (FM.Mor-∘ FCP.in₁ (FamP.p₂ {x = η .fobj Γ} {y = X̂}))
+      ≈˘⟨ fmorη-∘co Γ X̂ (FSC.copair u v) _ ⟩
+        fmorη Γ X̂ (FM.Mor-∘ (FSC.copair u v) (pairη Γ X̂ (FM.Mor-∘ FCP.in₁ (FamP.p₂ {x = η .fobj Γ} {y = X̂}))))
+      ≈⟨ fmorη-cong (FSC.copair-in₁ u v) ⟩
+        fmorη Γ X̂ u
+      ∎ where open ≈-Reasoning isEquiv
+
+    c₂ : (fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co (K⊕ X̂ Ŷ .bwd ∘ ℰP.p₂)) ∘ ℰP.pair ℰP.p₁ (ℰSCm.in₂ ∘ ℰP.p₂)
+         ≈ fmorη Γ Ŷ v
+    c₂ =
+      begin
+        (fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co (K⊕ X̂ Ŷ .bwd ∘ ℰP.p₂)) ∘co (ℰSCm.in₂ ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co ((K⊕ X̂ Ŷ .bwd ∘ ℰP.p₂) ∘co (ℰSCm.in₂ ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co ((K⊕ X̂ Ŷ .bwd ∘ ℰSCm.in₂) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₂ (∘-cong₁ (K⊕-in₂ X̂ Ŷ)) ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co (realise .fmor FCP.in₂ ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₂ (fmorη-pure Γ Ŷ FCP.in₂) ⟩
+        fmorη Γ (FCP.coprod X̂ Ŷ) (FSC.copair u v) ∘co fmorη Γ Ŷ (FM.Mor-∘ FCP.in₂ (FamP.p₂ {x = η .fobj Γ} {y = Ŷ}))
+      ≈˘⟨ fmorη-∘co Γ Ŷ (FSC.copair u v) _ ⟩
+        fmorη Γ Ŷ (FM.Mor-∘ (FSC.copair u v) (pairη Γ Ŷ (FM.Mor-∘ FCP.in₂ (FamP.p₂ {x = η .fobj Γ} {y = Ŷ}))))
+      ≈⟨ fmorη-cong (FSC.copair-in₂ u v) ⟩
+        fmorη Γ Ŷ v
+      ∎ where open ≈-Reasoning isEquiv
+
+-- The invariance interface at sums.
+invariance-sum : ∀ {n} {P Q : Poly ℰ n} → InvarianceAt P → InvarianceAt Q →
+               InvarianceAt (P + Q)
+private
+  module SumCase {n} {P Q : Poly ℰ n} (CP : InvarianceAt P) (CQ : InvarianceAt Q) where
+    X̂ : (Fin n → FM.Obj) → FM.Obj
+    X̂ δ̂ = FM.fobj FM.μObj (Poly-map η P) δ̂
+
+    Ŷ : (Fin n → FM.Obj) → FM.Obj
+    Ŷ δ̂ = FM.fobj FM.μObj (Poly-map η Q) δ̂
+
+    sumIso : ∀ δ̂₁ δ̂₂ (isos : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i))) →
+             Iso (realise .fobj (FCP.coprod (X̂ δ̂₁) (Ŷ δ̂₁))) (realise .fobj (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)))
+    sumIso δ̂₁ δ̂₂ isos =
+      Iso-trans (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁))
+        (Iso-trans (ℰCPm.coproduct-preserve-iso (CP .iso δ̂₁ δ̂₂ isos) (CQ .iso δ̂₁ δ̂₂ isos))
+          (Iso-sym (K⊕ (X̂ δ̂₂) (Ŷ δ̂₂))))
+
+    -- The composite forward map, with the source comparison iso cancelled.
+    sumIso-bwd : ∀ δ̂₁ δ̂₂ isos →
+                 sumIso δ̂₁ δ̂₂ isos .fwd ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .bwd
+                 ≈ K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰCPm.coprod-m (CP .iso δ̂₁ δ̂₂ isos .fwd) (CQ .iso δ̂₁ δ̂₂ isos .fwd)
+    sumIso-bwd δ̂₁ δ̂₂ isos =
+      ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd∘bwd≈id)) id-right)
+
+
+    sumComp : ∀ δ̂₁ δ̂₂ δ̂₃ (isos₁₂ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+              (isos₂₃ : ∀ i → Iso (realise .fobj (δ̂₂ i)) (realise .fobj (δ̂₃ i))) →
+              sumIso δ̂₁ δ̂₃ (λ i → Iso-trans (isos₁₂ i) (isos₂₃ i)) .fwd
+              ≈ sumIso δ̂₂ δ̂₃ isos₂₃ .fwd ∘ sumIso δ̂₁ δ̂₂ isos₁₂ .fwd
+    sumComp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃ = ≈-trans toM (≈-sym fromM)
+      where
+        cm₁₂ = ℰCPm.coprod-m (CP .iso δ̂₁ δ̂₂ isos₁₂ .fwd) (CQ .iso δ̂₁ δ̂₂ isos₁₂ .fwd)
+        cm₂₃ = ℰCPm.coprod-m (CP .iso δ̂₂ δ̂₃ isos₂₃ .fwd) (CQ .iso δ̂₂ δ̂₃ isos₂₃ .fwd)
+
+        toM : sumIso δ̂₁ δ̂₃ (λ i → Iso-trans (isos₁₂ i) (isos₂₃ i)) .fwd
+              ≈ (K⊕ (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ (cm₂₃ ∘ cm₁₂)) ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+        toM =
+          ∘-cong₁ (∘-cong₂
+            (≈-trans (ℰCPm.coprod-m-cong (CP .comp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃) (CQ .comp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃))
+              (ℰCPm.coprod-m-comp _ _ _ _)))
+
+        fromM : sumIso δ̂₂ δ̂₃ isos₂₃ .fwd ∘ sumIso δ̂₁ δ̂₂ isos₁₂ .fwd
+                ≈ (K⊕ (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ (cm₂₃ ∘ cm₁₂)) ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+        fromM =
+          begin
+            ((K⊕ (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ cm₂₃) ∘ K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .fwd) ∘ ((K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ cm₁₂) ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd)
+          ≈˘⟨ assoc _ _ _ ⟩
+            (((K⊕ (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ cm₂₃) ∘ K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .fwd) ∘ (K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ cm₁₂)) ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ≈⟨ ∘-cong₁ (assoc _ _ _) ⟩
+            ((K⊕ (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ cm₂₃) ∘ (K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .fwd ∘ (K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ cm₁₂))) ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ≈⟨ ∘-cong₁ (∘-cong₂ (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .fwd∘bwd≈id)) id-left))) ⟩
+            ((K⊕ (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ cm₂₃) ∘ cm₁₂) ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ≈⟨ ∘-cong₁ (assoc _ _ _) ⟩
+            (K⊕ (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ (cm₂₃ ∘ cm₁₂)) ∘ K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ∎ where open ≈-Reasoning isEquiv
+
+    sumNat : ∀ {Γ : obj} {ε̂₁ ε̂₂ : Fin n → FM.Obj}
+             (δ̂₁ δ̂₂ : Fin n → FM.Obj)
+             (isosδ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+             (isosε : ∀ i → Iso (realise .fobj (ε̂₁ i)) (realise .fobj (ε̂₂ i)))
+             (gs₁ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₁ i)) (ε̂₁ i))
+             (gs₂ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₂ i)) (ε̂₂ i)) →
+             (∀ i → fmorη Γ (δ̂₂ i) (gs₂ i) ∘co (isosδ i .fwd ∘ ℰP.p₂)
+                    ≈ isosε i .fwd ∘ fmorη Γ (δ̂₁ i) (gs₁ i)) →
+             fmorη Γ (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)) (FMu.strong-fmor (Poly-map η (P + Q)) gs₂)
+               ∘co (sumIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)
+             ≈ sumIso _ _ isosε .fwd ∘ fmorη Γ (FCP.coprod (X̂ δ̂₁) (Ŷ δ̂₁)) (FMu.strong-fmor (Poly-map η (P + Q)) gs₁)
+    sumNat {Γ} {ε̂₁} {ε̂₂} δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs =
+      co-iso-epi (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁)) (≈-trans lhs (≈-sym rhs))
+      where
+        sfP : ∀ δ̂ ε̂ → (∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂ i)) (ε̂ i)) → FM.Mor (FamP.prod (η .fobj Γ) (X̂ δ̂)) (X̂ ε̂)
+        sfP δ̂ ε̂ gs = FMu.strong-fmor (Poly-map η P) gs
+
+        sfQ : ∀ δ̂ ε̂ → (∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂ i)) (ε̂ i)) → FM.Mor (FamP.prod (η .fobj Γ) (Ŷ δ̂)) (Ŷ ε̂)
+        sfQ δ̂ ε̂ gs = FMu.strong-fmor (Poly-map η Q) gs
+
+        mid : ℰP.prod Γ (ℰCPm.coprod (realise .fobj (X̂ δ̂₁)) (realise .fobj (Ŷ δ̂₁))) ⇒ realise .fobj (FCP.coprod (X̂ ε̂₂) (Ŷ ε̂₂))
+        mid = ℰSCm.copair
+                (realise .fmor FCP.in₁ ∘ (CP .iso ε̂₁ ε̂₂ isosε .fwd ∘ fmorη Γ (X̂ δ̂₁) (sfP δ̂₁ ε̂₁ gs₁)))
+                (realise .fmor FCP.in₂ ∘ (CQ .iso ε̂₁ ε̂₂ isosε .fwd ∘ fmorη Γ (Ŷ δ̂₁) (sfQ δ̂₁ ε̂₁ gs₁)))
+
+        lhs : (fmorη Γ (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂)))
+                ∘co (sumIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)) ∘co (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+              ≈ mid
+        lhs =
+          begin
+            (fmorη Γ (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂))) ∘co (sumIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)) ∘co (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            fmorη Γ (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂))) ∘co ((sumIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂) ∘co (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂))
+          ≈⟨ CoK.∘-cong₂ (≈-trans (co-pure _ _) (∘-cong₁ (sumIso-bwd δ̂₁ δ̂₂ isosδ))) ⟩
+            fmorη Γ (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂))) ∘co ((K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰCPm.coprod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd)) ∘ ℰP.p₂)
+          ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+            fmorη Γ (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂))) ∘co ((K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰP.p₂) ∘co (ℰCPm.coprod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd) ∘ ℰP.p₂))
+          ≈˘⟨ CoK.assoc _ _ _ ⟩
+            (fmorη Γ (FCP.coprod (X̂ δ̂₂) (Ŷ δ̂₂)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂))) ∘co (K⊕ (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰP.p₂)) ∘co (ℰCPm.coprod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd) ∘ ℰP.p₂)
+          ≈⟨ CoK.∘-cong₁ (fmorη-scopair Γ (X̂ δ̂₂) (Ŷ δ̂₂) _ _) ⟩
+            ℰSCm.copair (fmorη Γ (X̂ δ̂₂) (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂))) (fmorη Γ (Ŷ δ̂₂) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂))) ∘co (ℰCPm.coprod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd) ∘ ℰP.p₂)
+          ≈⟨ scopair-coprod-m _ _ _ _ ⟩
+            ℰSCm.copair (fmorη Γ (X̂ δ̂₂) (FM.Mor-∘ FCP.in₁ (sfP δ̂₂ ε̂₂ gs₂)) ∘co (CP .iso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)) (fmorη Γ (Ŷ δ̂₂) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₂ ε̂₂ gs₂)) ∘co (CQ .iso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂))
+          ≈⟨ ℰSCm.copair-cong (≈-trans (CoK.∘-cong₁ (fmorη-post Γ (X̂ δ̂₂) FCP.in₁ _)) (≈-trans (assoc _ _ _) (∘-cong₂ (CP .natural δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs)))) (≈-trans (CoK.∘-cong₁ (fmorη-post Γ (Ŷ δ̂₂) FCP.in₂ _)) (≈-trans (assoc _ _ _) (∘-cong₂ (CQ .natural δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs)))) ⟩
+            mid
+          ∎
+          where
+            open ≈-Reasoning isEquiv
+
+
+
+        rhs : (sumIso _ _ isosε .fwd ∘ fmorη Γ (FCP.coprod (X̂ δ̂₁) (Ŷ δ̂₁)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₁ ε̂₁ gs₁)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₁ ε̂₁ gs₁))))
+                ∘co (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+              ≈ mid
+        rhs =
+          begin
+            (sumIso _ _ isosε .fwd ∘ fmorη Γ (FCP.coprod (X̂ δ̂₁) (Ŷ δ̂₁)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₁ ε̂₁ gs₁)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₁ ε̂₁ gs₁)))) ∘co (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+          ≈⟨ assoc _ _ _ ⟩
+            sumIso _ _ isosε .fwd ∘ (fmorη Γ (FCP.coprod (X̂ δ̂₁) (Ŷ δ̂₁)) (FSC.copair (FM.Mor-∘ FCP.in₁ (sfP δ̂₁ ε̂₁ gs₁)) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₁ ε̂₁ gs₁))) ∘co (K⊕ (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂))
+          ≈⟨ ∘-cong₂ (fmorη-scopair Γ (X̂ δ̂₁) (Ŷ δ̂₁) _ _) ⟩
+            sumIso _ _ isosε .fwd ∘ ℰSCm.copair (fmorη Γ (X̂ δ̂₁) (FM.Mor-∘ FCP.in₁ (sfP δ̂₁ ε̂₁ gs₁))) (fmorη Γ (Ŷ δ̂₁) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₁ ε̂₁ gs₁)))
+          ≈⟨ ℰSCm.copair-natural _ _ _ ⟩
+            ℰSCm.copair (sumIso _ _ isosε .fwd ∘ fmorη Γ (X̂ δ̂₁) (FM.Mor-∘ FCP.in₁ (sfP δ̂₁ ε̂₁ gs₁))) (sumIso _ _ isosε .fwd ∘ fmorη Γ (Ŷ δ̂₁) (FM.Mor-∘ FCP.in₂ (sfQ δ̂₁ ε̂₁ gs₁)))
+          ≈⟨ ℰSCm.copair-cong (≈-trans (∘-cong₂ (fmorη-post Γ (X̂ δ̂₁) FCP.in₁ _)) (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ push-in₁) (assoc _ _ _)))) (≈-trans (∘-cong₂ (fmorη-post Γ (Ŷ δ̂₁) FCP.in₂ _)) (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ push-in₂) (assoc _ _ _)))) ⟩
+            mid
+          ∎
+          where
+            open ≈-Reasoning isEquiv
+
+            push-in₁ : sumIso _ _ isosε .fwd ∘ realise .fmor FCP.in₁
+                       ≈ realise .fmor FCP.in₁ ∘ CP .iso ε̂₁ ε̂₂ isosε .fwd
+            push-in₁ =
+              ≈-trans (assoc _ _ _)
+                (≈-trans (∘-cong₂ (K⊕-in₁' (X̂ ε̂₁) (Ŷ ε̂₁)))
+                  (≈-trans (assoc _ _ _)
+                    (≈-trans (∘-cong₂ (ℰCPm.copair-in₁ _ _))
+                      (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (K⊕-in₁ (X̂ ε̂₂) (Ŷ ε̂₂)))))))
+
+            push-in₂ : sumIso _ _ isosε .fwd ∘ realise .fmor FCP.in₂
+                       ≈ realise .fmor FCP.in₂ ∘ CQ .iso ε̂₁ ε̂₂ isosε .fwd
+            push-in₂ =
+              ≈-trans (assoc _ _ _)
+                (≈-trans (∘-cong₂ (K⊕-in₂' (X̂ ε̂₁) (Ŷ ε̂₁)))
+                  (≈-trans (assoc _ _ _)
+                    (≈-trans (∘-cong₂ (ℰCPm.copair-in₂ _ _))
+                      (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (K⊕-in₂ (X̂ ε̂₂) (Ŷ ε̂₂)))))))
+
+invariance-sum {n} {P} {Q} CP CQ .iso = SumCase.sumIso CP CQ
+invariance-sum {n} {P} {Q} CP CQ .natural = SumCase.sumNat CP CQ
+invariance-sum {n} {P} {Q} CP CQ .comp = SumCase.sumComp CP CQ
+
+-- Product machinery for the product case of the invariance.
+K× : ∀ (X̂ Ŷ : FM.Obj) → Iso (realise .fobj (FamP.prod X̂ Ŷ))
+                            (ℰP.prod (realise .fobj X̂) (realise .fobj Ŷ))
+K× X̂ Ŷ = FR.realise-products-iso ℰP ℰE X̂ Ŷ
+
+K×-p₁ : ∀ (X̂ Ŷ : FM.Obj) → realise .fmor (FamP.p₁ {x = X̂} {y = Ŷ}) ∘ K× X̂ Ŷ .bwd ≈ ℰP.p₁
+K×-p₁ X̂ Ŷ =
+  ≈-trans (∘-cong₁ (≈-sym (FR.realise-products-p₁ ℰP ℰE X̂ Ŷ)))
+    (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (K× X̂ Ŷ .fwd∘bwd≈id)) id-right))
+
+K×-p₂ : ∀ (X̂ Ŷ : FM.Obj) → realise .fmor (FamP.p₂ {x = X̂} {y = Ŷ}) ∘ K× X̂ Ŷ .bwd ≈ ℰP.p₂
+K×-p₂ X̂ Ŷ =
+  ≈-trans (∘-cong₁ (≈-sym (FR.realise-products-p₂ ℰP ℰE X̂ Ŷ)))
+    (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (K× X̂ Ŷ .fwd∘bwd≈id)) id-right))
+
+-- Realisation in context sends the strong product action to the strong
+-- product action, across the product comparison isos.
+fmorη-sprodm : ∀ (Γ : obj) (X̂ Ŷ : FM.Obj) {Ẑ₁ Ẑ₂ : FM.Obj}
+               (u : FM.Mor (FamP.prod (η .fobj Γ) X̂) Ẑ₁)
+               (v : FM.Mor (FamP.prod (η .fobj Γ) Ŷ) Ẑ₂) →
+               fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+               ≈ K× Ẑ₁ Ẑ₂ .bwd ∘ ℰP.strong-prod-m (fmorη Γ X̂ u) (fmorη Γ Ŷ v)
+fmorη-sprodm Γ X̂ Ŷ {Ẑ₁} {Ẑ₂} u v =
+  iso-shuffle (K× Ẑ₁ Ẑ₂) _ _
+    (≈-trans (≈-sym (ℰP.pair-ext _)) (ℰP.pair-cong core₁ core₂))
+  where
+    core₁ : ℰP.p₁ ∘ (K× Ẑ₁ Ẑ₂ .fwd ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)))
+            ≈ fmorη Γ X̂ u ∘ ℰP.strong-p₁
+    core₁ =
+      begin
+        ℰP.p₁ ∘ (K× Ẑ₁ Ẑ₂ .fwd ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)))
+      ≈˘⟨ assoc _ _ _ ⟩
+        (ℰP.p₁ ∘ K× Ẑ₁ Ẑ₂ .fwd) ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂))
+      ≈⟨ ∘-cong₁ (FR.realise-products-p₁ ℰP ℰE Ẑ₁ Ẑ₂) ⟩
+        realise .fmor (FamP.p₁ {x = Ẑ₁} {y = Ẑ₂}) ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂))
+      ≈˘⟨ assoc _ _ _ ⟩
+        (realise .fmor (FamP.p₁ {x = Ẑ₁} {y = Ẑ₂}) ∘ fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₁ (fmorη-post Γ (FamP.prod X̂ Ŷ) _ _) ⟩
+        fmorη Γ (FamP.prod X̂ Ŷ) (FM.Mor-∘ (FamP.p₁ {x = Ẑ₁} {y = Ẑ₂}) (FamP.strong-prod-m u v)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (fmorη-cong (FamP.pair-p₁ _ _)) ⟩
+        fmorη Γ (FamP.prod X̂ Ŷ) (FM.Mor-∘ u FamP.strong-p₁) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (fmorη-∘co Γ (FamP.prod X̂ Ŷ) u _) ⟩
+        (fmorη Γ X̂ u ∘co fmorη Γ (FamP.prod X̂ Ŷ) (FM.Mor-∘ (FamP.p₁ {x = X̂} {y = Ŷ}) FamP.p₂)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (CoK.∘-cong₂ (fmorη-pure Γ (FamP.prod X̂ Ŷ) (FamP.p₁ {x = X̂} {y = Ŷ}))) ⟩
+        (fmorη Γ X̂ u ∘co (realise .fmor (FamP.p₁ {x = X̂} {y = Ŷ}) ∘ ℰP.p₂)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        fmorη Γ X̂ u ∘co ((realise .fmor (FamP.p₁ {x = X̂} {y = Ŷ}) ∘ ℰP.p₂) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        fmorη Γ X̂ u ∘co ((realise .fmor (FamP.p₁ {x = X̂} {y = Ŷ}) ∘ K× X̂ Ŷ .bwd) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₂ (∘-cong₁ (K×-p₁ X̂ Ŷ)) ⟩
+        fmorη Γ X̂ u ∘co (ℰP.p₁ ∘ ℰP.p₂)
+      ∎ where open ≈-Reasoning isEquiv
+
+    core₂ : ℰP.p₂ ∘ (K× Ẑ₁ Ẑ₂ .fwd ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)))
+            ≈ fmorη Γ Ŷ v ∘ ℰP.strong-p₂
+    core₂ =
+      begin
+        ℰP.p₂ ∘ (K× Ẑ₁ Ẑ₂ .fwd ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)))
+      ≈˘⟨ assoc _ _ _ ⟩
+        (ℰP.p₂ ∘ K× Ẑ₁ Ẑ₂ .fwd) ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂))
+      ≈⟨ ∘-cong₁ (FR.realise-products-p₂ ℰP ℰE Ẑ₁ Ẑ₂) ⟩
+        realise .fmor (FamP.p₂ {x = Ẑ₁} {y = Ẑ₂}) ∘ (fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂))
+      ≈˘⟨ assoc _ _ _ ⟩
+        (realise .fmor (FamP.p₂ {x = Ẑ₁} {y = Ẑ₂}) ∘ fmorη Γ (FamP.prod X̂ Ŷ) (FamP.strong-prod-m u v)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₁ (fmorη-post Γ (FamP.prod X̂ Ŷ) _ _) ⟩
+        fmorη Γ (FamP.prod X̂ Ŷ) (FM.Mor-∘ (FamP.p₂ {x = Ẑ₁} {y = Ẑ₂}) (FamP.strong-prod-m u v)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (fmorη-cong (FamP.pair-p₂ _ _)) ⟩
+        fmorη Γ (FamP.prod X̂ Ŷ) (FM.Mor-∘ v FamP.strong-p₂) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (fmorη-∘co Γ (FamP.prod X̂ Ŷ) v _) ⟩
+        (fmorη Γ Ŷ v ∘co fmorη Γ (FamP.prod X̂ Ŷ) (FM.Mor-∘ (FamP.p₂ {x = X̂} {y = Ŷ}) FamP.p₂)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (CoK.∘-cong₂ (fmorη-pure Γ (FamP.prod X̂ Ŷ) (FamP.p₂ {x = X̂} {y = Ŷ}))) ⟩
+        (fmorη Γ Ŷ v ∘co (realise .fmor (FamP.p₂ {x = X̂} {y = Ŷ}) ∘ ℰP.p₂)) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        fmorη Γ Ŷ v ∘co ((realise .fmor (FamP.p₂ {x = X̂} {y = Ŷ}) ∘ ℰP.p₂) ∘co (K× X̂ Ŷ .bwd ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        fmorη Γ Ŷ v ∘co ((realise .fmor (FamP.p₂ {x = X̂} {y = Ŷ}) ∘ K× X̂ Ŷ .bwd) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₂ (∘-cong₁ (K×-p₂ X̂ Ŷ)) ⟩
+        fmorη Γ Ŷ v ∘co (ℰP.p₂ ∘ ℰP.p₂)
+      ∎ where open ≈-Reasoning isEquiv
+
+-- The invariance interface at products.
+invariance-prod : ∀ {n} {P Q : Poly ℰ n} → InvarianceAt P → InvarianceAt Q →
+                InvarianceAt (P × Q)
+private
+  module ProdCase {n} {P Q : Poly ℰ n} (CP : InvarianceAt P) (CQ : InvarianceAt Q) where
+    X̂ : (Fin n → FM.Obj) → FM.Obj
+    X̂ δ̂ = FM.fobj FM.μObj (Poly-map η P) δ̂
+
+    Ŷ : (Fin n → FM.Obj) → FM.Obj
+    Ŷ δ̂ = FM.fobj FM.μObj (Poly-map η Q) δ̂
+
+    prodIso : ∀ δ̂₁ δ̂₂ (isos : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i))) →
+              Iso (realise .fobj (FamP.prod (X̂ δ̂₁) (Ŷ δ̂₁))) (realise .fobj (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)))
+    prodIso δ̂₁ δ̂₂ isos =
+      Iso-trans (K× (X̂ δ̂₁) (Ŷ δ̂₁))
+        (Iso-trans (ℰP.product-preserves-iso (CP .iso δ̂₁ δ̂₂ isos) (CQ .iso δ̂₁ δ̂₂ isos))
+          (Iso-sym (K× (X̂ δ̂₂) (Ŷ δ̂₂))))
+
+    prodIso-bwd : ∀ δ̂₁ δ̂₂ isos →
+                  prodIso δ̂₁ δ̂₂ isos .fwd ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .bwd
+                  ≈ K× (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isos .fwd) (CQ .iso δ̂₁ δ̂₂ isos .fwd)
+    prodIso-bwd δ̂₁ δ̂₂ isos =
+      ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd∘bwd≈id)) id-right)
+
+
+    prodComp : ∀ δ̂₁ δ̂₂ δ̂₃ (isos₁₂ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+               (isos₂₃ : ∀ i → Iso (realise .fobj (δ̂₂ i)) (realise .fobj (δ̂₃ i))) →
+               prodIso δ̂₁ δ̂₃ (λ i → Iso-trans (isos₁₂ i) (isos₂₃ i)) .fwd
+               ≈ prodIso δ̂₂ δ̂₃ isos₂₃ .fwd ∘ prodIso δ̂₁ δ̂₂ isos₁₂ .fwd
+    prodComp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃ = ≈-trans toM (≈-sym fromM)
+      where
+        pm₁₂ = ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isos₁₂ .fwd) (CQ .iso δ̂₁ δ̂₂ isos₁₂ .fwd)
+        pm₂₃ = ℰP.prod-m (CP .iso δ̂₂ δ̂₃ isos₂₃ .fwd) (CQ .iso δ̂₂ δ̂₃ isos₂₃ .fwd)
+
+        toM : prodIso δ̂₁ δ̂₃ (λ i → Iso-trans (isos₁₂ i) (isos₂₃ i)) .fwd
+              ≈ (K× (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ (pm₂₃ ∘ pm₁₂)) ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+        toM =
+          ∘-cong₁ (∘-cong₂
+            (≈-trans (ℰP.prod-m-cong (CP .comp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃) (CQ .comp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃))
+              (ℰP.prod-m-comp _ _ _ _)))
+
+        fromM : prodIso δ̂₂ δ̂₃ isos₂₃ .fwd ∘ prodIso δ̂₁ δ̂₂ isos₁₂ .fwd
+                ≈ (K× (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ (pm₂₃ ∘ pm₁₂)) ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+        fromM =
+          begin
+            ((K× (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ pm₂₃) ∘ K× (X̂ δ̂₂) (Ŷ δ̂₂) .fwd) ∘ ((K× (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ pm₁₂) ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd)
+          ≈˘⟨ assoc _ _ _ ⟩
+            (((K× (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ pm₂₃) ∘ K× (X̂ δ̂₂) (Ŷ δ̂₂) .fwd) ∘ (K× (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ pm₁₂)) ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ≈⟨ ∘-cong₁ (assoc _ _ _) ⟩
+            ((K× (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ pm₂₃) ∘ (K× (X̂ δ̂₂) (Ŷ δ̂₂) .fwd ∘ (K× (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ pm₁₂))) ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ≈⟨ ∘-cong₁ (∘-cong₂ (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (K× (X̂ δ̂₂) (Ŷ δ̂₂) .fwd∘bwd≈id)) id-left))) ⟩
+            ((K× (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ pm₂₃) ∘ pm₁₂) ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ≈⟨ ∘-cong₁ (assoc _ _ _) ⟩
+            (K× (X̂ δ̂₃) (Ŷ δ̂₃) .bwd ∘ (pm₂₃ ∘ pm₁₂)) ∘ K× (X̂ δ̂₁) (Ŷ δ̂₁) .fwd
+          ∎ where open ≈-Reasoning isEquiv
+
+    prodNat : ∀ {Γ : obj} {ε̂₁ ε̂₂ : Fin n → FM.Obj}
+              (δ̂₁ δ̂₂ : Fin n → FM.Obj)
+              (isosδ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+              (isosε : ∀ i → Iso (realise .fobj (ε̂₁ i)) (realise .fobj (ε̂₂ i)))
+              (gs₁ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₁ i)) (ε̂₁ i))
+              (gs₂ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₂ i)) (ε̂₂ i)) →
+              (∀ i → fmorη Γ (δ̂₂ i) (gs₂ i) ∘co (isosδ i .fwd ∘ ℰP.p₂)
+                     ≈ isosε i .fwd ∘ fmorη Γ (δ̂₁ i) (gs₁ i)) →
+              fmorη Γ (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)) (FMu.strong-fmor (Poly-map η (P × Q)) gs₂)
+                ∘co (prodIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)
+              ≈ prodIso _ _ isosε .fwd ∘ fmorη Γ (FamP.prod (X̂ δ̂₁) (Ŷ δ̂₁)) (FMu.strong-fmor (Poly-map η (P × Q)) gs₁)
+    prodNat {Γ} {ε̂₁} {ε̂₂} δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs =
+      co-iso-epi (K× (X̂ δ̂₁) (Ŷ δ̂₁)) (≈-trans lhs (≈-sym rhs))
+      where
+        sfP = FMu.strong-fmor (Poly-map η P)
+        sfQ = FMu.strong-fmor (Poly-map η Q)
+
+        mid : ℰP.prod Γ (ℰP.prod (realise .fobj (X̂ δ̂₁)) (realise .fobj (Ŷ δ̂₁))) ⇒ realise .fobj (FamP.prod (X̂ ε̂₂) (Ŷ ε̂₂))
+        mid = K× (X̂ ε̂₂) (Ŷ ε̂₂) .bwd ∘
+              ℰP.strong-prod-m
+                (CP .iso ε̂₁ ε̂₂ isosε .fwd ∘ fmorη Γ (X̂ δ̂₁) (sfP gs₁))
+                (CQ .iso ε̂₁ ε̂₂ isosε .fwd ∘ fmorη Γ (Ŷ δ̂₁) (sfQ gs₁))
+
+        lhs : (fmorη Γ (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)) (FamP.strong-prod-m (sfP gs₂) (sfQ gs₂))
+                ∘co (prodIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)) ∘co (K× (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+              ≈ mid
+        lhs =
+          begin
+            (fmorη Γ (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)) (FamP.strong-prod-m (sfP gs₂) (sfQ gs₂)) ∘co (prodIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂)) ∘co (K× (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            fmorη Γ (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)) (FamP.strong-prod-m (sfP gs₂) (sfQ gs₂)) ∘co ((prodIso δ̂₁ δ̂₂ isosδ .fwd ∘ ℰP.p₂) ∘co (K× (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂))
+          ≈⟨ CoK.∘-cong₂ (≈-trans (co-pure _ _) (∘-cong₁ (prodIso-bwd δ̂₁ δ̂₂ isosδ))) ⟩
+            fmorη Γ (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)) (FamP.strong-prod-m (sfP gs₂) (sfQ gs₂)) ∘co ((K× (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd)) ∘ ℰP.p₂)
+          ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+            fmorη Γ (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)) (FamP.strong-prod-m (sfP gs₂) (sfQ gs₂)) ∘co ((K× (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰP.p₂) ∘co (ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd) ∘ ℰP.p₂))
+          ≈˘⟨ CoK.assoc _ _ _ ⟩
+            (fmorη Γ (FamP.prod (X̂ δ̂₂) (Ŷ δ̂₂)) (FamP.strong-prod-m (sfP gs₂) (sfQ gs₂)) ∘co (K× (X̂ δ̂₂) (Ŷ δ̂₂) .bwd ∘ ℰP.p₂)) ∘co (ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd) ∘ ℰP.p₂)
+          ≈⟨ CoK.∘-cong₁ (fmorη-sprodm Γ (X̂ δ̂₂) (Ŷ δ̂₂) _ _) ⟩
+            (K× (X̂ ε̂₂) (Ŷ ε̂₂) .bwd ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₂) (sfP gs₂)) (fmorη Γ (Ŷ δ̂₂) (sfQ gs₂))) ∘co (ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd) ∘ ℰP.p₂)
+          ≈⟨ assoc _ _ _ ⟩
+            K× (X̂ ε̂₂) (Ŷ ε̂₂) .bwd ∘ (ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₂) (sfP gs₂)) (fmorη Γ (Ŷ δ̂₂) (sfQ gs₂)) ∘co (ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd) ∘ ℰP.p₂))
+          ≈⟨ ∘-cong₂ (∘-cong₂ (ℰP.pair-cong (≈-sym id-left) ≈-refl)) ⟩
+            K× (X̂ ε̂₂) (Ŷ ε̂₂) .bwd ∘ (ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₂) (sfP gs₂)) (fmorη Γ (Ŷ δ̂₂) (sfQ gs₂)) ∘ ℰP.prod-m (id _) (ℰP.prod-m (CP .iso δ̂₁ δ̂₂ isosδ .fwd) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd)))
+          ≈⟨ ∘-cong₂ (ℰP.strong-prod-m-pre _ _ _ _ _) ⟩
+            K× (X̂ ε̂₂) (Ŷ ε̂₂) .bwd ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₂) (sfP gs₂) ∘ ℰP.prod-m (id _) (CP .iso δ̂₁ δ̂₂ isosδ .fwd)) (fmorη Γ (Ŷ δ̂₂) (sfQ gs₂) ∘ ℰP.prod-m (id _) (CQ .iso δ̂₁ δ̂₂ isosδ .fwd))
+          ≈⟨ ∘-cong₂ (ℰP.strong-prod-m-cong (≈-trans (∘-cong₂ (ℰP.pair-cong id-left ≈-refl)) (CP .natural δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs)) (≈-trans (∘-cong₂ (ℰP.pair-cong id-left ≈-refl)) (CQ .natural δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs))) ⟩
+            mid
+          ∎
+          where
+            open ≈-Reasoning isEquiv
+
+
+
+        rhs : (prodIso _ _ isosε .fwd ∘ fmorη Γ (FamP.prod (X̂ δ̂₁) (Ŷ δ̂₁)) (FamP.strong-prod-m (sfP gs₁) (sfQ gs₁)))
+                ∘co (K× (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+              ≈ mid
+        rhs =
+          begin
+            (prodIso _ _ isosε .fwd ∘ fmorη Γ (FamP.prod (X̂ δ̂₁) (Ŷ δ̂₁)) (FamP.strong-prod-m (sfP gs₁) (sfQ gs₁))) ∘co (K× (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂)
+          ≈⟨ assoc _ _ _ ⟩
+            prodIso _ _ isosε .fwd ∘ (fmorη Γ (FamP.prod (X̂ δ̂₁) (Ŷ δ̂₁)) (FamP.strong-prod-m (sfP gs₁) (sfQ gs₁)) ∘co (K× (X̂ δ̂₁) (Ŷ δ̂₁) .bwd ∘ ℰP.p₂))
+          ≈⟨ ∘-cong₂ (fmorη-sprodm Γ (X̂ δ̂₁) (Ŷ δ̂₁) _ _) ⟩
+            prodIso _ _ isosε .fwd ∘ (K× (X̂ ε̂₁) (Ŷ ε̂₁) .bwd ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₁) (sfP gs₁)) (fmorη Γ (Ŷ δ̂₁) (sfQ gs₁)))
+          ≈˘⟨ assoc _ _ _ ⟩
+            (prodIso _ _ isosε .fwd ∘ K× (X̂ ε̂₁) (Ŷ ε̂₁) .bwd) ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₁) (sfP gs₁)) (fmorη Γ (Ŷ δ̂₁) (sfQ gs₁))
+          ≈⟨ ∘-cong₁ (prodIso-bwd ε̂₁ ε̂₂ isosε) ⟩
+            (K× (X̂ ε̂₂) (Ŷ ε̂₂) .bwd ∘ ℰP.prod-m (CP .iso ε̂₁ ε̂₂ isosε .fwd) (CQ .iso ε̂₁ ε̂₂ isosε .fwd)) ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₁) (sfP gs₁)) (fmorη Γ (Ŷ δ̂₁) (sfQ gs₁))
+          ≈⟨ assoc _ _ _ ⟩
+            K× (X̂ ε̂₂) (Ŷ ε̂₂) .bwd ∘ (ℰP.prod-m (CP .iso ε̂₁ ε̂₂ isosε .fwd) (CQ .iso ε̂₁ ε̂₂ isosε .fwd) ∘ ℰP.strong-prod-m (fmorη Γ (X̂ δ̂₁) (sfP gs₁)) (fmorη Γ (Ŷ δ̂₁) (sfQ gs₁)))
+          ≈⟨ ∘-cong₂ (ℰP.strong-prod-m-post _ _ _ _) ⟩
+            mid
+          ∎ where open ≈-Reasoning isEquiv
+
+invariance-prod {n} {P} {Q} CP CQ .iso = ProdCase.prodIso CP CQ
+invariance-prod {n} {P} {Q} CP CQ .natural = ProdCase.prodNat CP CQ
+invariance-prod {n} {P} {Q} CP CQ .comp = ProdCase.prodComp CP CQ
+
+-- Extend an isomorphism family by an isomorphism at the bound entry.
+mixed : ∀ {n} {δ̂₁ δ̂₂ : Fin n → FM.Obj}
+        (isos : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+        {Ŷ₁ Ŷ₂ : FM.Obj} (J : Iso (realise .fobj Ŷ₁) (realise .fobj Ŷ₂)) →
+        ∀ i → Iso (realise .fobj (extend δ̂₁ Ŷ₁ i)) (realise .fobj (extend δ̂₂ Ŷ₂ i))
+mixed isos J Fin.zero    = J
+mixed isos J (Fin.suc i) = isos i
+
+-- The strong action at extended environments commutes with an isomorphism at
+-- the bound entry and the given isomorphisms elsewhere.
+cross-mixed : ∀ {n} (Q : Poly ℰ (suc n)) (CQ : InvarianceAt Q) {Γ : obj}
+              {δ̂₁ δ̂₂ ε̂₁ ε̂₂ : Fin n → FM.Obj}
+              (isosδ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+              (isosε : ∀ i → Iso (realise .fobj (ε̂₁ i)) (realise .fobj (ε̂₂ i)))
+              {Ŷ₁ Ŷ₂ : FM.Obj} (J : Iso (realise .fobj Ŷ₁) (realise .fobj Ŷ₂))
+              (gs₁ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₁ i)) (ε̂₁ i))
+              (gs₂ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₂ i)) (ε̂₂ i)) →
+              (∀ i → fmorη Γ (δ̂₂ i) (gs₂ i) ∘co (isosδ i .fwd ∘ ℰP.p₂)
+                     ≈ isosε i .fwd ∘ fmorη Γ (δ̂₁ i) (gs₁ i)) →
+              fmorη Γ (FM.fobj FM.μObj (Poly-map η Q) (extend δ̂₂ Ŷ₂))
+                 (FMu.strong-fmor (Poly-map η Q) (FMu.strong-extend-mor gs₂ FamP.p₂))
+                ∘co (CQ .iso (extend δ̂₁ Ŷ₁) (extend δ̂₂ Ŷ₂) (mixed isosδ J) .fwd ∘ ℰP.p₂)
+              ≈ CQ .iso (extend ε̂₁ Ŷ₁) (extend ε̂₂ Ŷ₂) (mixed isosε J) .fwd
+                 ∘ fmorη Γ (FM.fobj FM.μObj (Poly-map η Q) (extend δ̂₁ Ŷ₁))
+                     (FMu.strong-fmor (Poly-map η Q) (FMu.strong-extend-mor gs₁ FamP.p₂))
+cross-mixed Q CQ {Γ} {δ̂₁} {δ̂₂} {ε̂₁} {ε̂₂} isosδ isosε {Ŷ₁} {Ŷ₂} J gs₁ gs₂ sqs =
+  CQ .natural (extend δ̂₁ Ŷ₁) (extend δ̂₂ Ŷ₂) (mixed isosδ J) (mixed isosε J)
+    (FMu.strong-extend-mor gs₁ FamP.p₂)
+    (FMu.strong-extend-mor gs₂ FamP.p₂)
+    compats
+  where
+    compats : ∀ i → fmorη Γ (extend δ̂₂ Ŷ₂ i) (FMu.strong-extend-mor gs₂ FamP.p₂ i) ∘co (mixed isosδ J i .fwd ∘ ℰP.p₂)
+              ≈ mixed isosε J i .fwd ∘ fmorη Γ (extend δ̂₁ Ŷ₁ i) (FMu.strong-extend-mor gs₁ FamP.p₂ i)
+    compats Fin.zero    = sq-p₂ J
+    compats (Fin.suc i) = sqs i
+
+-- A invariance at realisations of pure Fam(ℰ) morphisms is the realised plain
+-- action.
+pure-invariance : ∀ {n} (Q : Poly ℰ (suc n)) (CQ' : InvarianceAt Q) (δ̂₁ δ̂₂ : Fin (suc n) → FM.Obj)
+                (ms : ∀ i → FM.Mor (δ̂₁ i) (δ̂₂ i))
+                (isos : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i))) →
+                (∀ i → isos i .fwd ≈ realise .fmor (ms i)) →
+                CQ' .iso δ̂₁ δ̂₂ isos .fwd ≈ realise .fmor (FMu.fmor (Poly-map η Q) ms)
+pure-invariance {n} Q CQ' δ̂₁ δ̂₂ ms isos hyps =
+  p₂-cancel (≈-trans (≈-sym strip₁) (≈-trans (CQ' .natural δ̂₁ δ̂₂ isos (λ i → Iso-refl) (λ i → FM.Mor-∘ (ms i) (FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₁ i})) (λ i → FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₂ i}) sqs) strip₂))
+  where
+    strip₁ : fmorη ℰT'.witness (FM.fobj FM.μObj (Poly-map η Q) δ̂₂) (FMu.strong-fmor (Poly-map η Q) (λ i → FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₂ i}))
+              ∘co (CQ' .iso δ̂₁ δ̂₂ isos .fwd ∘ ℰP.p₂)
+             ≈ CQ' .iso δ̂₁ δ̂₂ isos .fwd ∘ ℰP.p₂
+    strip₁ =
+      ≈-trans (CoK.∘-cong₁ (≈-trans (fmorη-cong (FMuI.strong-fmor-p₂ (Poly-map η Q))) (fmorη-p₂ ℰT'.witness _)))
+        (CoK.id-left {Γ = ℰT'.witness})
+
+    strip₂ : CQ' .iso δ̂₂ δ̂₂ (λ i → Iso-refl) .fwd
+              ∘ fmorη ℰT'.witness (FM.fobj FM.μObj (Poly-map η Q) δ̂₁) (FMu.strong-fmor (Poly-map η Q) (λ i → FM.Mor-∘ (ms i) (FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₁ i})))
+             ≈ realise .fmor (FMu.fmor (Poly-map η Q) ms) ∘ ℰP.p₂
+    strip₂ =
+      ≈-trans (∘-cong₁ (invariance-refl Q CQ' δ̂₂ (λ i → Iso-refl) (λ i → ≈-refl)))
+        (≈-trans id-left
+          (≈-trans (fmorη-cong (FamC.≈-sym (sf-pure Q δ̂₁ δ̂₂ ms)))
+            (fmorη-pure ℰT'.witness (FM.fobj FM.μObj (Poly-map η Q) δ̂₁) (FMu.fmor (Poly-map η Q) ms))))
+
+    sqs : ∀ i → fmorη ℰT'.witness (δ̂₂ i) (FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₂ i}) ∘co (isos i .fwd ∘ ℰP.p₂)
+                ≈ Iso-refl .fwd ∘ fmorη ℰT'.witness (δ̂₁ i) (FM.Mor-∘ (ms i) (FamP.p₂ {x = η .fobj ℰT'.witness} {y = δ̂₁ i}))
+    sqs i =
+      ≈-trans (CoK.∘-cong₁ (fmorη-p₂ ℰT'.witness (δ̂₂ i)))
+        (≈-trans (CoK.id-left {Γ = ℰT'.witness})
+          (≈-trans (∘-cong₁ (hyps i))
+            (≈-sym (≈-trans id-left (fmorη-pure ℰT'.witness (δ̂₁ i) (ms i))))))
diff --git a/agda/src/fam-mu-realisation/mu-iso.agda b/agda/src/fam-mu-realisation/mu-iso.agda
new file mode 100644
index 00000000..ded6f59a
--- /dev/null
+++ b/agda/src/fam-mu-realisation/mu-iso.agda
@@ -0,0 +1,344 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- The μ-invariance: environment invariance at μ-polynomials, by uniqueness of
+-- folds; its identity and composition coherences and algebra-map squares.
+
+open import Level using (Level; _⊔_)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import prop-setoid using (Setoid; module ≈-Reasoning)
+open import categories
+  using (Category; setoid→category; HasTerminal; HasProducts; HasExponentials;
+         HasStrongCoproducts; HasCoproducts; strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor; HasColimits)
+open import polynomial-functor using (Poly; extend; Poly-map)
+import fam
+import fam-mu-types
+import fam-realisation
+import polynomial-functor
+import fam-mu-realisation.initial
+
+module fam-mu-realisation.mu-iso {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os (os ⊔ es)) → HasColimits (setoid→category A) ℰ)
+  (ℰT : HasTerminal ℰ) (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP)
+  (ℰSC : HasStrongCoproducts ℰ ℰP)
+  where
+
+open fam-mu-realisation.initial os es ℰC ℰT ℰP ℰE ℰSC public
+
+-- Realisations of the μ-object at environments with isomorphic realisations
+-- are isomorphic: fold each carrier into the other through the invariance of
+-- the polynomial's action, with the roundtrips by uniqueness of folds.
+module MuInvariance {n} (Q : Poly ℰ (suc n)) (CQ : InvarianceAt Q)
+    (δ̂₁ δ̂₂ : Fin n → FM.Obj)
+    (isos : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+  where
+
+  module M₁ = Initiality Q δ̂₁ CQ
+  module M₂ = Initiality Q δ̂₂ CQ
+  module ℰTm = HasTerminal ℰT
+
+  𝟙 = ℰTm.witness
+
+  extIsos : ∀ (A : obj) i → Iso (realise .fobj (extend δ̂₁ (η .fobj A) i))
+                                (realise .fobj (extend δ̂₂ (η .fobj A) i))
+  extIsos A Fin.zero    = Iso-refl
+  extIsos A (Fin.suc i) = isos i
+
+  GI : ∀ (A : obj) → Iso (Greal Q δ̂₁ A) (Greal Q δ̂₂ A)
+  GI A = CQ .iso (extend δ̂₁ (η .fobj A)) (extend δ̂₂ (η .fobj A)) (extIsos A)
+
+  F' : ℰP.prod 𝟙 (Creal Q δ̂₁) ⇒ Creal Q δ̂₂
+  F' = M₁.foldR (M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂))
+
+  G' : ℰP.prod 𝟙 (Creal Q δ̂₂) ⇒ Creal Q δ̂₁
+  G' = M₂.foldR (M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂))
+
+  -- (componentwise naturality squares hoisted to top level)
+
+  -- The crossing square over an arbitrary context.
+  crossΓ : ∀ {Γ' A B : obj} (h : ℰP.prod Γ' A ⇒ B) →
+           Gmap Q δ̂₂ h ∘co (GI A .fwd ∘ ℰP.p₂) ≈ GI B .fwd ∘ Gmap Q δ̂₁ h
+  crossΓ {Γ'} {A} {B} h =
+    CQ .natural (extend δ̂₁ (η .fobj A)) (extend δ̂₂ (η .fobj A)) (extIsos A) (extIsos B)
+      (FMu.strong-extend-mor (λ i → FamP.p₂) (ctxη Γ' A h))
+      (FMu.strong-extend-mor (λ i → FamP.p₂) (ctxη Γ' A h))
+      sqs
+    where
+      sqs : ∀ i → fmorη Γ' (extend δ̂₂ (η .fobj A) i) (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ' A h) i) ∘co (extIsos A i .fwd ∘ ℰP.p₂)
+            ≈ extIsos B i .fwd ∘ fmorη Γ' (extend δ̂₁ (η .fobj A) i) (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ' A h) i)
+      sqs Fin.zero    = sq-refl (ctxη Γ' A h)
+      sqs (Fin.suc i) = sq-p₂ (isos i)
+
+  -- The crossing square, backwards.
+  cross-flip : ∀ {A B : obj} (h : ℰP.prod 𝟙 A ⇒ B) →
+               Gmap Q δ̂₁ h ∘co (GI A .bwd ∘ ℰP.p₂) ≈ GI B .bwd ∘ Gmap Q δ̂₂ h
+  cross-flip {A} {B} h =
+    iso-shuffle (GI B) _ _
+      (≈-trans (≈-sym (assoc _ _ _)) (co-iso-cancel (GI A) (crossΓ h)))
+
+  -- Fusion of a fold against a composed algebra morphism, both directions.
+  square-p₂₁ : ℰP.p₂ ∘co (M₁.inR ∘ ℰP.p₂) ≈ (M₁.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ ℰP.p₂
+  square-p₂₁ =
+    ≈-trans (CoK.id-left {Γ = 𝟙})
+      (≈-sym (≈-trans (CoK.∘-cong₂ (Gmap-id Q δ̂₁)) (CoK.id-right {Γ = 𝟙})))
+
+  square-p₂₂ : ℰP.p₂ ∘co (M₂.inR ∘ ℰP.p₂) ≈ (M₂.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ ℰP.p₂
+  square-p₂₂ =
+    ≈-trans (CoK.id-left {Γ = 𝟙})
+      (≈-sym (≈-trans (CoK.∘-cong₂ (Gmap-id Q δ̂₂)) (CoK.id-right {Γ = 𝟙})))
+
+  ag-cross : (M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co (GI (Creal Q δ̂₁) .fwd ∘ Gmap Q δ̂₁ G')
+             ≈ (M₁.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ G'
+  ag-cross =
+    begin
+      (M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘ ℰP.pair ℰP.p₁ (GI (Creal Q δ̂₁) .fwd ∘ Gmap Q δ̂₁ G')
+    ≈⟨ assoc _ _ _ ⟩
+      M₁.inR ∘ ((GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂) ∘ ℰP.pair ℰP.p₁ (GI (Creal Q δ̂₁) .fwd ∘ Gmap Q δ̂₁ G'))
+    ≈⟨ ∘-cong₂ (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _))) ⟩
+      M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ (GI (Creal Q δ̂₁) .fwd ∘ Gmap Q δ̂₁ G'))
+    ≈˘⟨ ∘-cong₂ (assoc _ _ _) ⟩
+      M₁.inR ∘ ((GI (Creal Q δ̂₁) .bwd ∘ GI (Creal Q δ̂₁) .fwd) ∘ Gmap Q δ̂₁ G')
+    ≈⟨ ∘-cong₂ (≈-trans (∘-cong₁ (GI (Creal Q δ̂₁) .bwd∘fwd≈id)) id-left) ⟩
+      M₁.inR ∘ Gmap Q δ̂₁ G'
+    ≈˘⟨ ≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _)) ⟩
+      (M₁.inR ∘ ℰP.p₂) ∘ ℰP.pair ℰP.p₁ (Gmap Q δ̂₁ G')
+    ∎ where open ≈-Reasoning isEquiv
+
+
+  -- The composite G' ∘co F' satisfies the fold square for the algebra of the identity.
+  square-GF : (G' ∘co F') ∘co (M₁.inR ∘ ℰP.p₂) ≈ (M₁.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ (G' ∘co F')
+  square-GF =
+    begin
+      (G' ∘co F') ∘co (M₁.inR ∘ ℰP.p₂)
+    ≈⟨ CoK.assoc _ _ _ ⟩
+      G' ∘co (F' ∘co (M₁.inR ∘ ℰP.p₂))
+    ≈⟨ CoK.∘-cong₂ (M₁.foldR-β _) ⟩
+      G' ∘co ((M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ F')
+    ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₁ (≈-trans (≈-sym (assoc _ _ _)) (≈-sym (co-pure M₂.inR (GI (Creal Q δ̂₂) .fwd))))) ⟩
+      G' ∘co (((M₂.inR ∘ ℰP.p₂) ∘co (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ F')
+    ≈˘⟨ CoK.assoc _ _ _ ⟩
+      (G' ∘co ((M₂.inR ∘ ℰP.p₂) ∘co (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂))) ∘co Gmap Q δ̂₁ F'
+    ≈˘⟨ CoK.∘-cong₁ (CoK.assoc _ _ _) ⟩
+      ((G' ∘co (M₂.inR ∘ ℰP.p₂)) ∘co (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ F'
+    ≈⟨ CoK.∘-cong₁ (CoK.∘-cong₁ (M₂.foldR-β _)) ⟩
+      (((M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₂ G') ∘co (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ F'
+    ≈⟨ CoK.∘-cong₁ (CoK.assoc _ _ _) ⟩
+      ((M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co (Gmap Q δ̂₂ G' ∘co (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂))) ∘co Gmap Q δ̂₁ F'
+    ≈⟨ CoK.∘-cong₁ (CoK.∘-cong₂ (crossΓ G')) ⟩
+      ((M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co (GI (Creal Q δ̂₁) .fwd ∘ Gmap Q δ̂₁ G')) ∘co Gmap Q δ̂₁ F'
+    ≈⟨ CoK.∘-cong₁ ag-cross ⟩
+      ((M₁.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ G') ∘co Gmap Q δ̂₁ F'
+    ≈⟨ CoK.assoc _ _ _ ⟩
+      (M₁.inR ∘ ℰP.p₂) ∘co (Gmap Q δ̂₁ G' ∘co Gmap Q δ̂₁ F')
+    ≈˘⟨ CoK.∘-cong₂ (Gmap-∘co Q δ̂₁ G' F') ⟩
+      (M₁.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ (G' ∘co F')
+    ∎
+    where open ≈-Reasoning isEquiv
+
+  af-cross : (M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co (GI (Creal Q δ̂₂) .bwd ∘ Gmap Q δ̂₂ F')
+             ≈ (M₂.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ F'
+  af-cross =
+    begin
+      (M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘ ℰP.pair ℰP.p₁ (GI (Creal Q δ̂₂) .bwd ∘ Gmap Q δ̂₂ F')
+    ≈⟨ assoc _ _ _ ⟩
+      M₂.inR ∘ ((GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂) ∘ ℰP.pair ℰP.p₁ (GI (Creal Q δ̂₂) .bwd ∘ Gmap Q δ̂₂ F'))
+    ≈⟨ ∘-cong₂ (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _))) ⟩
+      M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ (GI (Creal Q δ̂₂) .bwd ∘ Gmap Q δ̂₂ F'))
+    ≈˘⟨ ∘-cong₂ (assoc _ _ _) ⟩
+      M₂.inR ∘ ((GI (Creal Q δ̂₂) .fwd ∘ GI (Creal Q δ̂₂) .bwd) ∘ Gmap Q δ̂₂ F')
+    ≈⟨ ∘-cong₂ (≈-trans (∘-cong₁ (GI (Creal Q δ̂₂) .fwd∘bwd≈id)) id-left) ⟩
+      M₂.inR ∘ Gmap Q δ̂₂ F'
+    ≈˘⟨ ≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _)) ⟩
+      (M₂.inR ∘ ℰP.p₂) ∘ ℰP.pair ℰP.p₁ (Gmap Q δ̂₂ F')
+    ∎ where open ≈-Reasoning isEquiv
+
+
+  -- The composite F' ∘co G' likewise, using the flipped crossing.
+  square-FG : (F' ∘co G') ∘co (M₂.inR ∘ ℰP.p₂) ≈ (M₂.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ (F' ∘co G')
+  square-FG =
+    begin
+      (F' ∘co G') ∘co (M₂.inR ∘ ℰP.p₂)
+    ≈⟨ CoK.assoc _ _ _ ⟩
+      F' ∘co (G' ∘co (M₂.inR ∘ ℰP.p₂))
+    ≈⟨ CoK.∘-cong₂ (M₂.foldR-β _) ⟩
+      F' ∘co ((M₁.inR ∘ (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₂ G')
+    ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₁ (≈-trans (≈-sym (assoc _ _ _)) (≈-sym (co-pure M₁.inR (GI (Creal Q δ̂₁) .bwd))))) ⟩
+      F' ∘co (((M₁.inR ∘ ℰP.p₂) ∘co (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₂ G')
+    ≈˘⟨ CoK.assoc _ _ _ ⟩
+      (F' ∘co ((M₁.inR ∘ ℰP.p₂) ∘co (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂))) ∘co Gmap Q δ̂₂ G'
+    ≈˘⟨ CoK.∘-cong₁ (CoK.assoc _ _ _) ⟩
+      ((F' ∘co (M₁.inR ∘ ℰP.p₂)) ∘co (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₂ G'
+    ≈⟨ CoK.∘-cong₁ (CoK.∘-cong₁ (M₁.foldR-β _)) ⟩
+      (((M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ F') ∘co (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₂ G'
+    ≈⟨ CoK.∘-cong₁ (CoK.assoc _ _ _) ⟩
+      ((M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co (Gmap Q δ̂₁ F' ∘co (GI (Creal Q δ̂₁) .bwd ∘ ℰP.p₂))) ∘co Gmap Q δ̂₂ G'
+    ≈⟨ CoK.∘-cong₁ (CoK.∘-cong₂ (cross-flip F')) ⟩
+      ((M₂.inR ∘ (GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co (GI (Creal Q δ̂₂) .bwd ∘ Gmap Q δ̂₂ F')) ∘co Gmap Q δ̂₂ G'
+    ≈⟨ CoK.∘-cong₁ af-cross ⟩
+      ((M₂.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ F') ∘co Gmap Q δ̂₂ G'
+    ≈⟨ CoK.assoc _ _ _ ⟩
+      (M₂.inR ∘ ℰP.p₂) ∘co (Gmap Q δ̂₂ F' ∘co Gmap Q δ̂₂ G')
+    ≈˘⟨ CoK.∘-cong₂ (Gmap-∘co Q δ̂₂ F' G') ⟩
+      (M₂.inR ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ (F' ∘co G')
+    ∎
+    where open ≈-Reasoning isEquiv
+
+  -- Composites in context agree with plain composites of the induced maps.
+  plait : ∀ {X Y Z : obj} (u : ℰP.prod 𝟙 Y ⇒ Z) (v : ℰP.prod 𝟙 X ⇒ Y) →
+          (u ∘ ℰP.pair ℰTm.to-terminal (id _)) ∘ (v ∘ ℰP.pair ℰTm.to-terminal (id _))
+          ≈ (u ∘co v) ∘ ℰP.pair ℰTm.to-terminal (id _)
+  plait u v =
+    begin
+      (u ∘ ℰP.pair ℰTm.to-terminal (id _)) ∘ (v ∘ ℰP.pair ℰTm.to-terminal (id _))
+    ≈⟨ assoc _ _ _ ⟩
+      u ∘ (ℰP.pair ℰTm.to-terminal (id _) ∘ (v ∘ ℰP.pair ℰTm.to-terminal (id _)))
+    ≈⟨ ∘-cong₂ (ℰP.pair-natural _ _ _) ⟩
+      u ∘ ℰP.pair (ℰTm.to-terminal ∘ (v ∘ ℰP.pair ℰTm.to-terminal (id _))) (id _ ∘ (v ∘ ℰP.pair ℰTm.to-terminal (id _)))
+    ≈⟨ ∘-cong₂ (ℰP.pair-cong (ℰTm.to-terminal-unique _ _) id-left) ⟩
+      u ∘ ℰP.pair (ℰP.p₁ ∘ ℰP.pair ℰTm.to-terminal (id _)) (v ∘ ℰP.pair ℰTm.to-terminal (id _))
+    ≈˘⟨ ∘-cong₂ (ℰP.pair-natural _ _ _) ⟩
+      u ∘ (ℰP.pair ℰP.p₁ v ∘ ℰP.pair ℰTm.to-terminal (id _))
+    ≈˘⟨ assoc _ _ _ ⟩
+      (u ∘ ℰP.pair ℰP.p₁ v) ∘ ℰP.pair ℰTm.to-terminal (id _)
+    ∎ where open ≈-Reasoning isEquiv
+
+  mu-invariance : Iso (Creal Q δ̂₁) (Creal Q δ̂₂)
+  mu-invariance .fwd = F' ∘ ℰP.pair ℰTm.to-terminal (id _)
+  mu-invariance .bwd = G' ∘ ℰP.pair ℰTm.to-terminal (id _)
+  mu-invariance .bwd∘fwd≈id =
+    ≈-trans (plait G' F')
+      (≈-trans (∘-cong₁ (≈-trans (M₁.foldR-η _ _ square-GF) (≈-sym (M₁.foldR-η {Γ = 𝟙} _ _ square-p₂₁))))
+        (ℰP.pair-p₂ _ _))
+  mu-invariance .fwd∘bwd≈id =
+    ≈-trans (plait F' G')
+      (≈-trans (∘-cong₁ (≈-trans (M₂.foldR-η _ _ square-FG) (≈-sym (M₂.foldR-η {Γ = 𝟙} _ _ square-p₂₂))))
+        (ℰP.pair-p₂ _ _))
+
+-- The forward map of the μ-invariance is a morphism of algebras.
+mu-invariance-fwd-in : ∀ {n} (Q : Poly ℰ (suc n)) (CQ : InvarianceAt Q)
+                     (δ̂₁ δ̂₂ : Fin n → FM.Obj)
+                     (isos : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i))) →
+                     MuInvariance.mu-invariance Q CQ δ̂₁ δ̂₂ isos .fwd ∘ Initiality.inR Q δ̂₁ CQ
+                     ≈ Initiality.inR Q δ̂₂ CQ ∘
+                        (MuInvariance.GI Q CQ δ̂₁ δ̂₂ isos (Creal Q δ̂₂) .fwd ∘
+                         realise .fmor (FMu.fmor (Poly-map η Q) (pureExt δ̂₁ (untranspose (MuInvariance.mu-invariance Q CQ δ̂₁ δ̂₂ isos .fwd ∘ realise-η-iso (Creal Q δ̂₁) .fwd)))))
+mu-invariance-fwd-in Q CQ δ̂₁ δ̂₂ isos =
+  ≈-trans (plain-β Q δ̂₁ CQ _)
+    (≈-trans (assoc _ _ _)
+      (∘-cong₂
+        (≈-trans (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _)))
+          (∘-cong₂ (≈-trans (∘-cong₁ (Gmap-cong Q δ̂₁ plain-eq))
+            (≈-trans (∘-cong₁ (Gmap-pure Q δ̂₁ (MC.mu-invariance .fwd)))
+              (≈-trans (assoc _ _ _)
+                (≈-trans (∘-cong₂ (ℰP.pair-p₂ _ _)) id-right))))))))
+  where
+    module MC = MuInvariance Q CQ δ̂₁ δ̂₂ isos
+
+    plain-eq : MC.F' ≈ MC.mu-invariance .fwd ∘ ℰP.p₂
+    plain-eq =
+      ≈-sym (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ sect-p₂) id-right))
+
+-- The backward map of the μ-invariance is a morphism of algebras.
+mu-invariance-bwd-in : ∀ {n} (Q : Poly ℰ (suc n)) (CQ : InvarianceAt Q)
+                     (δ̂₁ δ̂₂ : Fin n → FM.Obj)
+                     (isos : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i))) →
+                     MuInvariance.mu-invariance Q CQ δ̂₁ δ̂₂ isos .bwd ∘ Initiality.inR Q δ̂₂ CQ
+                     ≈ Initiality.inR Q δ̂₁ CQ ∘
+                        (MuInvariance.GI Q CQ δ̂₁ δ̂₂ isos (Creal Q δ̂₁) .bwd ∘
+                         realise .fmor (FMu.fmor (Poly-map η Q) (pureExt δ̂₂ (untranspose (MuInvariance.mu-invariance Q CQ δ̂₁ δ̂₂ isos .bwd ∘ realise-η-iso (Creal Q δ̂₂) .fwd)))))
+mu-invariance-bwd-in Q CQ δ̂₁ δ̂₂ isos =
+  ≈-trans (plain-β Q δ̂₂ CQ _)
+    (≈-trans (assoc _ _ _)
+      (∘-cong₂
+        (≈-trans (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _)))
+          (∘-cong₂ (≈-trans (∘-cong₁ (Gmap-cong Q δ̂₂ plain-eq))
+            (≈-trans (∘-cong₁ (Gmap-pure Q δ̂₂ (MC.mu-invariance .bwd)))
+              (≈-trans (assoc _ _ _)
+                (≈-trans (∘-cong₂ (ℰP.pair-p₂ _ _)) id-right))))))))
+  where
+    module MC = MuInvariance Q CQ δ̂₁ δ̂₂ isos
+
+    plain-eq : MC.G' ≈ MC.mu-invariance .bwd ∘ ℰP.p₂
+    plain-eq =
+      ≈-sym (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ sect-p₂) id-right))
+
+-- The μ-invariance at a composite isomorphism family is the composite of the
+-- μ-invariances.
+mu-invariance-comp : ∀ {n} (Q : Poly ℰ (suc n)) (CQ : InvarianceAt Q)
+                   (δ̂₁ δ̂₂ δ̂₃ : Fin n → FM.Obj)
+                   (isos₁₂ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+                   (isos₂₃ : ∀ i → Iso (realise .fobj (δ̂₂ i)) (realise .fobj (δ̂₃ i))) →
+                   MuInvariance.mu-invariance Q CQ δ̂₁ δ̂₃ (λ i → Iso-trans (isos₁₂ i) (isos₂₃ i)) .fwd
+                   ≈ MuInvariance.mu-invariance Q CQ δ̂₂ δ̂₃ isos₂₃ .fwd ∘ MuInvariance.mu-invariance Q CQ δ̂₁ δ̂₂ isos₁₂ .fwd
+mu-invariance-comp {n} Q CQ δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃ =
+  ≈-trans (∘-cong₁ (≈-sym (MC₁₃.M₁.foldR-η {Γ = ℰT'.witness} _ (MC₂₃.F' ∘co MC₁₂.F') square)))
+    (≈-sym (MC₁₂.plait MC₂₃.F' MC₁₂.F'))
+  where
+    module MC₁₂ = MuInvariance Q CQ δ̂₁ δ̂₂ isos₁₂
+    module MC₂₃ = MuInvariance Q CQ δ̂₂ δ̂₃ isos₂₃
+    module MC₁₃ = MuInvariance Q CQ δ̂₁ δ̂₃ (λ i → Iso-trans (isos₁₂ i) (isos₂₃ i))
+
+    C₃ = Creal Q δ̂₃
+
+    GIcomp : MC₂₃.GI C₃ .fwd ∘ MC₁₂.GI C₃ .fwd ≈ MC₁₃.GI C₃ .fwd
+    GIcomp =
+      ≈-sym (≈-trans (invariance-ext Q CQ _ _ (MC₁₃.extIsos C₃) (λ i → Iso-trans (MC₁₂.extIsos C₃ i) (MC₂₃.extIsos C₃ i)) pw)
+        (CQ .comp _ _ _ (MC₁₂.extIsos C₃) (MC₂₃.extIsos C₃)))
+      where
+        pw : ∀ i → MC₁₃.extIsos C₃ i .fwd ≈ Iso-trans (MC₁₂.extIsos C₃ i) (MC₂₃.extIsos C₃ i) .fwd
+        pw Fin.zero    = ≈-sym id-left
+        pw (Fin.suc i) = ≈-refl
+
+
+    head-comp : (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co (MC₁₂.GI C₃ .fwd ∘ ℰP.p₂)
+                ≈ MC₁₃.M₂.inR ∘ (MC₁₃.GI C₃ .fwd ∘ ℰP.p₂)
+    head-comp =
+      begin
+        (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co (MC₁₂.GI C₃ .fwd ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₁ (assoc _ _ _) ⟩
+        ((MC₂₃.M₂.inR ∘ MC₂₃.GI C₃ .fwd) ∘ ℰP.p₂) ∘co (MC₁₂.GI C₃ .fwd ∘ ℰP.p₂)
+      ≈⟨ co-pure _ _ ⟩
+        ((MC₂₃.M₂.inR ∘ MC₂₃.GI C₃ .fwd) ∘ MC₁₂.GI C₃ .fwd) ∘ ℰP.p₂
+      ≈⟨ ∘-cong₁ (assoc _ _ _) ⟩
+        (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ MC₁₂.GI C₃ .fwd)) ∘ ℰP.p₂
+      ≈⟨ ∘-cong₁ (∘-cong₂ GIcomp) ⟩
+        (MC₁₃.M₂.inR ∘ MC₁₃.GI C₃ .fwd) ∘ ℰP.p₂
+      ≈⟨ assoc _ _ _ ⟩
+        MC₁₃.M₂.inR ∘ (MC₁₃.GI C₃ .fwd ∘ ℰP.p₂)
+      ∎ where open ≈-Reasoning isEquiv
+
+    square : (MC₂₃.F' ∘co MC₁₂.F') ∘co (MC₁₃.M₁.inR ∘ ℰP.p₂)
+             ≈ (MC₁₃.M₂.inR ∘ (MC₁₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ (MC₂₃.F' ∘co MC₁₂.F')
+    square =
+      begin
+        (MC₂₃.F' ∘co MC₁₂.F') ∘co (MC₁₃.M₁.inR ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        MC₂₃.F' ∘co (MC₁₂.F' ∘co (MC₁₂.M₁.inR ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (MC₁₂.M₁.foldR-β _) ⟩
+        MC₂₃.F' ∘co ((MC₁₂.M₂.inR ∘ (MC₁₂.GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₁ (≈-trans (≈-sym (assoc _ _ _)) (≈-sym (co-pure _ _)))) ⟩
+        MC₂₃.F' ∘co (((MC₁₂.M₂.inR ∘ ℰP.p₂) ∘co (MC₁₂.GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.∘-cong₂ (CoK.assoc _ _ _) ⟩
+        MC₂₃.F' ∘co ((MC₁₂.M₂.inR ∘ ℰP.p₂) ∘co ((MC₁₂.GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ MC₁₂.F'))
+      ≈˘⟨ CoK.assoc _ _ _ ⟩
+        (MC₂₃.F' ∘co (MC₂₃.M₁.inR ∘ ℰP.p₂)) ∘co ((MC₁₂.GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.∘-cong₁ (MC₂₃.M₁.foldR-β _) ⟩
+        ((MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₂ MC₂₃.F') ∘co ((MC₁₂.GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co (Gmap Q δ̂₂ MC₂₃.F' ∘co ((MC₁₂.GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ MC₁₂.F'))
+      ≈˘⟨ CoK.∘-cong₂ (CoK.assoc _ _ _) ⟩
+        (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co ((Gmap Q δ̂₂ MC₂₃.F' ∘co (MC₁₂.GI (Creal Q δ̂₂) .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₁ (MC₁₂.crossΓ MC₂₃.F')) ⟩
+        (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co ((MC₁₂.GI C₃ .fwd ∘ Gmap Q δ̂₁ MC₂₃.F') ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₁ (≈-sym (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _))))) ⟩
+        (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co (((MC₁₂.GI C₃ .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ MC₂₃.F') ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.∘-cong₂ (CoK.assoc _ _ _) ⟩
+        (MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co ((MC₁₂.GI C₃ .fwd ∘ ℰP.p₂) ∘co (Gmap Q δ̂₁ MC₂₃.F' ∘co Gmap Q δ̂₁ MC₁₂.F'))
+      ≈˘⟨ CoK.assoc _ _ _ ⟩
+        ((MC₂₃.M₂.inR ∘ (MC₂₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co (MC₁₂.GI C₃ .fwd ∘ ℰP.p₂)) ∘co (Gmap Q δ̂₁ MC₂₃.F' ∘co Gmap Q δ̂₁ MC₁₂.F')
+      ≈⟨ CoK.∘-cong head-comp (≈-sym (Gmap-∘co Q δ̂₁ MC₂₃.F' MC₁₂.F')) ⟩
+        (MC₁₃.M₂.inR ∘ (MC₁₃.GI C₃ .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ (MC₂₃.F' ∘co MC₁₂.F')
+      ∎
+      where open ≈-Reasoning isEquiv
diff --git a/agda/src/fam-mu-realisation/natural.agda b/agda/src/fam-mu-realisation/natural.agda
new file mode 100644
index 00000000..37801f24
--- /dev/null
+++ b/agda/src/fam-mu-realisation/natural.agda
@@ -0,0 +1,429 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Naturality of the μ-invariance in the strong action, closing the invariance
+-- induction: every polynomial admits environment invariance.
+
+open import Level using (Level; _⊔_)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import prop-setoid using (Setoid; module ≈-Reasoning)
+open import categories
+  using (Category; setoid→category; HasTerminal; HasProducts; HasExponentials;
+         HasStrongCoproducts; HasCoproducts; strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor; HasColimits)
+open import polynomial-functor using (Poly; extend; Poly-map)
+import fam
+import fam-mu-types
+import fam-realisation
+import polynomial-functor
+import fam-mu-realisation.mu-iso
+
+module fam-mu-realisation.natural {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os (os ⊔ es)) → HasColimits (setoid→category A) ℰ)
+  (ℰT : HasTerminal ℰ) (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP)
+  (ℰSC : HasStrongCoproducts ℰ ℰP)
+  where
+
+open fam-mu-realisation.mu-iso os es ℰC ℰT ℰP ℰE ℰSC public
+
+-- The realised strong μ-action is the fold of the realised algebra, corrected
+-- by the invariance at the bound-variable entry.
+module SμfFold {n} (Q : Poly ℰ (suc n)) (CQ : InvarianceAt Q) {Γ : obj}
+    (δ̂ ε̂ : Fin n → FM.Obj)
+    (gs : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂ i)) (ε̂ i))
+  where
+
+  private
+    Q̂ = Poly-map η Q
+    module Mδ = Initiality Q δ̂ CQ
+
+    sμf : FM.Mor (FamP.prod (η .fobj Γ) (FM.μObj Q̂ δ̂)) (FM.μObj Q̂ ε̂)
+    sμf = FMu.strong-μ-fmor Q̂ gs
+
+    alg : FM.Mor (FamP.prod (η .fobj Γ) (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂)))) (FM.μObj Q̂ ε̂)
+    alg = FM.Mor-∘ (FMu.inMap Q̂ ε̂) (FMu.strong-fmor Q̂ (FMu.strong-extend-mor gs FamP.p₂))
+
+  KKisos : ∀ i → Iso (realise .fobj (extend δ̂ (η .fobj (Creal Q ε̂)) i))
+                     (realise .fobj (extend δ̂ (FM.μObj Q̂ ε̂) i))
+  KKisos Fin.zero    = realise-η-iso (Creal Q ε̂)
+  KKisos (Fin.suc i) = Iso-refl
+
+  KKε : Iso (realise .fobj (FM.fobj FM.μObj Q̂ (extend δ̂ (η .fobj (Creal Q ε̂)))))
+            (realise .fobj (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂))))
+  KKε = CQ .iso (extend δ̂ (η .fobj (Creal Q ε̂))) (extend δ̂ (FM.μObj Q̂ ε̂)) KKisos
+
+  aStar : ℰP.prod Γ (Greal Q δ̂ (Creal Q ε̂)) ⇒ Creal Q ε̂
+  aStar = fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂))) alg ∘co (KKε .fwd ∘ ℰP.p₂)
+
+  A' : ℰP.prod Γ (Creal Q δ̂) ⇒ Creal Q ε̂
+  A' = fmorη Γ (FM.μObj (Poly-map η Q) δ̂) (FMu.strong-μ-fmor (Poly-map η Q) gs)
+
+  sμf-square : A' ∘co (Mδ.inR ∘ ℰP.p₂) ≈ aStar ∘co Gmap Q δ̂ A'
+  sμf-square =
+    begin
+      A' ∘co (Mδ.inR ∘ ℰP.p₂)
+    ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+      A' ∘co ((realise .fmor (FMu.inMap Q̂ δ̂) ∘ ℰP.p₂) ∘co (CQ .iso (extend δ̂ (η .fobj (Creal Q δ̂))) (extend δ̂ (FM.μObj Q̂ δ̂)) Mδ.inIsos .fwd ∘ ℰP.p₂))
+    ≈˘⟨ CoK.assoc _ _ _ ⟩
+      (A' ∘co (realise .fmor (FMu.inMap Q̂ δ̂) ∘ ℰP.p₂)) ∘co (CQ .iso (extend δ̂ (η .fobj (Creal Q δ̂))) (extend δ̂ (FM.μObj Q̂ δ̂)) Mδ.inIsos .fwd ∘ ℰP.p₂)
+    ≈⟨ CoK.∘-cong₁ step-β ⟩
+      (fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂))) alg ∘co fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ δ̂))) (FMu.strong-fmor Q̂ (FMu.strong-extend-mor (λ i → FamP.p₂) sμf))) ∘co (CQ .iso (extend δ̂ (η .fobj (Creal Q δ̂))) (extend δ̂ (FM.μObj Q̂ δ̂)) Mδ.inIsos .fwd ∘ ℰP.p₂)
+    ≈⟨ CoK.assoc _ _ _ ⟩
+      fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂))) alg ∘co (fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ δ̂))) (FMu.strong-fmor Q̂ (FMu.strong-extend-mor (λ i → FamP.p₂) sμf)) ∘co (CQ .iso (extend δ̂ (η .fobj (Creal Q δ̂))) (extend δ̂ (FM.μObj Q̂ δ̂)) Mδ.inIsos .fwd ∘ ℰP.p₂))
+    ≈⟨ CoK.∘-cong₂ inner-nat ⟩
+      fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂))) alg ∘co (KKε .fwd ∘ Gmap Q δ̂ A')
+    ≈˘⟨ CoK.∘-cong₂ (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _))) ⟩
+      fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂))) alg ∘co ((KKε .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂ A')
+    ≈˘⟨ CoK.assoc _ _ _ ⟩
+      aStar ∘co Gmap Q δ̂ A'
+    ∎
+    where
+      open ≈-Reasoning isEquiv
+
+      step-β : A' ∘co (realise .fmor (FMu.inMap Q̂ δ̂) ∘ ℰP.p₂)
+               ≈ fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ ε̂))) alg ∘co fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ δ̂))) (FMu.strong-fmor Q̂ (FMu.strong-extend-mor (λ i → FamP.p₂) sμf))
+      step-β =
+        ≈-trans (CoK.∘-cong₂ (≈-sym (fmorη-pure Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ δ̂))) (FMu.inMap Q̂ δ̂))))
+          (≈-trans (≈-sym (fmorη-∘co Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ δ̂))) sμf _))
+            (≈-trans (fmorη-cong (FM.hasMuLaws .FM.HasMuLaws.⦅⦆-β {P = Q̂} {δ = δ̂} _))
+              (fmorη-∘co Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ δ̂))) alg _)))
+
+      inner-nat : fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂ (FM.μObj Q̂ δ̂))) (FMu.strong-fmor Q̂ (FMu.strong-extend-mor (λ i → FamP.p₂) sμf))
+                    ∘co (CQ .iso (extend δ̂ (η .fobj (Creal Q δ̂))) (extend δ̂ (FM.μObj Q̂ δ̂)) Mδ.inIsos .fwd ∘ ℰP.p₂)
+                  ≈ KKε .fwd ∘ Gmap Q δ̂ A'
+      inner-nat =
+        CQ .natural (extend δ̂ (η .fobj (Creal Q δ̂))) (extend δ̂ (FM.μObj Q̂ δ̂)) Mδ.inIsos KKisos
+          (FMu.strong-extend-mor (λ i → FamP.p₂) (ctxη Γ (Creal Q δ̂) A'))
+          (FMu.strong-extend-mor (λ i → FamP.p₂) sμf)
+          compats
+        where
+          compats : ∀ i → fmorη Γ (extend δ̂ (FM.μObj Q̂ δ̂) i) (FMu.strong-extend-mor (λ j → FamP.p₂) sμf i) ∘co (Mδ.inIsos i .fwd ∘ ℰP.p₂)
+                    ≈ KKisos i .fwd ∘ fmorη Γ (extend δ̂ (η .fobj (Creal Q δ̂)) i) (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ (Creal Q δ̂) A') i)
+          compats Fin.zero    = fmorη-ctxη-square Γ (FM.μObj Q̂ δ̂) (FM.μObj Q̂ ε̂) sμf
+          compats (Fin.suc i) = sq-refl _
+
+  -- The characterisation.
+  sμf-fold : fmorη Γ (FM.μObj Q̂ δ̂) (FMu.strong-μ-fmor Q̂ gs) ≈ Mδ.foldR aStar
+  sμf-fold = Mδ.foldR-η aStar A' sμf-square
+
+-- The naturality of the μ-invariance: the last field of the invariance interface
+-- at μ. Established by fold uniqueness, with the invariance paths identified
+-- through composition coherence and extensionality.
+module MuNat {n} (Q : Poly ℰ (suc n)) (CQ : InvarianceAt Q) {Γ : obj}
+    (δ̂₁ δ̂₂ ε̂₁ ε̂₂ : Fin n → FM.Obj)
+    (isosδ : ∀ i → Iso (realise .fobj (δ̂₁ i)) (realise .fobj (δ̂₂ i)))
+    (isosε : ∀ i → Iso (realise .fobj (ε̂₁ i)) (realise .fobj (ε̂₂ i)))
+    (gs₁ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₁ i)) (ε̂₁ i))
+    (gs₂ : ∀ i → FM.Mor (FamP.prod (η .fobj Γ) (δ̂₂ i)) (ε̂₂ i))
+    (sqs : ∀ i → fmorη Γ (δ̂₂ i) (gs₂ i) ∘co (isosδ i .fwd ∘ ℰP.p₂)
+                 ≈ isosε i .fwd ∘ fmorη Γ (δ̂₁ i) (gs₁ i))
+  where
+
+  private
+    Q̂ = Poly-map η Q
+
+    module Mδ₁ = Initiality Q δ̂₁ CQ
+    module Mδ₂ = Initiality Q δ̂₂ CQ
+    module Mε₁ = Initiality Q ε̂₁ CQ
+    module Mε₂ = Initiality Q ε̂₂ CQ
+    module Sδ₁ = SμfFold Q CQ δ̂₁ ε̂₁ gs₁
+    module Sδ₂ = SμfFold Q CQ δ̂₂ ε̂₂ gs₂
+    module MCδ = MuInvariance Q CQ δ̂₁ δ̂₂ isosδ
+    module MCε = MuInvariance Q CQ ε̂₁ ε̂₂ isosε
+
+    muδ = MCδ.mu-invariance
+    muε = MCε.mu-invariance
+    C₁ε = Creal Q ε̂₁
+    C₂ε = Creal Q ε̂₂
+
+    f̂ε : FM.Mor (η .fobj C₁ε) (η .fobj C₂ε)
+    f̂ε = untranspose {W = η .fobj C₁ε} (muε .fwd ∘ realise-η-iso C₁ε .fwd)
+
+    NFε₁ = FMu.fmor Q̂ (pureExt ε̂₁ f̂ε)
+
+    Kε₁ = CQ .iso (extend ε̂₁ (η .fobj C₁ε)) (extend ε̂₁ (FM.μObj Q̂ ε̂₁)) Mε₁.inIsos
+    Kε₂ = CQ .iso (extend ε̂₂ (η .fobj C₂ε)) (extend ε̂₂ (FM.μObj Q̂ ε̂₂)) Mε₂.inIsos
+    Mεμ = CQ .iso (extend ε̂₁ (FM.μObj Q̂ ε̂₁)) (extend ε̂₂ (FM.μObj Q̂ ε̂₂)) (mixed isosε muε)
+
+    Pc-isos = mixed {δ̂₁ = ε̂₁} {δ̂₂ = ε̂₁} (λ i → Iso-refl) {Ŷ₁ = η .fobj C₁ε} {Ŷ₂ = η .fobj C₂ε} (pureJ muε)
+
+    Pc-real : CQ .iso (extend ε̂₁ (η .fobj C₁ε)) (extend ε̂₁ (η .fobj C₂ε)) Pc-isos .fwd
+              ≈ realise .fmor NFε₁
+    Pc-real = pure-invariance Q CQ _ _ (pureExt ε̂₁ f̂ε) Pc-isos hyps
+      where
+        hyps : ∀ i → Pc-isos i .fwd ≈ realise .fmor (pureExt ε̂₁ f̂ε i)
+        hyps Fin.zero    = pureJ-fwd muε
+        hyps (Fin.suc i) = ≈-sym (realise .fmor-id)
+
+    counit-invariance-square : Kε₂ .fwd ∘ (MCε.GI C₂ε .fwd ∘ realise .fmor NFε₁)
+                             ≈ Mεμ .fwd ∘ Kε₁ .fwd
+    counit-invariance-square =
+      ≈-trans (∘-cong₂ (∘-cong₂ (≈-sym Pc-real)))
+        (≈-trans (∘-cong₂ (≈-sym (CQ .comp _ _ _ Pc-isos (MCε.extIsos C₂ε))))
+          (invariance-path-eq Q CQ (extend ε̂₁ (η .fobj C₁ε)) (extend ε̂₂ (η .fobj C₂ε)) (extend ε̂₁ (FM.μObj Q̂ ε̂₁)) (extend ε̂₂ (FM.μObj Q̂ ε̂₂)) (λ i → Iso-trans (Pc-isos i) (MCε.extIsos C₂ε i)) Mε₂.inIsos Mε₁.inIsos (mixed isosε muε) pointwise))
+      where
+        pointwise : ∀ i → Iso-trans (Iso-trans (Pc-isos i) (MCε.extIsos C₂ε i)) (Mε₂.inIsos i) .fwd
+                          ≈ Iso-trans (Mε₁.inIsos i) (mixed isosε muε i) .fwd
+        pointwise Fin.zero =
+          ≈-trans (∘-cong₂ id-left)
+            (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong₁ (≈-sym (assoc _ _ _)))
+                (∘-cong₁ (≈-trans (∘-cong₁ (realise-η-iso C₂ε .fwd∘bwd≈id)) id-left))))
+        pointwise (Fin.suc i) = id-left
+
+    -- Abbreviations for the δ̂-side invariance paths.
+    KK₁ = Sδ₁.KKε
+    KK₂ = Sδ₂.KKε
+    Mδμ = CQ .iso (extend δ̂₁ (FM.μObj Q̂ ε̂₁)) (extend δ̂₂ (FM.μObj Q̂ ε̂₂)) (mixed isosδ muε)
+
+    NF₂ = FMu.fmor Q̂ (pureExt δ̂₂ f̂ε)
+
+    Pc2-isos = mixed {δ̂₁ = δ̂₂} {δ̂₂ = δ̂₂} (λ i → Iso-refl) {Ŷ₁ = η .fobj C₁ε} {Ŷ₂ = η .fobj C₂ε} (pureJ muε)
+
+    Pc2-real : CQ .iso (extend δ̂₂ (η .fobj C₁ε)) (extend δ̂₂ (η .fobj C₂ε)) Pc2-isos .fwd
+               ≈ realise .fmor NF₂
+    Pc2-real = pure-invariance Q CQ _ _ (pureExt δ̂₂ f̂ε) Pc2-isos hyps
+      where
+        hyps : ∀ i → Pc2-isos i .fwd ≈ realise .fmor (pureExt δ̂₂ f̂ε i)
+        hyps Fin.zero    = pureJ-fwd muε
+        hyps (Fin.suc i) = ≈-sym (realise .fmor-id)
+
+    -- The δ̂-side invariance paths from the fold algebra's environment agree.
+    env-invariance-square : Mδμ .fwd ∘ KK₁ .fwd
+                          ≈ (KK₂ .fwd ∘ realise .fmor NF₂) ∘ MCδ.GI C₁ε .fwd
+    env-invariance-square =
+      ≈-trans (invariance-path-eq Q CQ (extend δ̂₁ (η .fobj C₁ε)) (extend δ̂₁ (FM.μObj Q̂ ε̂₁)) (extend δ̂₂ (η .fobj C₁ε)) (extend δ̂₂ (FM.μObj Q̂ ε̂₂)) Sδ₁.KKisos (mixed isosδ muε) (MCδ.extIsos C₁ε) (λ i → Iso-trans (Pc2-isos i) (Sδ₂.KKisos i)) pointwise)
+        (∘-cong₁ (≈-trans (CQ .comp _ _ _ Pc2-isos Sδ₂.KKisos) (∘-cong₂ Pc2-real)))
+      where
+        pointwise : ∀ i → Iso-trans (Sδ₁.KKisos i) (mixed isosδ muε i) .fwd
+                          ≈ Iso-trans (MCδ.extIsos C₁ε i) (Iso-trans (Pc2-isos i) (Sδ₂.KKisos i)) .fwd
+        pointwise Fin.zero =
+          ≈-sym (≈-trans id-right
+            (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong₁ (≈-sym (assoc _ _ _)))
+                (∘-cong₁ (≈-trans (∘-cong₁ (realise-η-iso C₂ε .fwd∘bwd≈id)) id-left)))))
+        pointwise (Fin.suc i) =
+          ≈-trans id-right (≈-sym (≈-trans (∘-cong₁ id-left) id-left))
+
+    -- Remaining abbreviations for the fold-square assembly.
+    sfp₁ : FM.Mor (FamP.prod (η .fobj Γ) (FM.fobj FM.μObj Q̂ (extend δ̂₁ (FM.μObj Q̂ ε̂₁))))
+                  (FM.fobj FM.μObj Q̂ (extend ε̂₁ (FM.μObj Q̂ ε̂₁)))
+    sfp₁ = FMu.strong-fmor Q̂ (FMu.strong-extend-mor gs₁ FamP.p₂)
+
+    sfp₂ : FM.Mor (FamP.prod (η .fobj Γ) (FM.fobj FM.μObj Q̂ (extend δ̂₂ (FM.μObj Q̂ ε̂₂))))
+                  (FM.fobj FM.μObj Q̂ (extend ε̂₂ (FM.μObj Q̂ ε̂₂)))
+    sfp₂ = FMu.strong-fmor Q̂ (FMu.strong-extend-mor gs₂ FamP.p₂)
+
+    b̂δ : FM.Mor (η .fobj (Creal Q δ̂₂)) (η .fobj (Creal Q δ̂₁))
+    b̂δ = untranspose {W = η .fobj (Creal Q δ̂₂)} (muδ .bwd ∘ realise-η-iso (Creal Q δ̂₂) .fwd)
+
+    NB₂ = FMu.fmor Q̂ (pureExt δ̂₂ b̂δ)
+
+    A₁ = Sδ₁.A'
+    A₂ = Sδ₂.A'
+
+    B' : ℰP.prod Γ (Creal Q δ̂₂) ⇒ Creal Q ε̂₂
+    B' = (muε .fwd ∘ A₁) ∘co (muδ .bwd ∘ ℰP.p₂)
+
+    -- The backward form of the counit invariance square.
+    counit-invariance-bwd : (MCε.GI C₂ε .fwd ∘ realise .fmor NFε₁) ∘ Kε₁ .bwd
+                          ≈ Kε₂ .bwd ∘ Mεμ .fwd
+    counit-invariance-bwd =
+      begin
+        (MCε.GI C₂ε .fwd ∘ realise .fmor NFε₁) ∘ Kε₁ .bwd
+      ≈˘⟨ id-left ⟩
+        id _ ∘ ((MCε.GI C₂ε .fwd ∘ realise .fmor NFε₁) ∘ Kε₁ .bwd)
+      ≈˘⟨ ∘-cong₁ (Kε₂ .bwd∘fwd≈id) ⟩
+        (Kε₂ .bwd ∘ Kε₂ .fwd) ∘ ((MCε.GI C₂ε .fwd ∘ realise .fmor NFε₁) ∘ Kε₁ .bwd)
+      ≈⟨ assoc _ _ _ ⟩
+        Kε₂ .bwd ∘ (Kε₂ .fwd ∘ ((MCε.GI C₂ε .fwd ∘ realise .fmor NFε₁) ∘ Kε₁ .bwd))
+      ≈˘⟨ ∘-cong₂ (assoc _ _ _) ⟩
+        Kε₂ .bwd ∘ ((Kε₂ .fwd ∘ (MCε.GI C₂ε .fwd ∘ realise .fmor NFε₁)) ∘ Kε₁ .bwd)
+      ≈⟨ ∘-cong₂ (∘-cong₁ counit-invariance-square) ⟩
+        Kε₂ .bwd ∘ ((Mεμ .fwd ∘ Kε₁ .fwd) ∘ Kε₁ .bwd)
+      ≈⟨ ∘-cong₂ (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (Kε₁ .fwd∘bwd≈id)) id-right)) ⟩
+        Kε₂ .bwd ∘ Mεμ .fwd
+      ∎ where open ≈-Reasoning isEquiv
+
+    -- The μ-invariance against the realised algebra map, in invariance form.
+    head-eq : muε .fwd ∘ realise .fmor (FMu.inMap Q̂ ε̂₁)
+              ≈ Mε₂.inR ∘ (Kε₂ .bwd ∘ Mεμ .fwd)
+    head-eq =
+      ≈-trans (∘-cong₂ (inR-K Q ε̂₁ CQ))
+        (≈-trans (≈-sym (assoc _ _ _))
+          (≈-trans (∘-cong₁ (mu-invariance-fwd-in Q CQ ε̂₁ ε̂₂ isosε))
+            (≈-trans (assoc _ _ _) (∘-cong₂ counit-invariance-bwd))))
+
+    -- Gmap of the composite, decomposed into pure lifts around the crossing.
+    gmapB' : Gmap Q δ̂₂ B' ≈ ((realise .fmor NF₂ ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ A₁) ∘co (realise .fmor NB₂ ∘ ℰP.p₂)
+    gmapB' =
+      ≈-trans (Gmap-cong Q δ̂₂ (CoK.∘-cong₁ split))
+        (≈-trans (Gmap-∘co Q δ̂₂ ((muε .fwd ∘ ℰP.p₂) ∘co A₁) (muδ .bwd ∘ ℰP.p₂))
+          (CoK.∘-cong
+            (≈-trans (Gmap-∘co Q δ̂₂ (muε .fwd ∘ ℰP.p₂) A₁)
+              (CoK.∘-cong₁ (Gmap-pure Q δ̂₂ (muε .fwd))))
+            (Gmap-pure Q δ̂₂ (muδ .bwd))))
+      where
+        split : muε .fwd ∘ A₁ ≈ (muε .fwd ∘ ℰP.p₂) ∘co A₁
+        split = ≈-sym (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _)))
+
+    -- The composite tails agree, over any head.
+    bracket : ((MCδ.GI C₁ε .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ A₁) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂)
+              ≈ Gmap Q δ̂₂ A₁ ∘co (realise .fmor NB₂ ∘ ℰP.p₂)
+    bracket =
+      begin
+        ((MCδ.GI C₁ε .fwd ∘ ℰP.p₂) ∘co Gmap Q δ̂₁ A₁) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₁ (≈-trans (assoc _ _ _) (∘-cong₂ (ℰP.pair-p₂ _ _))) ⟩
+        (MCδ.GI C₁ε .fwd ∘ Gmap Q δ̂₁ A₁) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂)
+      ≈˘⟨ CoK.∘-cong₁ (MCδ.crossΓ A₁) ⟩
+        (Gmap Q δ̂₂ A₁ ∘co (MCδ.GI (Creal Q δ̂₁) .fwd ∘ ℰP.p₂)) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂)
+      ≈⟨ CoK.assoc _ _ _ ⟩
+        Gmap Q δ̂₂ A₁ ∘co ((MCδ.GI (Creal Q δ̂₁) .fwd ∘ ℰP.p₂) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂))
+      ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+        Gmap Q δ̂₂ A₁ ∘co ((MCδ.GI (Creal Q δ̂₁) .fwd ∘ (MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂)) ∘ ℰP.p₂)
+      ≈⟨ CoK.∘-cong₂ (∘-cong₁ (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (MCδ.GI (Creal Q δ̂₁) .fwd∘bwd≈id)) id-left))) ⟩
+        Gmap Q δ̂₂ A₁ ∘co (realise .fmor NB₂ ∘ ℰP.p₂)
+      ∎ where open ≈-Reasoning isEquiv
+
+    -- The δ̂₁-side tail transforms into the δ̂₂-side tail (named factors,
+    -- normalised to right-nested form on both sides).
+    tail-eq : ∀ {Z : obj} (X : ℰP.prod Γ (realise .fobj (FM.fobj FM.μObj Q̂ (extend δ̂₁ (FM.μObj Q̂ ε̂₁)))) ⇒ Z) →
+              ((X ∘co (KK₁ .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ A₁) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂)
+              ≈ ((X ∘co (Mδμ .bwd ∘ ℰP.p₂)) ∘co (KK₂ .fwd ∘ ℰP.p₂)) ∘co (((realise .fmor NF₂ ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ A₁) ∘co (realise .fmor NB₂ ∘ ℰP.p₂))
+    tail-eq {Z} X = ≈-trans lhs-norm (≈-sym rhs-norm)
+      where
+        k₁ = KK₁ .fwd ∘ ℰP.p₂
+        g₁ = Gmap Q δ̂₁ A₁
+        r  = (MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂
+        mδ = Mδμ .bwd ∘ ℰP.p₂
+        k₂ = KK₂ .fwd ∘ ℰP.p₂
+        nf = realise .fmor NF₂ ∘ ℰP.p₂
+        gi = MCδ.GI C₁ε .fwd ∘ ℰP.p₂
+        g₂ = Gmap Q δ̂₂ A₁
+        nb = realise .fmor NB₂ ∘ ℰP.p₂
+
+
+        k₁-split : k₁ ≈ mδ ∘co (k₂ ∘co (nf ∘co gi))
+        k₁-split =
+          begin
+            KK₁ .fwd ∘ ℰP.p₂
+          ≈⟨ ∘-cong₁ (iso-shuffle Mδμ _ _ env-invariance-square) ⟩
+            (Mδμ .bwd ∘ ((KK₂ .fwd ∘ realise .fmor NF₂) ∘ MCδ.GI C₁ε .fwd)) ∘ ℰP.p₂
+          ≈˘⟨ co-pure _ _ ⟩
+            mδ ∘co (((KK₂ .fwd ∘ realise .fmor NF₂) ∘ MCδ.GI C₁ε .fwd) ∘ ℰP.p₂)
+          ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+            mδ ∘co (((KK₂ .fwd ∘ realise .fmor NF₂) ∘ ℰP.p₂) ∘co gi)
+          ≈˘⟨ CoK.∘-cong₂ (CoK.∘-cong₁ (co-pure _ _)) ⟩
+            mδ ∘co ((k₂ ∘co nf) ∘co gi)
+          ≈⟨ CoK.∘-cong₂ (CoK.assoc _ _ _) ⟩
+            mδ ∘co (k₂ ∘co (nf ∘co gi))
+          ∎ where open ≈-Reasoning isEquiv
+
+        lhs-norm : ((X ∘co k₁) ∘co g₁) ∘co r ≈ X ∘co (mδ ∘co (k₂ ∘co (nf ∘co (g₂ ∘co nb))))
+        lhs-norm =
+          begin
+            ((X ∘co k₁) ∘co g₁) ∘co r
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            (X ∘co k₁) ∘co (g₁ ∘co r)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            X ∘co (k₁ ∘co (g₁ ∘co r))
+          ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₁ k₁-split) ⟩
+            X ∘co ((mδ ∘co (k₂ ∘co (nf ∘co gi))) ∘co (g₁ ∘co r))
+          ≈⟨ CoK.∘-cong₂ (CoK.assoc _ _ _) ⟩
+            X ∘co (mδ ∘co ((k₂ ∘co (nf ∘co gi)) ∘co (g₁ ∘co r)))
+          ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₂ (CoK.assoc _ _ _)) ⟩
+            X ∘co (mδ ∘co (k₂ ∘co ((nf ∘co gi) ∘co (g₁ ∘co r))))
+          ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₂ (CoK.∘-cong₂ (CoK.assoc _ _ _))) ⟩
+            X ∘co (mδ ∘co (k₂ ∘co (nf ∘co (gi ∘co (g₁ ∘co r)))))
+          ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₂ (CoK.∘-cong₂ (CoK.∘-cong₂ (≈-trans (≈-sym (CoK.assoc _ _ _)) bracket)))) ⟩
+            X ∘co (mδ ∘co (k₂ ∘co (nf ∘co (g₂ ∘co nb))))
+          ∎ where open ≈-Reasoning isEquiv
+
+        rhs-norm : ((X ∘co mδ) ∘co k₂) ∘co ((nf ∘co g₂) ∘co nb) ≈ X ∘co (mδ ∘co (k₂ ∘co (nf ∘co (g₂ ∘co nb))))
+        rhs-norm =
+          begin
+            ((X ∘co mδ) ∘co k₂) ∘co ((nf ∘co g₂) ∘co nb)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            (X ∘co mδ) ∘co (k₂ ∘co ((nf ∘co g₂) ∘co nb))
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            X ∘co (mδ ∘co (k₂ ∘co ((nf ∘co g₂) ∘co nb)))
+          ≈⟨ CoK.∘-cong₂ (CoK.∘-cong₂ (CoK.∘-cong₂ (CoK.assoc _ _ _))) ⟩
+            X ∘co (mδ ∘co (k₂ ∘co (nf ∘co (g₂ ∘co nb))))
+          ∎ where open ≈-Reasoning isEquiv
+
+    HEAD : ℰP.prod Γ (realise .fobj (FM.fobj FM.μObj Q̂ (extend δ̂₁ (FM.μObj Q̂ ε̂₁)))) ⇒ Creal Q ε̂₂
+    HEAD = (Mε₂.inR ∘ (Kε₂ .bwd ∘ Mεμ .fwd)) ∘ fmorη Γ _ sfp₁
+
+
+    -- The δ̂₂-side fold algebra, in composite form.
+    head₂-eq : fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂₂ (FM.μObj Q̂ ε̂₂)))
+                 (FM.Mor-∘ (FMu.inMap Q̂ ε̂₂) sfp₂)
+               ≈ HEAD ∘co (Mδμ .bwd ∘ ℰP.p₂)
+    head₂-eq =
+      ≈-trans (fmorη-post Γ _ (FMu.inMap Q̂ ε̂₂) sfp₂)
+        (≈-trans (∘-cong₁ (inR-K Q ε̂₂ CQ))
+          (≈-trans (∘-cong₂ (≈-sym (co-iso-cancel Mδμ (cross-mixed Q CQ isosδ isosε {Ŷ₁ = FM.μObj Q̂ ε̂₁} {Ŷ₂ = FM.μObj Q̂ ε̂₂} muε gs₁ gs₂ sqs))))
+            (≈-trans (≈-sym (assoc _ _ _)) (CoK.∘-cong₁ (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (assoc _ _ _)))))))
+
+    -- The δ̂₁-side fold algebra, pushed under the ε̂-invariance.
+    head₁-eq : muε .fwd ∘ Sδ₁.aStar ≈ HEAD ∘co (KK₁ .fwd ∘ ℰP.p₂)
+    head₁-eq =
+      ≈-trans (≈-sym (assoc _ _ _)) (CoK.∘-cong₁ head-inner)
+      where
+        head-inner : muε .fwd ∘ fmorη Γ (FM.fobj FM.μObj Q̂ (extend δ̂₁ (FM.μObj Q̂ ε̂₁))) (FM.Mor-∘ (FMu.inMap Q̂ ε̂₁) sfp₁) ≈ HEAD
+        head-inner =
+          ≈-trans (∘-cong₂ (fmorη-post Γ _ (FMu.inMap Q̂ ε̂₁) sfp₁))
+            (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ head-eq))
+
+    -- The fold square for the composite candidate.
+    B-square : B' ∘co (Mδ₂.inR ∘ ℰP.p₂) ≈ Sδ₂.aStar ∘co Gmap Q δ̂₂ B'
+    B-square = ≈-trans lhs-eq (≈-sym (CoK.∘-cong (CoK.∘-cong₁ head₂-eq) gmapB'))
+      where
+        step-fold : (muε .fwd ∘ A₁) ∘co (Mδ₁.inR ∘ ℰP.p₂)
+                    ≈ (HEAD ∘co (KK₁ .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ A₁
+        step-fold =
+          ≈-trans (assoc _ _ _)
+            (≈-trans (∘-cong₂ Sδ₁.sμf-square)
+              (≈-trans (≈-sym (assoc _ _ _)) (CoK.∘-cong₁ head₁-eq)))
+
+        lhs-eq : B' ∘co (Mδ₂.inR ∘ ℰP.p₂)
+                 ≈ ((HEAD ∘co (Mδμ .bwd ∘ ℰP.p₂)) ∘co (KK₂ .fwd ∘ ℰP.p₂)) ∘co (((realise .fmor NF₂ ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ A₁) ∘co (realise .fmor NB₂ ∘ ℰP.p₂))
+        lhs-eq =
+          begin
+            B' ∘co (Mδ₂.inR ∘ ℰP.p₂)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            (muε .fwd ∘ A₁) ∘co ((muδ .bwd ∘ ℰP.p₂) ∘co (Mδ₂.inR ∘ ℰP.p₂))
+          ≈⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+            (muε .fwd ∘ A₁) ∘co ((muδ .bwd ∘ Mδ₂.inR) ∘ ℰP.p₂)
+          ≈⟨ CoK.∘-cong₂ (∘-cong₁ (mu-invariance-bwd-in Q CQ δ̂₁ δ̂₂ isosδ)) ⟩
+            (muε .fwd ∘ A₁) ∘co ((Mδ₁.inR ∘ (MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂)) ∘ ℰP.p₂)
+          ≈˘⟨ CoK.∘-cong₂ (co-pure _ _) ⟩
+            (muε .fwd ∘ A₁) ∘co ((Mδ₁.inR ∘ ℰP.p₂) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂))
+          ≈˘⟨ CoK.assoc _ _ _ ⟩
+            ((muε .fwd ∘ A₁) ∘co (Mδ₁.inR ∘ ℰP.p₂)) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂)
+          ≈⟨ CoK.∘-cong₁ step-fold ⟩
+            ((HEAD ∘co (KK₁ .fwd ∘ ℰP.p₂)) ∘co Gmap Q δ̂₁ A₁) ∘co ((MCδ.GI (Creal Q δ̂₁) .bwd ∘ realise .fmor NB₂) ∘ ℰP.p₂)
+          ≈⟨ tail-eq HEAD ⟩
+            ((HEAD ∘co (Mδμ .bwd ∘ ℰP.p₂)) ∘co (KK₂ .fwd ∘ ℰP.p₂)) ∘co (((realise .fmor NF₂ ∘ ℰP.p₂) ∘co Gmap Q δ̂₂ A₁) ∘co (realise .fmor NB₂ ∘ ℰP.p₂))
+          ∎ where open ≈-Reasoning isEquiv
+
+  -- The naturality square of the μ-invariance.
+  mu-natural : Sδ₂.A' ∘co (muδ .fwd ∘ ℰP.p₂) ≈ muε .fwd ∘ Sδ₁.A'
+  mu-natural =
+    co-iso-move muδ (≈-trans Sδ₂.sμf-fold (≈-sym (Mδ₂.foldR-η Sδ₂.aStar B' B-square)))
+
+-- The μ case of the invariance interface.
+invariance-mu : ∀ {n} {P : Poly ℰ (suc n)} → InvarianceAt P → InvarianceAt (μ P)
+invariance-mu {n} {P} CP .iso = MuInvariance.mu-invariance P CP
+invariance-mu {n} {P} CP .natural {Γ} {ε̂₁} {ε̂₂} δ̂₁ δ̂₂ isosδ isosε gs₁ gs₂ sqs =
+  MuNat.mu-natural P CP δ̂₁ δ̂₂ ε̂₁ ε̂₂ isosδ isosε gs₁ gs₂ sqs
+invariance-mu {n} {P} CP .comp δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃ = mu-invariance-comp P CP δ̂₁ δ̂₂ δ̂₃ isos₁₂ isos₂₃
+
+-- Every polynomial admits environment invariance.
+invarianceAt : ∀ {n} (P : Poly ℰ n) → InvarianceAt P
+invarianceAt (const A) = invariance-const A
+invarianceAt (var i)   = invariance-var i
+invarianceAt (P + Q)   = invariance-sum (invarianceAt P) (invarianceAt Q)
+invarianceAt (P × Q)   = invariance-prod (invarianceAt P) (invarianceAt Q)
+invarianceAt (μ P)     = invariance-mu (invarianceAt P)
diff --git a/agda/src/fam-mu-realisation/pure.agda b/agda/src/fam-mu-realisation/pure.agda
new file mode 100644
index 00000000..bf957797
--- /dev/null
+++ b/agda/src/fam-mu-realisation/pure.agda
@@ -0,0 +1,136 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Pure lifts: realisation in context of pure Fam(ℰ) morphisms reduces to
+-- the realised plain functorial action.
+
+open import Level using (Level; _⊔_)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import prop-setoid using (Setoid; module ≈-Reasoning)
+open import categories
+  using (Category; setoid→category; HasTerminal; HasProducts; HasExponentials;
+         HasStrongCoproducts; HasCoproducts; strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor; HasColimits)
+open import polynomial-functor using (Poly; extend; Poly-map)
+import fam
+import fam-mu-types
+import fam-realisation
+import polynomial-functor
+import fam-mu-realisation.context
+
+module fam-mu-realisation.pure {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os (os ⊔ es)) → HasColimits (setoid→category A) ℰ)
+  (ℰT : HasTerminal ℰ) (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP)
+  (ℰSC : HasStrongCoproducts ℰ ℰP)
+  where
+
+open fam-mu-realisation.context os es ℰC ℰT ℰP ℰE ℰSC public
+
+-- Untransposition absorbs realised precomposition.
+untranspose-pre : ∀ {V W : FM.Obj} {X : obj}
+                  (g : realise .fobj W ⇒ X) (w : FM.Mor V W) →
+                  FamC._≈_ (untranspose (g ∘ realise .fmor w)) (FM.Mor-∘ (untranspose g) w)
+untranspose-pre {V} {W} {X} g w =
+  FamC.≈-sym
+    (FamC.≈-trans (FamC.≈-sym (FR.untranspose-transpose (FM.Mor-∘ (untranspose g) w)))
+      (FR.untranspose-cong
+        (≈-trans (FR.transpose-natural₁ (untranspose g) w)
+          (∘-cong₁ (FR.transpose-untranspose g)))))
+
+-- The transposed form of a pure context morphism.
+ctxη-pure : ∀ (Γ A : obj) {B : obj} (m : A ⇒ B) →
+            FamC._≈_ (ctxη Γ A (m ∘ ℰP.p₂))
+              (FM.Mor-∘ (untranspose (m ∘ realise-η-iso A .fwd)) (FamP.p₂ {x = η .fobj Γ} {y = η .fobj A}))
+ctxη-pure Γ A {B} m =
+  FamC.≈-trans (FR.untranspose-cong inner) (untranspose-pre (m ∘ realise-η-iso A .fwd) _)
+  where
+    inner : (m ∘ ℰP.p₂) ∘ (ℰP.prod-m (id _) (realise-η-iso A .fwd) ∘ prodη Γ (η .fobj A) .fwd)
+            ≈ (m ∘ realise-η-iso A .fwd) ∘ realise .fmor (FamP.p₂ {x = η .fobj Γ} {y = η .fobj A})
+    inner =
+      begin
+        (m ∘ ℰP.p₂) ∘ (ℰP.prod-m (id _) (realise-η-iso A .fwd) ∘ prodη Γ (η .fobj A) .fwd)
+      ≈˘⟨ assoc _ _ _ ⟩
+        ((m ∘ ℰP.p₂) ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd)) ∘ prodη Γ (η .fobj A) .fwd
+      ≈⟨ ∘-cong₁ (assoc _ _ _) ⟩
+        (m ∘ (ℰP.p₂ ∘ ℰP.prod-m (id _) (realise-η-iso A .fwd))) ∘ prodη Γ (η .fobj A) .fwd
+      ≈⟨ ∘-cong₁ (∘-cong₂ (ℰP.pair-p₂ _ _)) ⟩
+        (m ∘ (realise-η-iso A .fwd ∘ ℰP.p₂)) ∘ prodη Γ (η .fobj A) .fwd
+      ≈˘⟨ ∘-cong₁ (assoc _ _ _) ⟩
+        ((m ∘ realise-η-iso A .fwd) ∘ ℰP.p₂) ∘ prodη Γ (η .fobj A) .fwd
+      ≈⟨ assoc _ _ _ ⟩
+        (m ∘ realise-η-iso A .fwd) ∘ (ℰP.p₂ ∘ prodη Γ (η .fobj A) .fwd)
+      ≈⟨ ∘-cong₂ (prodη-p₂ Γ (η .fobj A)) ⟩
+        (m ∘ realise-η-iso A .fwd) ∘ realise .fmor (FamP.p₂ {x = η .fobj Γ} {y = η .fobj A})
+      ∎ where open ≈-Reasoning isEquiv
+
+-- Extend a pure morphism to the bound entry, identities elsewhere.
+pureExt : ∀ {n} (δ̂ : Fin n → FM.Obj) { B̂ : FM.Obj} → FM.Mor  B̂ →
+          ∀ i → FM.Mor (extend δ̂ Â i) (extend δ̂ B̂ i)
+pureExt δ̂ m̂ Fin.zero    = m̂
+pureExt δ̂ m̂ (Fin.suc i) = FamC.id _
+
+module FamT = HasTerminal (FM.terminal ℰT)
+
+-- The Fam(ℰ) strong action at a purely-precomposed family is the plain action
+-- precomposed with the projection.
+sf-pure : ∀ {n} (Q : Poly ℰ (suc n)) (δ̂₁ δ̂₂ : Fin (suc n) → FM.Obj) {Γ : obj}
+          (ms : ∀ i → FM.Mor (δ̂₁ i) (δ̂₂ i)) →
+          FamC._≈_
+            (FM.Mor-∘ (FMu.fmor (Poly-map η Q) ms) (FamP.p₂ {x = η .fobj Γ} {y = FM.fobj FM.μObj (Poly-map η Q) δ̂₁}))
+            (FMu.strong-fmor (Poly-map η Q) (λ i → FM.Mor-∘ (ms i) (FamP.p₂ {x = η .fobj Γ} {y = δ̂₁ i})))
+sf-pure {n} Q δ̂₁ δ̂₂ {Γ} ms =
+  FamC.≈-trans (FamC.assoc _ _ _)
+    (FamC.≈-trans (FamC.∘-cong₂ sect-proj)
+      (FamC.≈-trans (FMuI.strong-fmor-reindex (Poly-map η Q) FamT.to-terminal _)
+        (FMuI.strong-fmor-cong (Poly-map η Q) pointwise)))
+  where
+    sect-proj : FamC._≈_
+                  (FM.Mor-∘ (FamP.pair FamT.to-terminal (FamC.id _)) (FamP.p₂ {x = η .fobj Γ} {y = FM.fobj FM.μObj (Poly-map η Q) δ̂₁}))
+                  (FamP.prod-m FamT.to-terminal (FamC.id _))
+    sect-proj =
+      FamC.≈-trans (FamP.pair-natural _ _ _)
+        (FamP.pair-cong (FamT.to-terminal-unique _ _) FamC.≈-refl)
+
+    pointwise : ∀ i → FamC._≈_
+                  (FM.Mor-∘ (FM.Mor-∘ (ms i) (FamP.p₂ {x = FamT.witness} {y = δ̂₁ i})) (FamP.prod-m FamT.to-terminal (FamC.id _)))
+                  (FM.Mor-∘ (ms i) (FamP.p₂ {x = η .fobj Γ} {y = δ̂₁ i}))
+    pointwise i =
+      FamC.≈-trans (FamC.assoc _ _ _)
+        (FamC.∘-cong₂
+          (FamC.≈-trans (FamP.pair-p₂ _ _) FamC.id-left))
+
+-- The realised strong action on a pure morphism is a pure lift of the
+-- realised plain Fam(ℰ) action.
+Gmap-pure : ∀ {n} (Q : Poly ℰ (suc n)) (δ̂ : Fin n → FM.Obj) {Γ A B : obj} (m : A ⇒ B) →
+            Gmap Q δ̂ {Γ} {A} {B} (m ∘ ℰP.p₂)
+            ≈ realise .fmor (FMu.fmor (Poly-map η Q) (pureExt δ̂ (untranspose (m ∘ realise-η-iso A .fwd)))) ∘ ℰP.p₂
+Gmap-pure {n} Q δ̂ {Γ} {A} {B} m =
+  ≈-trans (fmorη-cong (FMuI.strong-fmor-cong (Poly-map η Q) pw))
+    (≈-trans (fmorη-cong (FamC.≈-sym (sf-pure Q (extend δ̂ (η .fobj A)) (extend δ̂ (η .fobj B)) (pureExt δ̂ m̂))))
+      (fmorη-pure Γ (FM.fobj FM.μObj (Poly-map η Q) (extend δ̂ (η .fobj A))) (FMu.fmor (Poly-map η Q) (pureExt δ̂ m̂))))
+  where
+    m̂ = untranspose (m ∘ realise-η-iso A .fwd)
+
+    pw : ∀ i → FamC._≈_
+           (FMu.strong-extend-mor (λ j → FamP.p₂) (ctxη Γ A (m ∘ ℰP.p₂)) i)
+           (FM.Mor-∘ (pureExt δ̂ m̂ i) (FamP.p₂ {x = η .fobj Γ} {y = extend δ̂ (η .fobj A) i}))
+    pw Fin.zero    = ctxη-pure Γ A m
+    pw (Fin.suc i) = FamC.≈-sym FamC.id-left
+
+-- Realising an untransposed morphism is the counit inverse followed by it.
+realise-untranspose : ∀ {W : FM.Obj} {X : obj} (g : realise .fobj W ⇒ X) →
+                      realise .fmor (untranspose {W = W} g) ≈ realise-η-iso X .bwd ∘ g
+realise-untranspose {W} {X} g =
+  iso-shuffle (realise-η-iso X) _ _
+    (≈-trans (≈-sym (FR.transpose-realise {W = W} (untranspose {W = W} g))) (FR.transpose-untranspose {W = W} g))
+
+-- Transport an isomorphism of realisations across the singleton embedding.
+pureJ : ∀ {A B : obj} (I : Iso A B) → Iso (realise .fobj (η .fobj A)) (realise .fobj (η .fobj B))
+pureJ {A} {B} I =
+  Iso-trans (realise-η-iso A) (Iso-trans I (Iso-sym (realise-η-iso B)))
+
+pureJ-fwd : ∀ {A B : obj} (I : Iso A B) →
+            pureJ I .fwd ≈ realise .fmor (untranspose {W = η .fobj A} (I .fwd ∘ realise-η-iso A .fwd))
+pureJ-fwd {A} {B} I =
+  ≈-sym (≈-trans (realise-untranspose {W = η .fobj A} (I .fwd ∘ realise-η-iso A .fwd)) (≈-sym (assoc _ _ _)))
diff --git a/agda/src/fam-mu-types.agda b/agda/src/fam-mu-types.agda
new file mode 100644
index 00000000..5eaa79f3
--- /dev/null
+++ b/agda/src/fam-mu-types.agda
@@ -0,0 +1,749 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- μ-types (parameterised initial algebras of polynomial functors) for the Fam
+-- construction, built as sort-indexed W-types in setoids. This root module
+-- proves the initial-algebra laws — β (BetaDef, the fold satisfies the algebra
+-- square) and η (EtaDef, uniqueness), each by tree induction with the nested-μ
+-- cases discharged through fusion — and re-exports the construction itself
+-- from the layers beneath it.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_; lift) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Product using (_,_)
+open import Data.Unit using (tt)
+open import prop using (_,_)
+open import categories using (Category; HasTerminal; HasProducts)
+open import prop-setoid as PS using ()
+import indexed-family
+open indexed-family using (Fam; _⇒f_)
+import fam-mu-types.reindex-fusion
+
+module fam-mu-types {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open fam-mu-types.reindex-fusion os es T P public
+
+-- β/η proof machinery: the fusion of α's reconstruction with the fold equals the strong functorial action
+-- of `⦅ alg ⦆`.
+module BetaDef {n} {Γ A : Obj} {P : Poly (suc n)} {δ : Fin n → Obj}
+               (alg : Mor (Fam𝒞-P.prod Γ (fobj μObj P (extend δ A))) A) where
+  open HasMu hasMu using (strong-fmor; strong-extend-mor; ⦅_⦆; inMap)
+  module AM = InMapDef P δ
+  module FD = FoldDef {Γ = Γ} {A = A} {P = P} {δ = δ} alg
+  δ' = extend δ (μObj P δ)
+  fs : ∀ i → Mor (Fam𝒞-P.prod Γ (δ' i)) (extend δ A i)
+  fs = strong-extend-mor (λ i → Fam𝒞-P.p₂) FD.foldMor
+
+  -- Collapse the inMap-reconstruction reindex followed by the fold's reindex into one
+  -- index-only reindex, so the fusion lemmas can treat them as a single morphism.
+  module Rcomb = Reindex δ' (extend δ A)
+  combine : (γ : Γ .idx .Carrier) → ∀ {k} {ρA ρB ρC} {dA dB dC} →
+            AM.R.MorD {k} ρA ρB dA dB → FD.FMor {k} ρB ρC dB dC → Rcomb.IMorD {k} ρA ρC
+  combine γ md fm = Rcomb.ibase (λ v a → FD.fold-apply γ fm v (AM.R.apply md v a))
+    (λ v {a} {a'} p → FD.fold-apply-resp (Γ .idx .isEquivalence .refl) fm v
+      (AM.R.apply-resp md v {a} {a'} p))
+
+  mutual
+    -- Defunctionalised relation "these two Rcomb.IMorDs are combine-lemma-related under binders".
+    data Rel : ∀ {k} {ρA ρB} → Rcomb.IMorD {k} ρA ρB → Rcomb.IMorD {k} ρA ρB →
+               Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+      rcomb : ∀ {k} {ρA ρB ρC} {dA dB dC} (γ : Γ .idx .Carrier) (Q : Poly (suc k))
+              (md : AM.R.MorD ρA ρB dA dB) (fm : FD.FMor ρB ρC dB dC) →
+              Rel (combine γ (AM.R.bind Q md) (FD.fbind Q fm)) (Rcomb.ibind ∣ Q ∣ (combine γ md fm))
+      rbind : ∀ {k} {ρA ρB} {md₁ md₂ : Rcomb.IMorD ρA ρB} (R : Sh.Poly (suc k)) →
+              Rel md₁ md₂ → Rel (Rcomb.ibind R md₁) (Rcomb.ibind R md₂)
+
+    -- reindex respects Rel-related morphisms; the binder recursion is structural on Rel.
+    reindex-mcong : ∀ {k} {R : Sh.Poly (suc k)} {ρA ρB} {md₁ md₂ : Rcomb.IMorD ρA ρB}
+                    (r : Rel md₁ md₂) (t : AM.TX.W R ρA) → FD.TA'.W-≈ (Rcomb.ireindex md₁ t) (Rcomb.ireindex md₂ t)
+    reindex-mcong {R = R} r (AM.TX.sup y) = reindex-mcong-shape R (rbind R r) y
+
+    reindex-mcong-shape : ∀ {j} (R : Sh.Poly j) {ρA ρB} {md₁ md₂ : Rcomb.IMorD ρA ρB}
+                          (r : Rel md₁ md₂) (y : AM.TX.⟦ R ⟧shape ρA) →
+                          FD.TA'.shape≈ R ρB (Rcomb.ireindex-shape R md₁ y) (Rcomb.ireindex-shape R md₂ y)
+    reindex-mcong-shape (const S) r y = S .isEquivalence .refl
+    reindex-mcong-shape (var v)    r y = mrel-apply r v
+    reindex-mcong-shape (P + P') r (inj₁ y) = reindex-mcong-shape P r y
+    reindex-mcong-shape (P + P') r (inj₂ z) = reindex-mcong-shape P' r z
+    reindex-mcong-shape (P × P') r (y , z) = reindex-mcong-shape P r y , reindex-mcong-shape P' r z
+    reindex-mcong-shape (μ R'') r y = reindex-mcong r y
+
+    mrel-apply : ∀ {k} {ρA ρB} {md₁ md₂ : Rcomb.IMorD ρA ρB} (r : Rel md₁ md₂) (v : Fin k) {a} →
+                 FD.TA'.elEq (ρB v) (Rcomb.iapply md₁ v a) (Rcomb.iapply md₂ v a)
+    mrel-apply (rcomb γ Q md fm)            Fin.zero     {a} = combine-lemma γ md fm a
+    mrel-apply (rcomb {ρC = ρC} γ Q md fm) (Fin.suc v')      = FD.TA'.elEq-refl (ρC v') _
+    mrel-apply (rbind R r)                  Fin.zero     {a} = reindex-mcong r a
+    mrel-apply (rbind R r)                 (Fin.suc v')      = mrel-apply r v'
+
+    combine-lemma : ∀ {k} {Q : Poly (suc k)} {ρA ρB ρC} {dA dB dC} (γ : Γ .idx .Carrier)
+                    (md : AM.R.MorD ρA ρB dA dB) (fm : FD.FMor ρB ρC dB dC) (t : AM.TX.W ∣ Q ∣ ρA) →
+                    FD.TA'.W-≈ (FD.fold-reindex γ fm (AM.R.reindex md t)) (Rcomb.ireindex (combine γ md fm) t)
+    combine-lemma {Q = Q} γ md fm (AM.TX.sup x) = combine-lemma-shape Q Q γ md fm x
+
+    combine-lemma-shape : ∀ {k} (Q : Poly (suc k)) (R : Poly (suc k)) {ρA ρB ρC} {dA dB dC} (γ : Γ .idx .Carrier)
+                          (md : AM.R.MorD ρA ρB dA dB) (fm : FD.FMor ρB ρC dB dC)
+                          (x : AM.TX.⟦ ∣ R ∣ ⟧shape (extend ρA (inj₂ (mkSort ∣ Q ∣ ρA)))) →
+                          FD.TA'.shape≈ ∣ R ∣ (extend ρC (inj₂ (mkSort ∣ Q ∣ ρC)))
+                            (FD.fold-reindex-shape γ R (FD.fbind Q fm) (AM.R.reindex-shape ∣ R ∣ (AM.R.bind Q md) x))
+                            (Rcomb.ireindex-shape ∣ R ∣ (Rcomb.ibind ∣ Q ∣ (combine γ md fm)) x)
+    combine-lemma-shape Q (const A')              γ md fm x = A' .idx .isEquivalence .refl
+    combine-lemma-shape Q (var Fin.zero)          γ md fm x = combine-lemma γ md fm x
+    combine-lemma-shape Q (var (Fin.suc v)) {ρC = ρC} γ md fm x = FD.TA'.elEq-refl (ρC v) _
+    combine-lemma-shape Q (P + Q') γ md fm (inj₁ x) = combine-lemma-shape Q P γ md fm x
+    combine-lemma-shape Q (P + Q') γ md fm (inj₂ y) = combine-lemma-shape Q Q' γ md fm y
+    combine-lemma-shape Q (P × Q') γ md fm (x , y) =
+      combine-lemma-shape Q P γ md fm x , combine-lemma-shape Q Q' γ md fm y
+    combine-lemma-shape Q (μ R'') γ md fm x =
+      FD.TA'.W-≈-trans {x = FD.fold-reindex γ (FD.fbind Q fm) (AM.R.reindex (AM.R.bind Q md) x)}
+                       {y = Rcomb.ireindex (combine γ (AM.R.bind Q md) (FD.fbind Q fm)) x}
+                       (combine-lemma γ (AM.R.bind Q md) (FD.fbind Q fm) x)
+                       (reindex-mcong (rcomb γ Q md fm) x)
+
+  -- Fibre mirror of the collapse, at a fixed γ: `combine-act` is combine's Γ-dependent
+  -- fibre action, and the lemmas transport the fibre composites along the corresponding
+  -- index proofs, mirroring `Rel`/`reindex-mcong`/`combine-lemma` clause by clause.
+  module CombineFam (γ : Γ .idx .Carrier) where
+    module FR = FReindex {δA = δ'} {δB = extend δ A} (Γ .fam .fm γ)
+
+    combine-act : ∀ {k} {ρA ρB ρC} {dA dB dC} (md : AM.R.MorD {k} ρA ρB dA dB) (fm : FD.FMor {k} ρB ρC dB dC) →
+                  FR.FAct (combine γ md fm) dA dC
+    combine-act md fm =
+      FR.abase (λ v a → FD.fold-apply-fam γ fm v (AM.R.apply md v a)
+                        ∘ prod-m (id (Fam.fm (Γ .fam) γ)) (AM.R.apply-fam md v a))
+
+    mutual
+      -- Fibre actions over Rel-related morphisms, related constructor by constructor.
+      data RelAct : ∀ {k} {ρA ρB} {dA dB} {md₁ md₂ : Rcomb.IMorD {k} ρA ρB} →
+                    Rel md₁ md₂ → FR.FAct md₁ dA dB → FR.FAct md₂ dA dB →
+                    Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+        rcombA : ∀ {k} {ρA ρB ρC} {dA dB dC} (Q : Poly (suc k))
+                 (md : AM.R.MorD ρA ρB dA dB) (fm : FD.FMor ρB ρC dB dC) →
+                 RelAct (rcomb γ Q md fm) (combine-act (AM.R.bind Q md) (FD.fbind Q fm))
+                        (FR.abind Q (combine γ md fm) (combine-act md fm))
+        rbindA : ∀ {k} {ρA ρB} {dA dB} {md₁ md₂ : Rcomb.IMorD ρA ρB} {r : Rel md₁ md₂}
+                 {a₁ : FR.FAct md₁ dA dB} {a₂ : FR.FAct md₂ dA dB} (Q : Poly (suc k)) →
+                 RelAct r a₁ a₂ → RelAct (rbind ∣ Q ∣ r) (FR.abind Q md₁ a₁) (FR.abind Q md₂ a₂)
+
+      reindex-mcong-fam : ∀ {k} {Q : Poly (suc k)} {ρA ρB} {dA dB} {md₁ md₂ : Rcomb.IMorD ρA ρB}
+                          {r : Rel md₁ md₂} {a₁ : FR.FAct md₁ dA dB} {a₂ : FR.FAct md₂ dA dB}
+                          (ra : RelAct r a₁ a₂) (t : AM.TX.W ∣ Q ∣ ρA) →
+                          FD.TA'.fib-subst Q dB {x = Rcomb.ireindex md₁ t} {y = Rcomb.ireindex md₂ t}
+                             (reindex-mcong r t) ∘ FR.freindex-fam a₁ {t} ≈
+                          FR.freindex-fam a₂ {t}
+      reindex-mcong-fam {Q = Q} ra (AM.TX.sup y) = reindex-mcong-shape-fam Q (rbindA Q ra) y
+
+      reindex-mcong-shape-fam : ∀ {j} (R : Poly j) {ρA ρB} {dA dB} {md₁ md₂ : Rcomb.IMorD ρA ρB}
+                                {r : Rel md₁ md₂} {a₁ : FR.FAct md₁ dA dB} {a₂ : FR.FAct md₂ dA dB}
+                                (ra : RelAct r a₁ a₂) (y : AM.TX.⟦ ∣ R ∣ ⟧shape ρA) →
+                                (FD.TA'.fib-shape-subst R dB (reindex-mcong-shape ∣ R ∣ r y) ∘ FR.freindex-shape-fam R a₁ {y})
+                                ≈ FR.freindex-shape-fam R a₂ {y}
+      reindex-mcong-shape-fam (const A') ra y =
+        ≈-trans (∘-cong (A' .fam .refl*) ≈-refl) id-left
+      reindex-mcong-shape-fam (var v) ra y = mrel-apply-fam ra v
+      reindex-mcong-shape-fam (P + P') ra (inj₁ y) = reindex-mcong-shape-fam P ra y
+      reindex-mcong-shape-fam (P + P') ra (inj₂ z) = reindex-mcong-shape-fam P' ra z
+      reindex-mcong-shape-fam (P × P') ra (y , z) =
+        ≈-trans (strong-prod-m-post _ _ _ _)
+          (strong-prod-m-cong (reindex-mcong-shape-fam P ra y) (reindex-mcong-shape-fam P' ra z))
+      reindex-mcong-shape-fam (μ R'') ra y = reindex-mcong-fam {Q = R''} ra y
+
+      mrel-apply-fam : ∀ {k} {ρA ρB} {dA dB} {md₁ md₂ : Rcomb.IMorD ρA ρB}
+                       {r : Rel md₁ md₂} {a₁ : FR.FAct md₁ dA dB} {a₂ : FR.FAct md₂ dA dB}
+                       (ra : RelAct r a₁ a₂) (v : Fin k) {z} →
+                       FD.TA'.fib-el-subst (ρB v) (dB v) (mrel-apply r v {z}) ∘ FR.aapply a₁ v z ≈ FR.aapply a₂ v z
+      mrel-apply-fam (rcombA Q md fm) Fin.zero {z} = combine-lemma-fam md fm z
+      mrel-apply-fam (rcombA {ρC = ρC} Q md fm) (Fin.suc v') {z} =
+        ≈-trans (∘-cong (FD.TA'.fib-el-refl* (ρC v') _ _) ≈-refl) id-left
+      mrel-apply-fam (rbindA Q ra) Fin.zero {z} = reindex-mcong-fam {Q = Q} ra z
+      mrel-apply-fam (rbindA Q ra) (Fin.suc v') = mrel-apply-fam ra v'
+
+      combine-lemma-fam : ∀ {k} {Q : Poly (suc k)} {ρA ρB ρC} {dA dB dC}
+                          (md : AM.R.MorD ρA ρB dA dB) (fm : FD.FMor ρB ρC dB dC) (t : AM.TX.W ∣ Q ∣ ρA) →
+                          (FD.TA'.fib-subst Q dC {x = FD.fold-reindex γ fm (AM.R.reindex md t)}
+                                            {y = Rcomb.ireindex (combine γ md fm) t}
+                             (combine-lemma γ md fm t)
+                           ∘ (FD.fold-reindex-fam γ fm (AM.R.reindex md t)
+                              ∘ prod-m (id _) (AM.R.reindex-fam-W {Q = Q} md {t})))
+                          ≈ FR.freindex-fam (combine-act md fm) {t}
+      combine-lemma-fam {Q = Q} md fm (AM.TX.sup x) = combine-lemma-shape-fam Q Q md fm x
+
+      combine-lemma-shape-fam : ∀ {k} (Q : Poly (suc k)) (R : Poly (suc k)) {ρA ρB ρC} {dA dB dC}
+                                (md : AM.R.MorD ρA ρB dA dB) (fm : FD.FMor ρB ρC dB dC)
+                                (x : AM.TX.⟦ ∣ R ∣ ⟧shape (extend ρA (inj₂ (mkSort ∣ Q ∣ ρA)))) →
+                                FD.TA'.fib-shape-subst R (FD.TA'.deco-ext Q dC)
+                                   (combine-lemma-shape Q R γ md fm x)
+                                 ∘ (FD.fold-reindex-shape-fam γ R (FD.fbind Q fm)
+                                      (AM.R.reindex-shape ∣ R ∣ (AM.R.bind Q md) x)
+                                    ∘ prod-m (id _) (AM.R.reindex-fam R (AM.R.bind Q md) {x}))
+                                ≈ FR.freindex-shape-fam R (FR.abind Q (combine γ md fm) (combine-act md fm)) {x}
+      combine-lemma-shape-fam Q (const A') md fm x =
+        ≈-trans (∘-cong (A' .fam .refl*) ≈-refl)
+          (≈-trans id-left (≈-trans (pair-p₂ _ _) id-left))
+      combine-lemma-shape-fam Q (var Fin.zero) md fm x = combine-lemma-fam md fm x
+      combine-lemma-shape-fam Q (var (Fin.suc v)) {ρC = ρC} md fm x =
+        ≈-trans (∘-cong (FD.TA'.fib-el-refl* (ρC v) _ _) ≈-refl) id-left
+      combine-lemma-shape-fam Q (P + Q') md fm (inj₁ x) = combine-lemma-shape-fam Q P md fm x
+      combine-lemma-shape-fam Q (P + Q') md fm (inj₂ y) = combine-lemma-shape-fam Q Q' md fm y
+      combine-lemma-shape-fam Q (P × Q') md fm (x , y) =
+        ≈-trans (∘-cong ≈-refl (strong-prod-m-pre _ _ _ _ _))
+          (≈-trans (strong-prod-m-post _ _ _ _)
+            (strong-prod-m-cong (combine-lemma-shape-fam Q P md fm x) (combine-lemma-shape-fam Q Q' md fm y)))
+      combine-lemma-shape-fam Q (μ R'') md fm x =
+        ≈-trans (∘-cong (FD.TA'.fib-trans* R'' _
+                           {x = FD.fold-reindex γ (FD.fbind Q fm) (AM.R.reindex (AM.R.bind Q md) x)}
+                           {y = Rcomb.ireindex (combine γ (AM.R.bind Q md) (FD.fbind Q fm)) x}
+                           {z = Rcomb.ireindex (Rcomb.ibind ∣ Q ∣ (combine γ md fm)) x}
+                           (reindex-mcong (rcomb γ Q md fm) x)
+                           (combine-lemma γ (AM.R.bind Q md) (FD.fbind Q fm) x)) ≈-refl)
+          (≈-trans (assoc _ _ _)
+            (≈-trans (∘-cong ≈-refl (combine-lemma-fam (AM.R.bind Q md) (FD.fbind Q fm) x))
+              (reindex-mcong-fam {Q = R''} (rcombA Q md fm) x)))
+
+  -- Correspondence hypothesis for the fuse instances: `combine mor₀ fbase` acts as the fold at the
+  -- recursion slot and as the identity at the parameter slots.
+  corr-fs : ∀ i {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {a₁ a₂} (a≈ : _≈s_ (δ' i .idx) a₁ a₂) →
+            _≈s_ (extend δ A i .idx)
+                 (Rcomb.iapply (combine γ₁ AM.mor₀ FD.fbase) i a₁)
+                 (fs i .idxf .PS._⇒_.func (γ₂ , a₂))
+  corr-fs Fin.zero γ≈ {a₁} {a₂} a≈ = FD.fold-idx-resp γ≈ {a₁} {a₂} a≈
+  corr-fs (Fin.suc j) γ≈ a≈ = a≈
+
+  -- fold-shape-idx ∘ reindex-shape ∘ embed-idx ≈ strong-fmor's idx action of the fold.
+  β-idx : (R : Poly (suc n)) → ∀ {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {m₁ m₂}
+          (m≈ : _≈s_ (fobj μObj R δ' .idx) m₁ m₂) →
+          _≈s_ (fobj μObj R (extend δ A) .idx)
+               (FD.fold-shape-idx R γ₁ (AM.R.reindex-shape ∣ R ∣ AM.mor₀ (AM.embed-idx R m₁)))
+               (strong-fmor R fs .idxf .PS._⇒_.func (γ₂ , m₂))
+  β-idx (const A')        γ≈ m≈ = m≈
+  β-idx (var Fin.zero)    γ≈ {m₁} {m₂} m≈ = FD.fold-idx-resp γ≈ {m₁} {m₂} m≈
+  β-idx (var (Fin.suc j)) γ≈ m≈ = m≈
+  β-idx (Q₁ + Q₂) γ≈ {inj₁ _} {inj₁ _} m≈ = β-idx Q₁ γ≈ m≈
+  β-idx (Q₁ + Q₂) γ≈ {inj₂ _} {inj₂ _} m≈ = β-idx Q₂ γ≈ m≈
+  β-idx (Q₁ × Q₂) γ≈ {_ , _} {_ , _} (m≈₁ , m≈₂) = β-idx Q₁ γ≈ m≈₁ , β-idx Q₂ γ≈ m≈₂
+  β-idx (μ Q') {γ₁} {γ₂} γ≈ {m₁} {m₂} m≈ =
+    FD.TA'.W-≈-trans
+      {x = FD.fold-shape-idx (μ Q') γ₁ (AM.R.reindex-shape ∣ μ Q' ∣ AM.mor₀ (AM.embed-idx (μ Q') m₁))}
+      {y = Rcomb.ireindex (combine γ₁ AM.mor₀ FD.fbase) m₁}
+      {z = strong-fmor (μ Q') fs .idxf .PS._⇒_.func (γ₂ , m₂)}
+      (combine-lemma {Q = Q'} γ₁ AM.mor₀ FD.fbase m₁)
+      (fuse-idx {n = suc n} {Γ = Γ} {sₛ = δ'} {sₜ = extend δ A} Q'
+        (λ γ → combine γ AM.mor₀ FD.fbase) fs corr-fs γ≈ {m₁} {m₂} m≈)
+
+  -- Fibre analogue of `β-idx`: the fibre transformations agree (modulo transport along β-idx).
+  β-fam : (R : Poly (suc n)) → ∀ {γ} {m} →
+          Category._≈_ 𝒞
+            (fobj μObj R (extend δ A) .fam .subst
+               (β-idx R (Γ .idx .isEquivalence .refl) (fobj μObj R δ' .idx .isEquivalence .refl))
+             ∘ (FD.fold-shape-fam R γ (AM.R.reindex-shape ∣ R ∣ AM.mor₀ (AM.embed-idx R m))
+                ∘ prod-m (id _) (AM.R.reindex-fam R AM.mor₀ ∘ AM.embed-fam R m)))
+            (strong-fmor R fs .famf ._⇒f_.transf (γ , m))
+  β-fam (const A') = ≈-trans (∘-cong (A' .fam .refl*) ≈-refl) (≈-trans id-left (≈-trans (∘-cong ≈-refl (≈-trans (prod-m-cong ≈-refl id-left) prod-m-id)) id-right))
+  β-fam (var Fin.zero) = ≈-trans (∘-cong (A .fam .refl*) ≈-refl) (≈-trans id-left (≈-trans (∘-cong ≈-refl (≈-trans (prod-m-cong ≈-refl id-left) prod-m-id)) id-right))
+  β-fam (var (Fin.suc i)) = ≈-trans (∘-cong (δ i .fam .refl*) ≈-refl) (≈-trans id-left (≈-trans (∘-cong ≈-refl (≈-trans (prod-m-cong ≈-refl id-left) prod-m-id)) id-right))
+  β-fam (R₁ + R₂) {m = inj₁ m'} = ≈-trans (β-fam R₁) (≈-sym (≈-trans id-left id-left))
+  β-fam (R₁ + R₂) {m = inj₂ m'} = ≈-trans (β-fam R₂) (≈-sym (≈-trans id-left id-left))
+  β-fam (R₁ × R₂) {m = m₁' , m₂'} =
+    ≈-trans (∘-cong ≈-refl (pair-natural _ _ _))
+      (≈-trans (pair-compose _ _ _ _)
+        (pair-cong
+          (≈-trans (∘-cong ≈-refl
+                     (≈-trans (assoc _ _ _)
+                       (≈-trans (∘-cong ≈-refl
+                                  (≈-trans (∘-cong ≈-refl (prod-m-cong ≈-refl (≈-sym (prod-m-comp _ _ _ _))))
+                                    (strong-p₁-natural (id _) _ _)))
+                         (≈-sym (assoc _ _ _)))))
+            (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong (β-fam R₁) ≈-refl)
+                (≈-trans (∘-cong ≈-refl (pair-cong ≈-refl (≈-sym id-left))) (≈-sym id-left)))))
+          (≈-trans (∘-cong ≈-refl
+                     (≈-trans (assoc _ _ _)
+                       (≈-trans (∘-cong ≈-refl
+                                  (≈-trans (∘-cong ≈-refl (prod-m-cong ≈-refl (≈-sym (prod-m-comp _ _ _ _))))
+                                    (strong-p₂-natural (id _) _ _)))
+                         (≈-sym (assoc _ _ _)))))
+            (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong (β-fam R₂) ≈-refl)
+                (≈-trans (∘-cong ≈-refl (pair-cong ≈-refl (≈-sym id-left))) (≈-sym id-left)))))))
+  β-fam (μ Q') {γ} {m} =
+    ≈-trans (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-cong ≈-refl id-right)))
+      (≈-trans (∘-cong (FD.TA'.fib-trans* Q' _
+                          {x = FD.fold-reindex γ FD.fbase (AM.R.reindex AM.mor₀ m)}
+                          {y = Rcomb.ireindex (combine γ AM.mor₀ FD.fbase) m}
+                          {z = strong-fmor (μ Q') fs .idxf .PS._⇒_.func (γ , m)}
+                          (fuse-idx {n = suc n} {Γ = Γ} {sₛ = δ'} {sₜ = extend δ A} Q'
+                            (λ γ' → combine γ' AM.mor₀ FD.fbase) fs corr-fs
+                            (Γ .idx .isEquivalence .refl) {m} {m}
+                            (μObj Q' δ' .idx .isEquivalence .refl {m}))
+                          (combine-lemma {Q = Q'} γ AM.mor₀ FD.fbase m)) ≈-refl)
+        (≈-trans (assoc _ _ _)
+          (≈-trans (∘-cong ≈-refl (Cγ.combine-lemma-fam {Q = Q'} AM.mor₀ FD.fbase m))
+            (fuse-fam γ Q' (λ γ' → combine γ' AM.mor₀ FD.fbase)
+              (Cγ.combine-act AM.mor₀ FD.fbase) fs corr-fs corr-fs-fam {m}))))
+    where
+      module Cγ = CombineFam γ
+      corr-fs-fam : ∀ i {a} →
+                    (extend δ A i .fam .subst
+                       (corr-fs i (Γ .idx .isEquivalence .refl) (δ' i .idx .isEquivalence .refl {a}))
+                     ∘ Cγ.FR.aapply (Cγ.combine-act AM.mor₀ FD.fbase) i a)
+                    ≈ (fs i .famf ._⇒f_.transf (γ , a))
+      corr-fs-fam Fin.zero {a} =
+        ≈-trans (∘-cong (A .fam .refl*) ≈-refl)
+          (≈-trans id-left (≈-trans (∘-cong ≈-refl prod-m-id) id-right))
+      corr-fs-fam (Fin.suc j) {a} =
+        ≈-trans (∘-cong (δ j .fam .refl*) ≈-refl)
+          (≈-trans id-left (≈-trans (∘-cong ≈-refl prod-m-id) id-right))
+
+-- η/uniqueness machinery: any h satisfying the β square agrees with the fold, pointwise by tree induction.
+-- Nested-μ case collapses h's strong action to an index-only reindex (`cmb-hs`, via fuse-idx) and telescopes
+-- it against the fold.
+module EtaDef {n} {Γ A : Obj} {P : Poly (suc n)} {δ : Fin n → Obj}
+              (alg : Mor (Fam𝒞-P.prod Γ (fobj μObj P (extend δ A))) A)
+              (h : Mor (Fam𝒞-P.prod Γ (μObj P δ)) A)
+              (eq : Fam𝒞._≈_
+                      (Fam𝒞._∘_ h (Fam𝒞-P.pair Fam𝒞-P.p₁ (Fam𝒞._∘_ (InMapDef.inMor P δ) Fam𝒞-P.p₂)))
+                      (Fam𝒞._∘_ alg (Fam𝒞-P.pair Fam𝒞-P.p₁
+                        (HasMu.strong-fmor hasMu P (HasMu.strong-extend-mor hasMu (λ i → Fam𝒞-P.p₂) h))))) where
+  open HasMu hasMu using (strong-fmor; strong-extend-mor)
+  module AM = InMapDef P δ
+  module FD = FoldDef {Γ = Γ} {A = A} {P = P} {δ = δ} alg
+  δ' = extend δ (μObj P δ)
+  hs : ∀ i → Mor (Fam𝒞-P.prod Γ (δ' i)) (extend δ A i)
+  hs = strong-extend-mor (λ i → Fam𝒞-P.p₂) h
+
+  -- Context shift δ → δ': the μ-binder slot of the body environment is exactly the
+  -- fresh δ' slot (identity on indices and fibres).
+  module Rδ = Reindex δ δ'
+
+  mor₀δ : Rδ.MorD (Sh.η₀ ∣ P ∣) (λ v → inj₁ v)
+                  (FD.Tδ.deco-ext P {ρ̄ = λ i → inj₁ i} (λ i → lift tt)) (λ v → lift tt)
+  mor₀δ = Rδ.base (λ { Fin.zero a → a ; (Fin.suc i) a → a })
+                  (λ { Fin.zero p → p ; (Fin.suc i) p → p })
+                  (λ { Fin.zero a → id _ ; (Fin.suc i) a → id _ })
+                  (λ { Fin.zero p → ≈-trans id-left (≈-sym id-right)
+                     ; (Fin.suc i) p → ≈-trans id-left (≈-sym id-right) })
+
+  -- Shift a shape over the μ-binder environment into `fobj`'s native form over δ'.
+  shift : (R : Poly (suc n)) → FD.Tδ.⟦ ∣ R ∣ ⟧shape (Sh.η₀ ∣ P ∣) → fobj μObj R δ' .idx .Carrier
+  shift R x = AM.unembed-idx R (Rδ.reindex-shape ∣ R ∣ mor₀δ x)
+
+  shift-resp : (R : Poly (suc n)) {x y : FD.Tδ.⟦ ∣ R ∣ ⟧shape (Sh.η₀ ∣ P ∣)} →
+               FD.Tδ.shape≈ ∣ R ∣ (Sh.η₀ ∣ P ∣) x y → _≈s_ (fobj μObj R δ' .idx) (shift R x) (shift R y)
+  shift-resp R p = AM.unembed-idx-resp R (Rδ.reindex-shape-resp ∣ R ∣ mor₀δ p)
+
+  -- Round trip: shifting into δ' and reindexing back along mor₀ is the identity,
+  -- on indices and fibres.
+  mutual
+    data RT : ∀ {j} {ρD : Fin j → Fin n ⊎ Sort n} {ρX : Fin j → Fin (suc n) ⊎ Sort (suc n)}
+              {dD : ∀ v → FD.Tδ.DecoAssign (ρD v)} {dX : ∀ v → AM.TX.DecoAssign (ρX v)} →
+              Rδ.MorD ρD ρX dD dX → AM.R.MorD ρX ρD dX dD → Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+      rtbase : RT mor₀δ AM.mor₀
+      rtbind : ∀ {j} {ρD ρX dD dX} {md : Rδ.MorD {j} ρD ρX dD dX} {md' : AM.R.MorD ρX ρD dX dD} (Q : Poly (suc j)) →
+               RT md md' → RT (Rδ.bind Q md) (AM.R.bind Q md')
+
+    rt-shape : ∀ {j} (S : Poly j) {ρD ρX dD dX} {md : Rδ.MorD ρD ρX dD dX} {md' : AM.R.MorD ρX ρD dX dD}
+               (rt : RT md md') (z : FD.Tδ.⟦ ∣ S ∣ ⟧shape ρD) →
+               FD.Tδ.shape≈ ∣ S ∣ ρD (AM.R.reindex-shape ∣ S ∣ md' (Rδ.reindex-shape ∣ S ∣ md z)) z
+    rt-shape (const A') rt z = A' .idx .isEquivalence .refl
+    rt-shape (var v) rt z = rt-apply rt v
+    rt-shape (S₁ + S₂) rt (inj₁ z) = rt-shape S₁ rt z
+    rt-shape (S₁ + S₂) rt (inj₂ z) = rt-shape S₂ rt z
+    rt-shape (S₁ × S₂) rt (z₁ , z₂) = rt-shape S₁ rt z₁ , rt-shape S₂ rt z₂
+    rt-shape (μ S') rt (FD.Tδ.sup z) = rt-shape S' (rtbind S' rt) z
+
+    rt-apply : ∀ {j} {ρD ρX dD dX} {md : Rδ.MorD {j} ρD ρX dD dX} {md' : AM.R.MorD ρX ρD dX dD}
+               (rt : RT md md') (v : Fin j) {z} → FD.Tδ.elEq (ρD v) (AM.R.apply md' v (Rδ.apply md v z)) z
+    rt-apply rtbase Fin.zero {z} = FD.Tδ.W-≈-refl z
+    rt-apply rtbase (Fin.suc i) {z} = δ i .idx .isEquivalence .refl
+    rt-apply (rtbind S' rt) Fin.zero {z} = rt-shape (μ S') rt z
+    rt-apply (rtbind S' rt) (Fin.suc v) = rt-apply rt v
+
+    rtf-shape : ∀ {j} (S : Poly j) {ρD ρX dD dX} {md : Rδ.MorD ρD ρX dD dX} {md' : AM.R.MorD ρX ρD dX dD}
+                (rt : RT md md') (z : FD.Tδ.⟦ ∣ S ∣ ⟧shape ρD) →
+                FD.Tδ.fib-shape-subst S dD (rt-shape S rt z)
+                 ∘ (AM.R.reindex-fam S md' {Rδ.reindex-shape ∣ S ∣ md z} ∘ Rδ.reindex-fam S md {z}) ≈ id _
+    rtf-shape (const A') rt z =
+      ≈-trans (∘-cong (A' .fam .refl*) ≈-refl) (≈-trans id-left id-left)
+    rtf-shape (var v) rt z = rtf-apply rt v
+    rtf-shape (S₁ + S₂) rt (inj₁ z) = rtf-shape S₁ rt z
+    rtf-shape (S₁ + S₂) rt (inj₂ z) = rtf-shape S₂ rt z
+    rtf-shape (S₁ × S₂) rt (z₁ , z₂) =
+      ≈-trans (∘-cong ≈-refl (≈-sym (prod-m-comp _ _ _ _)))
+        (≈-trans (≈-sym (prod-m-comp _ _ _ _))
+          (≈-trans (prod-m-cong (rtf-shape S₁ rt z₁) (rtf-shape S₂ rt z₂)) prod-m-id))
+    rtf-shape (μ S') rt (FD.Tδ.sup z) = rtf-shape S' (rtbind S' rt) z
+
+    rtf-apply : ∀ {j} {ρD ρX dD dX} {md : Rδ.MorD {j} ρD ρX dD dX} {md' : AM.R.MorD ρX ρD dX dD}
+                (rt : RT md md') (v : Fin j) {z} →
+                FD.Tδ.fib-el-subst (ρD v) (dD v) (rt-apply rt v {z})
+                 ∘ (AM.R.apply-fam md' v (Rδ.apply md v z) ∘ Rδ.apply-fam md v z) ≈ id _
+    rtf-apply rtbase Fin.zero {z} =
+      ≈-trans (∘-cong (FD.Tδ.fib-refl* P _ z) ≈-refl) (≈-trans id-left id-left)
+    rtf-apply rtbase (Fin.suc i) {z} =
+      ≈-trans (∘-cong (δ i .fam .refl*) ≈-refl) (≈-trans id-left id-left)
+    rtf-apply (rtbind S' rt) Fin.zero {z} = rtf-shape (μ S') rt z
+    rtf-apply (rtbind S' rt) (Fin.suc v) = rtf-apply rt v
+
+  -- inMap reconstructs the shifted shape.
+  roundtrip : (x : FD.Tδ.⟦ ∣ P ∣ ⟧shape (Sh.η₀ ∣ P ∣)) →
+              FD.Tδ.W-≈ (AM.inMor .idxf .PS._⇒_.func (shift P x)) (FD.Tδ.sup x)
+  roundtrip x =
+    FD.Tδ.shape≈-trans ∣ P ∣ (Sh.η₀ ∣ P ∣)
+      (AM.R.reindex-shape-resp ∣ P ∣ AM.mor₀ (AM.embed-unembed P (Rδ.reindex-shape ∣ P ∣ mor₀δ x))) (rt-shape P rtbase x)
+
+  shift-fam : (R : Poly (suc n)) (x : FD.Tδ.⟦ ∣ R ∣ ⟧shape (Sh.η₀ ∣ P ∣)) →
+              FD.Tδ.fib-shape R (FD.Tδ.deco-ext P (λ i → lift tt)) x ⇒ fobj μObj R δ' .fam .fm (shift R x)
+  shift-fam R x = AM.unembed-fam R (Rδ.reindex-shape ∣ R ∣ mor₀δ x) ∘ Rδ.reindex-fam R mor₀δ {x}
+
+  roundtrip-fam : (x : FD.Tδ.⟦ ∣ P ∣ ⟧shape (Sh.η₀ ∣ P ∣)) →
+                  μObj P δ .fam .subst (roundtrip x) ∘ (AM.inMor .famf ._⇒f_.transf (shift P x) ∘ shift-fam P x) ≈ id _
+  roundtrip-fam x =
+    ≈-trans (∘-cong (FD.Tδ.fib-shape-trans* P _
+                       (rt-shape P rtbase x)
+                       (AM.R.reindex-shape-resp ∣ P ∣ AM.mor₀ (AM.embed-unembed P y'))) ≈-refl)
+      (≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong ≈-refl
+                   (≈-trans (∘-cong ≈-refl (assoc _ _ _))
+                     (≈-trans (≈-sym (assoc _ _ _))
+                       (≈-trans (∘-cong (≈-sym (AM.R.reindex-fam-natural P AM.mor₀
+                                                 (AM.embed-unembed P y'))) ≈-refl)
+                         (≈-trans (assoc _ _ _)
+                           (∘-cong ≈-refl
+                             (≈-trans (∘-cong ≈-refl (≈-sym (assoc _ _ _)))
+                               (≈-trans (≈-sym (assoc _ _ _))
+                                 (≈-trans (∘-cong (AM.embed-unembed-fam P y') ≈-refl) id-left)))))))))
+          (rtf-shape P rtbase x)))
+    where y' = Rδ.reindex-shape ∣ P ∣ mor₀δ x
+
+  -- Transport along the inverted round trip is α's fibre action after the shift.
+  shift-subst : (x : FD.Tδ.⟦ ∣ P ∣ ⟧shape (Sh.η₀ ∣ P ∣)) →
+                μObj P δ .fam .subst
+                  (FD.Tδ.W-≈-sym {x = AM.inMor .idxf .PS._⇒_.func (shift P x)} {y = FD.Tδ.sup x}
+                    (roundtrip x))
+                ≈ AM.inMor .famf ._⇒f_.transf (shift P x) ∘ shift-fam P x
+  shift-subst x =
+    ≈-trans (≈-sym id-right)
+      (≈-trans (∘-cong ≈-refl (≈-sym (roundtrip-fam x)))
+        (≈-trans (≈-sym (assoc _ _ _))
+          (≈-trans (∘-cong (≈-trans (≈-sym (μObj P δ .fam .trans*
+                                              (FD.Tδ.W-≈-sym {x = AM.inMor .idxf .PS._⇒_.func (shift P x)}
+                                                             {y = FD.Tδ.sup x} (roundtrip x))
+                                              (roundtrip x)))
+                             (μObj P δ .fam .refl*)) ≈-refl)
+            id-left)))
+
+  -- h's strong action collapsed to an index-only reindex, and its fuse-idx hypothesis.
+  module Rcomb = Reindex δ' (extend δ A)
+  cmb-hs : Γ .idx .Carrier → Rcomb.IMorD (λ v → inj₁ v) (λ v → inj₁ v)
+  cmb-hs γ = Rcomb.ibase (λ { Fin.zero a → h .idxf .PS._⇒_.func (γ , a) ; (Fin.suc i) a → a })
+                         (λ { Fin.zero p → h .idxf .PS._⇒_.func-resp-≈ (Γ .idx .isEquivalence .refl , p)
+                            ; (Fin.suc i) p → p })
+
+  corr-hs : ∀ i {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {a₁ a₂} (a≈ : _≈s_ (δ' i .idx) a₁ a₂) →
+            _≈s_ (extend δ A i .idx) (Rcomb.iapply (cmb-hs γ₁) i a₁) (hs i .idxf .PS._⇒_.func (γ₂ , a₂))
+  corr-hs Fin.zero γ≈ a≈ = h .idxf .PS._⇒_.func-resp-≈ (γ≈ , a≈)
+  corr-hs (Fin.suc j) γ≈ a≈ = a≈
+
+  mutual
+    -- h agrees with the fold, pointwise. At sup, round-trip through α's reconstruction so the β square
+    -- `eq` applies, then push through the shape.
+    η-idx : ∀ {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {t₁ t₂ : FD.Tδ.W ∣ P ∣ (λ i → inj₁ i)}
+            (t≈ : FD.Tδ.W-≈ t₁ t₂) → _≈s_ (A .idx) (h .idxf .PS._⇒_.func (γ₁ , t₁)) (FD.fold-idx γ₂ t₂)
+    η-idx {γ₁} {γ₂} γ≈ {FD.Tδ.sup x₁} {FD.Tδ.sup x₂} t≈ =
+      A .idx .isEquivalence .trans
+        (h .idxf .PS._⇒_.func-resp-≈
+          (Γ .idx .isEquivalence .refl {γ₁} ,
+           FD.Tδ.W-≈-sym
+             {x = AM.inMor .idxf .PS._⇒_.func (shift P x₁)} {y = FD.Tδ.sup x₁}
+             (roundtrip x₁)))
+        (A .idx .isEquivalence .trans
+          (eq ._≃_.idxf-eq .PS._≃m_.func-eq (γ≈ , shift-resp P t≈))
+          (alg .idxf .PS._⇒_.func-resp-≈ (Γ .idx .isEquivalence .refl {γ₂} , η-shape P γ₂ x₂)))
+
+    -- h's strong action at the unembedded shift agrees with the fold's shape action.
+    η-shape : (R : Poly (suc n)) (γ : Γ .idx .Carrier) (x : FD.Tδ.⟦ ∣ R ∣ ⟧shape (Sh.η₀ ∣ P ∣)) →
+              _≈s_ (fobj μObj R (extend δ A) .idx)
+                   (strong-fmor R hs .idxf .PS._⇒_.func (γ , shift R x))
+                   (FD.fold-shape-idx R γ x)
+    η-shape (const A') γ x = A' .idx .isEquivalence .refl
+    η-shape (var Fin.zero) γ x = η-idx (Γ .idx .isEquivalence .refl {γ}) (FD.Tδ.W-≈-refl x)
+    η-shape (var (Fin.suc j)) γ x = δ j .idx .isEquivalence .refl
+    η-shape (R₁ + R₂) γ (inj₁ x) = η-shape R₁ γ x
+    η-shape (R₁ + R₂) γ (inj₂ y) = η-shape R₂ γ y
+    η-shape (R₁ × R₂) γ (x , y) = η-shape R₁ γ x , η-shape R₂ γ y
+    η-shape (μ Q') γ x =
+      FD.TA'.W-≈-trans
+        {x = strong-fmor (μ Q') hs .idxf .PS._⇒_.func (γ , Rδ.reindex mor₀δ x)}
+        {y = Rcomb.ireindex (cmb-hs γ) (Rδ.reindex mor₀δ x)}
+        {z = FD.fold-reindex {Q = Q'} γ FD.fbase x}
+        (FD.TA'.W-≈-sym
+          {x = Rcomb.ireindex (cmb-hs γ) (Rδ.reindex mor₀δ x)}
+          {y = strong-fmor (μ Q') hs .idxf .PS._⇒_.func (γ , Rδ.reindex mor₀δ x)}
+          (fuse-idx {n = suc n} {Γ = Γ} {sₛ = δ'} {sₜ = extend δ A} Q' cmb-hs hs corr-hs
+            (Γ .idx .isEquivalence .refl {γ}) {Rδ.reindex mor₀δ x} {Rδ.reindex mor₀δ x}
+            (μObj Q' δ' .idx .isEquivalence .refl {Rδ.reindex mor₀δ x})))
+        (htele-shape (μ Q') hbase x)
+      where
+      mutual
+        -- Telescope: reindexing by h after the context shift is the fold's reindex,  by the outer induction
+        -- at the recursion slots.
+        data HRel : ∀ {j} {ρD : Fin j → Fin n ⊎ Sort n} {ρX ρC : Fin j → Fin (suc n) ⊎ Sort (suc n)}
+                    {dD : ∀ v → FD.Tδ.DecoAssign (ρD v)} {dX : ∀ v → AM.TX.DecoAssign (ρX v)}
+                    {dC : ∀ v → FD.TA'.DecoAssign (ρC v)} →
+                    Rδ.MorD ρD ρX dD dX → Rcomb.IMorD ρX ρC → FD.FMor ρD ρC dD dC →
+                    Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+          hbase : HRel mor₀δ (cmb-hs γ) FD.fbase
+          hbind : ∀ {j} {ρD ρX ρC dD dX dC} {md : Rδ.MorD {j} ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                  {fm : FD.FMor ρD ρC dD dC} (S' : Poly (suc j)) → HRel md mdc fm →
+                  HRel (Rδ.bind S' md) (Rcomb.ibind ∣ S' ∣ mdc) (FD.fbind S' fm)
+
+        htele-shape : ∀ {j} (S : Poly j) {ρD ρX ρC dD dX dC} {md : Rδ.MorD ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                      {fm : FD.FMor ρD ρC dD dC} (rel : HRel md mdc fm) (z : FD.Tδ.⟦ ∣ S ∣ ⟧shape ρD) →
+                      FD.TA'.shape≈ ∣ S ∣ ρC (Rcomb.ireindex-shape ∣ S ∣ mdc (Rδ.reindex-shape ∣ S ∣ md z))
+                        (FD.fold-reindex-shape γ S fm z)
+        htele-shape (const A') rel z = A' .idx .isEquivalence .refl
+        htele-shape (var v) rel z = htele-apply rel v
+        htele-shape (S₁ + S₂) rel (inj₁ z) = htele-shape S₁ rel z
+        htele-shape (S₁ + S₂) rel (inj₂ z) = htele-shape S₂ rel z
+        htele-shape (S₁ × S₂) rel (z₁ , z₂) = htele-shape S₁ rel z₁ , htele-shape S₂ rel z₂
+        htele-shape (μ S') rel (FD.Tδ.sup z) = htele-shape S' (hbind S' rel) z
+
+        htele-apply : ∀ {j} {ρD ρX ρC dD dX dC} {md : Rδ.MorD {j} ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                      {fm : FD.FMor ρD ρC dD dC} (rel : HRel md mdc fm) (v : Fin j) {z} →
+                      FD.TA'.elEq (ρC v) (Rcomb.iapply mdc v (Rδ.apply md v z)) (FD.fold-apply γ fm v z)
+        htele-apply hbase Fin.zero {z} = η-idx (Γ .idx .isEquivalence .refl {γ}) (FD.Tδ.W-≈-refl z)
+        htele-apply hbase (Fin.suc i) {z} = δ i .idx .isEquivalence .refl
+        htele-apply (hbind S' rel) Fin.zero {z} = htele-shape (μ S') rel z
+        htele-apply (hbind S' rel) (Fin.suc v) = htele-apply rel v
+
+  -- Fibre side, at a fixed γ: h's fibre action agrees with the fold's, transported
+  -- along the pointwise index agreement.
+  module EtaFam (γ : Γ .idx .Carrier) where
+    module FR = FReindex {δA = δ'} {δB = extend δ A} (Γ .fam .fm γ)
+
+    act-hs : FR.FAct (cmb-hs γ) (λ v → lift tt) (λ v → lift tt)
+    act-hs = FR.abase (λ { Fin.zero a → h .famf ._⇒f_.transf (γ , a) ; (Fin.suc i) a → p₂ })
+
+    corr-hs-fam : ∀ i {a} →
+                  extend δ A i .fam .subst
+                     (corr-hs i (Γ .idx .isEquivalence .refl) (δ' i .idx .isEquivalence .refl {a}))
+                   ∘ FR.aapply act-hs i a ≈
+                  hs i .famf ._⇒f_.transf (γ , a)
+    corr-hs-fam Fin.zero {a} = ≈-trans (∘-cong (A .fam .refl*) ≈-refl) id-left
+    corr-hs-fam (Fin.suc j) {a} = ≈-trans (∘-cong (δ j .fam .refl*) ≈-refl) id-left
+
+    mutual
+      η-fam : (t : FD.Tδ.W ∣ P ∣ (λ i → inj₁ i)) →
+              A .fam .subst (η-idx (Γ .idx .isEquivalence .refl {γ}) {t} {t} (FD.Tδ.W-≈-refl t))
+               ∘ h .famf ._⇒f_.transf (γ , t)
+              ≈ FD.fold-fam γ t
+      η-fam (FD.Tδ.sup x) =
+        ≈-trans (∘-cong (A .fam .trans* q₂₃ q₁) ≈-refl)
+          (≈-trans (assoc _ _ _)
+            (≈-trans (∘-cong ≈-refl (≈-sym (h .famf ._⇒f_.natural
+                                             (Γ .idx .isEquivalence .refl {γ} , rt⁻))))
+              (≈-trans (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-cong (Γ .fam .refl*) (shift-subst x))))
+                (≈-trans (∘-cong ≈-refl (∘-cong ≈-refl pairT-intro))
+                  (≈-trans (∘-cong ≈-refl (≈-sym (assoc _ _ _)))
+                    (≈-trans (≈-sym (assoc _ _ _))
+                      (≈-trans (∘-cong (∘-cong (A .fam .trans* q₃ q₂) ≈-refl) ≈-refl)
+                        (≈-trans (∘-cong (assoc _ _ _) ≈-refl)
+                          (≈-trans (∘-cong (∘-cong ≈-refl eq-step) ≈-refl)
+                            (≈-trans (∘-cong (≈-trans (≈-sym (assoc _ _ _))
+                                               (≈-trans (∘-cong (≈-sym (alg .famf ._⇒f_.natural
+                                                                         (Γ .idx .isEquivalence .refl {γ} ,
+                                                                          η-shape P γ x))) ≈-refl)
+                                                 (assoc _ _ _))) ≈-refl)
+                              (≈-trans (assoc _ _ _)
+                                (∘-cong ≈-refl
+                                  (≈-trans (∘-cong (pair-compose _ _ _ _) ≈-refl)
+                                    (≈-trans (pair-natural _ _ _)
+                                      (pair-cong
+                                        (≈-trans (∘-cong (≈-trans (∘-cong (Γ .fam .refl*) ≈-refl) id-left) ≈-refl)
+                                          (≈-trans (pair-p₁ _ _) id-left))
+                                        (≈-trans (assoc _ _ _) (η-shape-fam P x)))))))))))))))))
+        where
+        rt⁻ = FD.Tδ.W-≈-sym {x = AM.inMor .idxf .PS._⇒_.func (shift P x)} {y = FD.Tδ.sup x} (roundtrip x)
+        q₁ = h .idxf .PS._⇒_.func-resp-≈ (Γ .idx .isEquivalence .refl {γ} , rt⁻)
+        q₂ = eq ._≃_.idxf-eq .PS._≃m_.func-eq
+               (Γ .idx .isEquivalence .refl {γ} , shift-resp P (FD.Tδ.shape≈-refl ∣ P ∣ (Sh.η₀ ∣ P ∣) x))
+        q₃ = alg .idxf .PS._⇒_.func-resp-≈ (Γ .idx .isEquivalence .refl {γ} , η-shape P γ x)
+        q₂₃ = A .idx .isEquivalence .trans q₂ q₃
+
+        eq-step : A .fam .subst q₂ ∘ (h .famf ._⇒f_.transf (γ , AM.inMor .idxf .PS._⇒_.func (shift P x))
+                                        ∘ pair p₁ (id _ ∘ (AM.inMor .famf ._⇒f_.transf (shift P x) ∘ p₂))) ≈
+                  alg .famf ._⇒f_.transf (γ , strong-fmor P hs .idxf .PS._⇒_.func (γ , shift P x))
+                     ∘ pair p₁ (strong-fmor P hs .famf ._⇒f_.transf (γ , shift P x))
+        eq-step =
+          ≈-trans (∘-cong ≈-refl (≈-sym id-left))
+            (≈-trans (eq ._≃_.famf-eq .indexed-family._≃f_.transf-eq {γ , shift P x}) id-left)
+
+        pairT-intro : prod-m (id _) (AM.inMor .famf ._⇒f_.transf (shift P x) ∘ shift-fam P x)
+                      ≈ (pair p₁ (id _ ∘ (AM.inMor .famf ._⇒f_.transf (shift P x) ∘ p₂))
+                         ∘ prod-m (id _) (shift-fam P x))
+        pairT-intro =
+          ≈-sym (≈-trans (pair-natural _ _ _)
+            (pair-cong (pair-p₁ _ _)
+              (≈-trans (∘-cong id-left ≈-refl)
+                (≈-trans (assoc _ _ _)
+                  (≈-trans (∘-cong ≈-refl (pair-p₂ _ _)) (≈-sym (assoc _ _ _)))))))
+
+      η-shape-fam : (R : Poly (suc n)) (x : FD.Tδ.⟦ ∣ R ∣ ⟧shape (Sh.η₀ ∣ P ∣)) →
+                    fobj μObj R (extend δ A) .fam .subst (η-shape R γ x)
+                     ∘ (strong-fmor R hs .famf ._⇒f_.transf (γ , shift R x) ∘ prod-m (id _) (shift-fam R x)) ≈
+                    FD.fold-shape-fam R γ x
+      η-shape-fam (const A') x =
+        ≈-trans (∘-cong (A' .fam .refl*) ≈-refl)
+          (≈-trans id-left (≈-trans (∘-cong ≈-refl (≈-trans (prod-m-cong ≈-refl id-left) prod-m-id)) id-right))
+      η-shape-fam (var Fin.zero) x =
+        ≈-trans (∘-cong ≈-refl (≈-trans (∘-cong ≈-refl (≈-trans (prod-m-cong ≈-refl id-left) prod-m-id)) id-right))
+          (η-fam x)
+      η-shape-fam (var (Fin.suc j)) x =
+        ≈-trans (∘-cong (δ j .fam .refl*) ≈-refl)
+          (≈-trans id-left (≈-trans (∘-cong ≈-refl (≈-trans (prod-m-cong ≈-refl id-left) prod-m-id)) id-right))
+      η-shape-fam (R₁ + R₂) (inj₁ x) =
+        ≈-trans (∘-cong ≈-refl (∘-cong (≈-trans id-left id-left) ≈-refl)) (η-shape-fam R₁ x)
+      η-shape-fam (R₁ + R₂) (inj₂ y) =
+        ≈-trans (∘-cong ≈-refl (∘-cong (≈-trans id-left id-left) ≈-refl)) (η-shape-fam R₂ y)
+      η-shape-fam (R₁ × R₂) (x , y) =
+        ≈-trans (∘-cong ≈-refl
+                   (∘-cong (pair-cong (≈-trans id-left (∘-cong ≈-refl (pair-cong ≈-refl id-left)))
+                                      (≈-trans id-left (∘-cong ≈-refl (pair-cong ≈-refl id-left))))
+                           (prod-m-cong ≈-refl (≈-sym (prod-m-comp _ _ _ _)))))
+          (≈-trans (∘-cong ≈-refl (strong-prod-m-pre _ _ _ _ _))
+            (≈-trans (strong-prod-m-post _ _ _ _)
+              (strong-prod-m-cong (η-shape-fam R₁ x) (η-shape-fam R₂ y))))
+      η-shape-fam (μ Q') x =
+        ≈-trans (∘-cong (FD.TA'.fib-trans* Q' _
+                           {x = strong-fmor (μ Q') hs .idxf .PS._⇒_.func (γ , m')}
+                           {y = Rcomb.ireindex (cmb-hs γ) m'}
+                           {z = FD.fold-reindex {Q = Q'} γ FD.fbase x}
+                           (htele-shape' (μ Q') hbase' x)
+                           sym-fuse) ≈-refl)
+          (≈-trans (assoc _ _ _)
+            (≈-trans (∘-cong ≈-refl
+                       (≈-trans (∘-cong ≈-refl (∘-cong ≈-refl (prod-m-cong ≈-refl id-left)))
+                         (≈-trans (≈-sym (assoc _ _ _)) (∘-cong fuse-inv ≈-refl))))
+              (htelef-shape (μ Q') hbase' x)))
+        where
+        m' = Rδ.reindex mor₀δ x
+        fuse-pf = fuse-idx {n = suc n} {Γ = Γ} {sₛ = δ'} {sₜ = extend δ A} Q' cmb-hs hs corr-hs
+                    (Γ .idx .isEquivalence .refl {γ}) {m'} {m'}
+                    (μObj Q' δ' .idx .isEquivalence .refl {m'})
+        sym-fuse = FD.TA'.W-≈-sym
+                     {x = Rcomb.ireindex (cmb-hs γ) m'}
+                     {y = strong-fmor (μ Q') hs .idxf .PS._⇒_.func (γ , m')} fuse-pf
+
+        fuse-inv : μObj Q' (extend δ A) .fam .subst
+                      {x = strong-fmor (μ Q') hs .idxf .PS._⇒_.func (γ , m')}
+                      {y = Rcomb.ireindex (cmb-hs γ) m'} sym-fuse
+                    ∘ strong-fmor (μ Q') hs .famf ._⇒f_.transf (γ , m') ≈ FR.freindex-fam act-hs {m'}
+        fuse-inv =
+          ≈-trans (∘-cong ≈-refl (≈-sym (fuse-fam γ Q' cmb-hs act-hs hs corr-hs corr-hs-fam {m'})))
+            (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong (≈-trans (≈-sym (μObj Q' (extend δ A) .fam .trans*
+                                                 {x = Rcomb.ireindex (cmb-hs γ) m'}
+                                                 {y = strong-fmor (μ Q') hs .idxf .PS._⇒_.func (γ , m')}
+                                                 {z = Rcomb.ireindex (cmb-hs γ) m'}
+                                                 sym-fuse fuse-pf))
+                                  (μObj Q' (extend δ A) .fam .refl* {Rcomb.ireindex (cmb-hs γ) m'})) ≈-refl)
+                id-left))
+
+        mutual
+          -- Telescope with the fibre action carried alongside, mirroring the index telescope in η-shape's
+          -- μ case clause by clause.
+          data HRel' : ∀ {j} {ρD : Fin j → Fin n ⊎ Sort n} {ρX ρC : Fin j → Fin (suc n) ⊎ Sort (suc n)}
+                       {dD : ∀ v → FD.Tδ.DecoAssign (ρD v)} {dX : ∀ v → AM.TX.DecoAssign (ρX v)}
+                       {dC : ∀ v → FD.TA'.DecoAssign (ρC v)} →
+                       Rδ.MorD ρD ρX dD dX → (mdc : Rcomb.IMorD ρX ρC) → FD.FMor ρD ρC dD dC →
+                       FR.FAct mdc dX dC → Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+            hbase' : HRel' mor₀δ (cmb-hs γ) FD.fbase act-hs
+            hbind' : ∀ {j} {ρD ρX ρC dD dX dC} {md : Rδ.MorD {j} ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                     {fm : FD.FMor ρD ρC dD dC} {am : FR.FAct mdc dX dC} (S' : Poly (suc j)) →
+                     HRel' md mdc fm am →
+                     HRel' (Rδ.bind S' md) (Rcomb.ibind ∣ S' ∣ mdc) (FD.fbind S' fm) (FR.abind S' mdc am)
+
+          htele-shape' : ∀ {j} (S : Poly j) {ρD ρX ρC dD dX dC} {md : Rδ.MorD ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                         {fm : FD.FMor ρD ρC dD dC} {am : FR.FAct mdc dX dC}
+                         (rel : HRel' md mdc fm am) (z : FD.Tδ.⟦ ∣ S ∣ ⟧shape ρD) →
+                         FD.TA'.shape≈ ∣ S ∣ ρC (Rcomb.ireindex-shape ∣ S ∣ mdc (Rδ.reindex-shape ∣ S ∣ md z))
+                           (FD.fold-reindex-shape γ S fm z)
+          htele-shape' (const A') rel z = A' .idx .isEquivalence .refl
+          htele-shape' (var v) rel z = htele-apply' rel v
+          htele-shape' (S₁ + S₂) rel (inj₁ z) = htele-shape' S₁ rel z
+          htele-shape' (S₁ + S₂) rel (inj₂ z) = htele-shape' S₂ rel z
+          htele-shape' (S₁ × S₂) rel (z₁ , z₂) = htele-shape' S₁ rel z₁ , htele-shape' S₂ rel z₂
+          htele-shape' (μ S') rel (FD.Tδ.sup z) = htele-shape' S' (hbind' S' rel) z
+
+          htele-apply' : ∀ {j} {ρD ρX ρC dD dX dC} {md : Rδ.MorD {j} ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                         {fm : FD.FMor ρD ρC dD dC} {am : FR.FAct mdc dX dC}
+                         (rel : HRel' md mdc fm am) (v : Fin j) {z} →
+                         FD.TA'.elEq (ρC v) (Rcomb.iapply mdc v (Rδ.apply md v z)) (FD.fold-apply γ fm v z)
+          htele-apply' hbase' Fin.zero {z} = η-idx (Γ .idx .isEquivalence .refl {γ}) (FD.Tδ.W-≈-refl z)
+          htele-apply' hbase' (Fin.suc i) {z} = δ i .idx .isEquivalence .refl
+          htele-apply' (hbind' S' rel) Fin.zero {z} = htele-shape' (μ S') rel z
+          htele-apply' (hbind' S' rel) (Fin.suc v) = htele-apply' rel v
+
+          htelef-shape : ∀ {j} (S : Poly j) {ρD ρX ρC dD dX dC} {md : Rδ.MorD ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                         {fm : FD.FMor ρD ρC dD dC} {am : FR.FAct mdc dX dC}
+                         (rel : HRel' md mdc fm am) (z : FD.Tδ.⟦ ∣ S ∣ ⟧shape ρD) →
+                         FD.TA'.fib-shape-subst S dC (htele-shape' S rel z)
+                          ∘ (FR.freindex-shape-fam S am {Rδ.reindex-shape ∣ S ∣ md z}
+                             ∘ prod-m (id _) (Rδ.reindex-fam S md {z})) ≈
+                         FD.fold-reindex-shape-fam γ S fm z
+          htelef-shape (const A') rel z =
+            ≈-trans (∘-cong (A' .fam .refl*) ≈-refl)
+              (≈-trans id-left (≈-trans (pair-p₂ _ _) id-left))
+          htelef-shape (var v) rel z = htelef-apply rel v
+          htelef-shape (S₁ + S₂) rel (inj₁ z) = htelef-shape S₁ rel z
+          htelef-shape (S₁ + S₂) rel (inj₂ z) = htelef-shape S₂ rel z
+          htelef-shape (S₁ × S₂) rel (z₁ , z₂) =
+            ≈-trans (∘-cong ≈-refl (strong-prod-m-pre _ _ _ _ _))
+              (≈-trans (strong-prod-m-post _ _ _ _)
+                (strong-prod-m-cong (htelef-shape S₁ rel z₁) (htelef-shape S₂ rel z₂)))
+          htelef-shape (μ S') rel (FD.Tδ.sup z) = htelef-shape S' (hbind' S' rel) z
+
+          htelef-apply : ∀ {j} {ρD ρX ρC dD dX dC} {md : Rδ.MorD {j} ρD ρX dD dX} {mdc : Rcomb.IMorD ρX ρC}
+                         {fm : FD.FMor ρD ρC dD dC} {am : FR.FAct mdc dX dC}
+                         (rel : HRel' md mdc fm am) (v : Fin j) {z} →
+                         (FD.TA'.fib-el-subst (ρC v) (dC v) (htele-apply' rel v {z})
+                          ∘ (FR.aapply am v (Rδ.apply md v z) ∘ prod-m (id _) (Rδ.apply-fam md v z)))
+                         ≈ FD.fold-apply-fam γ fm v z
+          htelef-apply hbase' Fin.zero {z} =
+            ≈-trans (∘-cong ≈-refl (≈-trans (∘-cong ≈-refl prod-m-id) id-right)) (η-fam z)
+          htelef-apply hbase' (Fin.suc i) {z} =
+            ≈-trans (∘-cong (δ i .fam .refl*) ≈-refl)
+              (≈-trans id-left (≈-trans (∘-cong ≈-refl prod-m-id) id-right))
+          htelef-apply (hbind' S' rel) Fin.zero {z} = htelef-shape (μ S') rel z
+          htelef-apply (hbind' S' rel) (Fin.suc v) = htelef-apply rel v
+
+hasMuLaws : HasMuLaws hasMu
+hasMuLaws .HasMuLaws.⦅⦆-β {P = P} alg ._≃_.idxf-eq .PS._≃m_.func-eq (γ≈ , m≈) =
+  alg .idxf .PS._⇒_.func-resp-≈ (γ≈ , BetaDef.β-idx alg P γ≈ m≈)
+hasMuLaws .HasMuLaws.⦅⦆-β {Γ = Γ} {P = P} {δ = δ} alg ._≃_.famf-eq .indexed-family._≃f_.transf-eq {γ , m} =
+  ≈-trans (∘-cong ≈-refl id-left)
+    (≈-trans (∘-cong ≈-refl (∘-cong ≈-refl (pair-cong ≈-refl id-left)))
+      (≈-trans (∘-cong ≈-refl (assoc _ _ _))
+        (≈-trans (∘-cong ≈-refl (∘-cong ≈-refl
+                   (≈-trans (pair-natural _ _ _)
+                     (pair-cong (pair-p₁ _ _) (∘-cong ≈-refl (pair-cong (≈-sym id-left) ≈-refl))))))
+          (≈-trans (≈-sym (assoc _ _ _))
+            (≈-trans (∘-cong (≈-sym (alg .famf ._⇒f_.natural
+                                       (Γ .idx .isEquivalence .refl ,
+                                        B.β-idx P (Γ .idx .isEquivalence .refl)
+                                          (fobj μObj P B.δ' .idx .isEquivalence .refl)))) ≈-refl)
+              (≈-trans (assoc _ _ _)
+                (≈-trans (∘-cong ≈-refl (pair-compose _ _ _ _))
+                  (≈-trans (∘-cong ≈-refl
+                             (pair-cong (≈-trans (∘-cong (Γ .fam .refl*) ≈-refl) id-left) (B.β-fam P)))
+                    (≈-sym id-left)))))))))
+  where
+    module B = BetaDef {P = P} {δ = δ} alg
+hasMuLaws .HasMuLaws.⦅⦆-η {Γ = Γ} {P = P} {δ = δ} alg h eq ._≃_.idxf-eq .PS._≃m_.func-eq (γ≈ , t≈) =
+  EtaDef.η-idx {P = P} {δ = δ} alg h eq γ≈ t≈
+hasMuLaws .HasMuLaws.⦅⦆-η {Γ = Γ} {P = P} {δ = δ} alg h eq ._≃_.famf-eq .indexed-family._≃f_.transf-eq {γ , t} =
+  EtaDef.EtaFam.η-fam {P = P} {δ = δ} alg h eq γ t
diff --git a/agda/src/fam-mu-types/carrier.agda b/agda/src/fam-mu-types/carrier.agda
new file mode 100644
index 00000000..ab552f4d
--- /dev/null
+++ b/agda/src/fam-mu-types/carrier.agda
@@ -0,0 +1,65 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- Carrier of μ-types for the Fam construction: nested μ reduced to a single
+-- sort-indexed W-type in setoids, with the fibre family computed by structural
+-- recursion over trees. The sorts and trees are category-free, built from the
+-- index setoids alone; the fibres recover the objects of the original
+-- polynomial and environment through a decoration of the sorts.
+--
+-- Abbott, Altenkirch, Ghani. Containers: constructing strictly positive types. TCS 342(1), 2005.
+-- Abbott, Altenkirch, Ghani. Representing nested inductive types using W-types. ICALP 2004.
+-- Emmenegger. W-types in setoids. arXiv:1809.02375, 2018.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Product using (_,_)
+open import prop using (_,_)
+open import categories using (Category; HasTerminal; HasProducts)
+open import prop-setoid using (IsEquivalence; Setoid)
+open import indexed-family using (Fam; _⇒f_)
+import fam
+import polynomial-functor
+import fam-mu-types.sort
+import fam-mu-types.fibre
+
+module fam-mu-types.carrier {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open Category 𝒞 public
+open IsEquivalence public
+open HasProducts P public
+open fam.CategoryOfFamilies os (os ⊔ es) 𝒞 public
+open Obj public
+open Mor public
+open Fam public
+module Fam𝒞 = Category cat
+open products P public  -- Fam-level products
+module Fam𝒞-P = HasProducts products
+open _⇒f_ public
+open polynomial-functor using (extend) public
+open polynomial-functor.Poly public
+open polynomial-functor.Interp (terminal T) products strongCoproducts public
+  using (fobj; HasMu; HasMuLaws)
+
+Poly = polynomial-functor.Poly cat
+open Setoid using (Carrier; isEquivalence) renaming (_≈_ to _≈s_) public
+
+open import Data.Sum using (_⊎_) public
+open import Data.Product using () renaming (_×_ to _×T_) public
+open import prop using (_∧_; ⊥) public
+
+-- The category-free sort layer, shared by every base category, and the
+-- decorated fibre layer over this one.
+module Sh = fam-mu-types.sort os es
+open Sh public using (Sort; mkSort)
+open fam-mu-types.fibre os es T P public using (Idx; ∣_∣; module Fibre; μObj)
+
+-- Trees over an environment: shapes at its index setoids, fibres by decoration.
+module Tree {n} (δ : Fin n → Obj) where
+  open Sh.Tree (λ i → δ i .idx) public
+  open Fibre δ public
diff --git a/agda/src/fam-mu-types/constant-free.agda b/agda/src/fam-mu-types/constant-free.agda
new file mode 100644
index 00000000..c714ee61
--- /dev/null
+++ b/agda/src/fam-mu-types/constant-free.agda
@@ -0,0 +1,655 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- The μ-carrier of a polynomial coincides with its constant-free
+-- form at the environment extended by the constants: a constant and a
+-- variable bound to an equal environment entry contribute the same carrier
+-- data, so the two W-types agree up to renaming of tree constructors.
+-- Decorations are passed explicitly: the T₂-side decoration is consumed at
+-- shifted positions, so it cannot be inferred by pattern unification.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_; lift) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc) renaming (_+_ to _+ℕ_)
+import Data.Fin as Fin
+open Fin using (Fin; _↑ˡ_; _↑ʳ_; splitAt)
+open import Data.Fin.Properties using (splitAt-↑ˡ; splitAt-↑ʳ)
+open import Data.Sum using (inj₁; inj₂; [_,_]′)
+open import Data.Product using (_,_)
+open import Data.Unit using (tt)
+open import prop using () renaming (_,_ to _,ₚ_)
+open import Relation.Binary.PropositionalEquality
+  using (_≡_; cong; cong₂; subst-subst-sym; subst-sym-subst)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; subst to ≡-subst)
+open import categories using (Category; HasTerminal; HasProducts)
+open import prop-setoid using (Setoid)
+open import indexed-family using (_≃f_)
+import polynomial-functor
+import fam-mu-types.carrier
+
+module fam-mu-types.constant-free {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open fam-mu-types.carrier os es T P
+open polynomial-functor using (#c; constant-free; constant-free-go; consts; _++e_)
+
+-- Fixed data for one instance of the lemma: an environment and a constant
+-- block over the Fam category.
+module ConstantFree {n k : ℕ} (δ : Fin n → Obj) (cs : Fin k → Obj) where
+
+  δ⁺ : Fin (n +ℕ k) → Obj
+  δ⁺ = δ ++e cs
+
+  module T₁ = Tree δ
+  module T₂ = Tree δ⁺
+
+  -- Relate source references (environment positions or sorts) to target ones,
+  -- with their decorations: environment positions inject on the left; sorts
+  -- relate recursively, with the constant block of the source polynomial
+  -- pointing at the constant entries of the extended environment.
+  mutual
+    data RefRel : (r₁ : Fin n ⊎ Sort n) (r₂ : Fin (n +ℕ k) ⊎ Sort (n +ℕ k)) →
+                  T₁.DecoAssign r₁ → T₂.DecoAssign r₂ → Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+      env : ∀ {p} → RefRel (inj₁ p) (inj₁ (p ↑ˡ k)) (lift tt) (lift tt)
+      srt : ∀ {s₁ s₂ e₁ e₂} → SortRel s₁ s₂ e₁ e₂ → RefRel (inj₂ s₁) (inj₂ s₂) e₁ e₂
+
+    data SortRel : (s₁ : Sort n) (s₂ : Sort (n +ℕ k)) →
+                   T₁.Deco s₁ → T₂.Deco s₂ → Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+      mk : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+           (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+           (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i)) →
+           (∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+           (∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+           (∀ c → cs (ι c) ≡ consts Q c) →
+           SortRel (mkSort ∣ Q ∣ ρ₁) (mkSort ∣ constant-free-go Q ι ∣ ρ₂)
+                   (T₁.mkDeco Q d₁) (T₂.mkDeco (constant-free-go Q ι) d₂)
+
+  -- The forward tree map: rename constant leaves to their variable images.
+  mutual
+    wfwd : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+           (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+           (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i)) →
+           (∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+           (∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+           (∀ c → cs (ι c) ≡ consts Q c) →
+           T₁.W ∣ Q ∣ ρ₁ → T₂.W ∣ constant-free-go Q ι ∣ ρ₂
+    wfwd {j} Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (T₁.sup x) =
+      T₂.sup (shape-fwd Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+                (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+                (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok x)
+
+    -- The extended environments stay related when entering a binder.
+    extend-vars : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+                  (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                  (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i)) →
+                  (∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                  (∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                  (∀ c → cs (ι c) ≡ consts Q c) →
+                  ∀ i → RefRel (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁)) i)
+                               (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)) (i ↑ˡ k))
+                               (T₁.deco-ext Q d₁ i)
+                               (T₂.deco-ext (constant-free-go Q ι) d₂ (i ↑ˡ k))
+    extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok Fin.zero    = srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)
+    extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (Fin.suc i) = vars i
+
+    extend-fresh : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+                   (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k)) →
+                   (∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                   ∀ (c : Fin k) → extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)) (suc j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)
+    extend-fresh Q ρ₁ ι ρ₂ fresh c = fresh c
+
+    shape-fwd : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+                (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i)) →
+                (∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                (∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                (∀ c → cs (ι c) ≡ consts Q c) →
+                T₁.⟦ ∣ Q ∣ ⟧shape η₁ → T₂.⟦ ∣ constant-free-go Q ι ∣ ⟧shape η₂
+    shape-fwd {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok x =
+      ≡-subst T₂.El (≡-sym (fresh (ι Fin.zero)))
+        (≡-subst (λ B → B .idx .Carrier)
+          (≡-sym (≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero))) x)
+    shape-fwd (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok x = el-fwd (vars i) x
+    shape-fwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₁ x) =
+      inj₁ (shape-fwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+              (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x)
+    shape-fwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₂ y) =
+      inj₂ (shape-fwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+              (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y)
+    shape-fwd (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok (x , y) =
+      shape-fwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x
+      , shape-fwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y
+    shape-fwd (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok x = wfwd Q' η₁ ι η₂ d₁ d₂ vars fresh csok x
+
+    -- References transport elements.
+    el-fwd : ∀ {r₁ r₂ dr₁ dr₂} → RefRel r₁ r₂ dr₁ dr₂ → T₁.El r₁ → T₂.El r₂
+    el-fwd (env {p}) x =
+      ≡-subst (λ B → B .idx .Carrier) (≡-sym (cong [ δ , cs ]′ (splitAt-↑ˡ n p k))) x
+    el-fwd (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) x = wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x
+
+  -- Casts commute with the setoid equalities, by identity elimination.
+  private
+    cast-≈ : ∀ {B B' : Obj} (e : B ≡ B') {x y : B .idx .Carrier} →
+             B .idx ._≈s_ x y →
+             B' .idx ._≈s_ (≡-subst (λ Z → Z .idx .Carrier) e x) (≡-subst (λ Z → Z .idx .Carrier) e y)
+    cast-≈ ≡-refl p = p
+
+    el-cast-≈ : ∀ {r r' : Fin (n +ℕ k) ⊎ Sort (n +ℕ k)} (e : r ≡ r') {x y : T₂.El r} →
+                T₂.elEq r x y → T₂.elEq r' (≡-subst T₂.El e x) (≡-subst T₂.El e y)
+    el-cast-≈ ≡-refl p = p
+
+  -- The forward map preserves bisimilarity.
+  mutual
+    w≈-fwd : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+             (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+             (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i))
+             (vars : ∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+             (fresh : ∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+             (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+             {x y : T₁.W ∣ Q ∣ ρ₁} → T₁.W-≈ x y →
+             T₂.W-≈ (wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x) (wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok y)
+    w≈-fwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok {T₁.sup x} {T₁.sup y} p =
+      shape≈-fwd Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+        (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+        (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok p
+
+    shape≈-fwd : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+                 (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                 (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i))
+                 (vars : ∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                 (fresh : ∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                 (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+                 {x y : T₁.⟦ ∣ Q ∣ ⟧shape η₁} → T₁.shape≈ ∣ Q ∣ η₁ x y →
+                 T₂.shape≈ ∣ constant-free-go Q ι ∣ η₂ (shape-fwd Q η₁ ι η₂ d₁ d₂ vars fresh csok x) (shape-fwd Q η₁ ι η₂ d₁ d₂ vars fresh csok y)
+    shape≈-fwd {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok p =
+      el-cast-≈ (≡-sym (fresh (ι Fin.zero)))
+        (cast-≈ (≡-sym (≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero))) p)
+    shape≈-fwd (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok p = elEq-fwd (vars i) p
+    shape≈-fwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok {inj₁ _} {inj₁ _} p =
+      shape≈-fwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) p
+    shape≈-fwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok {inj₂ _} {inj₂ _} p =
+      shape≈-fwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) p
+    shape≈-fwd (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok {_ , _} {_ , _} (p ,ₚ q) =
+      shape≈-fwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) p
+      ,ₚ shape≈-fwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) q
+    shape≈-fwd (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok {x} {y} p =
+      w≈-fwd Q' η₁ ι η₂ d₁ d₂ vars fresh csok {x} {y} p
+
+    elEq-fwd : ∀ {r₁ r₂ dr₁ dr₂} (r : RefRel r₁ r₂ dr₁ dr₂) {x y : T₁.El r₁} →
+               T₁.elEq r₁ x y → T₂.elEq r₂ (el-fwd r x) (el-fwd r y)
+    elEq-fwd (env {p}) q =
+      cast-≈ (≡-sym (cong [ δ , cs ]′ (splitAt-↑ˡ n p k))) q
+    elEq-fwd (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) {x} {y} q =
+      w≈-fwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok {x} {y} q
+
+  -- The backward tree map: rename the fresh variable leaves back to constants.
+  mutual
+    wbwd : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+           (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+           (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i)) →
+           (∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+           (∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+           (∀ c → cs (ι c) ≡ consts Q c) →
+           T₂.W ∣ constant-free-go Q ι ∣ ρ₂ → T₁.W ∣ Q ∣ ρ₁
+    wbwd {j} Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (T₂.sup x) =
+      T₁.sup (shape-bwd Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+                (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+                (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok x)
+
+    shape-bwd : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+                (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i)) →
+                (∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                (∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                (∀ c → cs (ι c) ≡ consts Q c) →
+                T₂.⟦ ∣ constant-free-go Q ι ∣ ⟧shape η₂ → T₁.⟦ ∣ Q ∣ ⟧shape η₁
+    shape-bwd {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok x =
+      ≡-subst (λ B → B .idx .Carrier)
+        (≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero))
+        (≡-subst T₂.El (fresh (ι Fin.zero)) x)
+    shape-bwd (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok x = el-bwd (vars i) x
+    shape-bwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₁ x) =
+      inj₁ (shape-bwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+              (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x)
+    shape-bwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₂ y) =
+      inj₂ (shape-bwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+              (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y)
+    shape-bwd (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok (x , y) =
+      shape-bwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x
+      , shape-bwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y
+    shape-bwd (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok x = wbwd Q' η₁ ι η₂ d₁ d₂ vars fresh csok x
+
+    el-bwd : ∀ {r₁ r₂ dr₁ dr₂} → RefRel r₁ r₂ dr₁ dr₂ → T₂.El r₂ → T₁.El r₁
+    el-bwd (env {p}) x =
+      ≡-subst (λ B → B .idx .Carrier) (cong [ δ , cs ]′ (splitAt-↑ˡ n p k)) x
+    el-bwd (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) x = wbwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x
+
+  -- Equal elements are setoid-equal.
+  private
+    obj-≡-to-≈ : ∀ {B : Obj} {x y : B .idx .Carrier} → x ≡ y → B .idx ._≈s_ x y
+    obj-≡-to-≈ {B} {x} ≡-refl = B .idx .isEquivalence .refl
+
+    ≡-to-≈₁ : ∀ {r} {x y : T₁.El r} → x ≡ y → T₁.elEq r x y
+    ≡-to-≈₁ {r} {x} ≡-refl = T₁.elEq-refl r x
+
+    ≡-to-≈₂ : ∀ {r} {x y : T₂.El r} → x ≡ y → T₂.elEq r x y
+    ≡-to-≈₂ {r} {x} ≡-refl = T₂.elEq-refl r x
+
+    Car : Obj → Set os
+    Car B = B .idx .Carrier
+
+  -- Round trips: the two maps are mutually inverse up to bisimilarity.
+  mutual
+    w-fb : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+           (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+           (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i))
+           (vars : ∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+           (fresh : ∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+           (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+           (x : T₁.W ∣ Q ∣ ρ₁) →
+           T₁.W-≈ (wbwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x)) x
+    w-fb Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (T₁.sup x) =
+      shape-fb Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+        (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+        (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok x
+
+    shape-fb : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+               (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+               (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i))
+               (vars : ∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+               (fresh : ∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+               (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+               (x : T₁.⟦ ∣ Q ∣ ⟧shape η₁) →
+               T₁.shape≈ ∣ Q ∣ η₁ (shape-bwd Q η₁ ι η₂ d₁ d₂ vars fresh csok (shape-fwd Q η₁ ι η₂ d₁ d₂ vars fresh csok x)) x
+    shape-fb {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok x =
+      obj-≡-to-≈ {B = A} (≡-trans (cong (≡-subst Car E) (subst-subst-sym {P = T₂.El} F)) (subst-subst-sym {P = Car} E))
+      where
+        E = ≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero)
+        F = fresh (ι Fin.zero)
+    shape-fb (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok x = el-fb (vars i) x
+    shape-fb (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₁ x) =
+      shape-fb Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x
+    shape-fb (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₂ y) =
+      shape-fb R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y
+    shape-fb (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok (x , y) =
+      shape-fb Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x
+      ,ₚ shape-fb R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y
+    shape-fb (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok x = w-fb Q' η₁ ι η₂ d₁ d₂ vars fresh csok x
+
+    el-fb : ∀ {r₁ r₂ dr₁ dr₂} (r : RefRel r₁ r₂ dr₁ dr₂) (x : T₁.El r₁) →
+            T₁.elEq r₁ (el-bwd r (el-fwd r x)) x
+    el-fb (env {p}) x = obj-≡-to-≈ {B = δ p} (subst-subst-sym {P = Car} (cong [ δ , cs ]′ (splitAt-↑ˡ n p k)))
+    el-fb (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) x = w-fb Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x
+
+  mutual
+    w-bf : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+           (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+           (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i))
+           (vars : ∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+           (fresh : ∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+           (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+           (y : T₂.W ∣ constant-free-go Q ι ∣ ρ₂) →
+           T₂.W-≈ (wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (wbwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok y)) y
+    w-bf Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (T₂.sup y) =
+      shape-bf Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+        (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+        (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok y
+
+    shape-bf : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+               (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+               (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i))
+               (vars : ∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+               (fresh : ∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+               (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+               (y : T₂.⟦ ∣ constant-free-go Q ι ∣ ⟧shape η₂) →
+               T₂.shape≈ ∣ constant-free-go Q ι ∣ η₂ (shape-fwd Q η₁ ι η₂ d₁ d₂ vars fresh csok (shape-bwd Q η₁ ι η₂ d₁ d₂ vars fresh csok y)) y
+    shape-bf {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok y =
+      ≡-to-≈₂ {r = η₂ (jv ↑ʳ ι Fin.zero)} (≡-trans (cong (≡-subst T₂.El (≡-sym F)) (subst-sym-subst {P = Car} E)) (subst-sym-subst {P = T₂.El} F))
+      where
+        E = ≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero)
+        F = fresh (ι Fin.zero)
+    shape-bf (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok y = el-bf (vars i) y
+    shape-bf (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₁ y) =
+      shape-bf Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) y
+    shape-bf (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₂ y) =
+      shape-bf R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y
+    shape-bf (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok (x , y) =
+      shape-bf Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x
+      ,ₚ shape-bf R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y
+    shape-bf (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok y = w-bf Q' η₁ ι η₂ d₁ d₂ vars fresh csok y
+
+    el-bf : ∀ {r₁ r₂ dr₁ dr₂} (r : RefRel r₁ r₂ dr₁ dr₂) (y : T₂.El r₂) →
+            T₂.elEq r₂ (el-fwd r (el-bwd r y)) y
+    el-bf (env {p}) y = obj-≡-to-≈ {B = δ⁺ (p ↑ˡ k)} (subst-sym-subst {P = Car} (cong [ δ , cs ]′ (splitAt-↑ˡ n p k)))
+    el-bf (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) y = w-bf Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok y
+
+  -- The backward map preserves bisimilarity.
+  mutual
+    w≈-bwd : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+             (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+             (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i))
+             (vars : ∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+             (fresh : ∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+             (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+             {x y : T₂.W ∣ constant-free-go Q ι ∣ ρ₂} → T₂.W-≈ x y →
+             T₁.W-≈ (wbwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x) (wbwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok y)
+    w≈-bwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok {T₂.sup x} {T₂.sup y} p =
+      shape≈-bwd Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+        (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+        (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok p
+
+    shape≈-bwd : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+                 (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                 (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i))
+                 (vars : ∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                 (fresh : ∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                 (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+                 {x y : T₂.⟦ ∣ constant-free-go Q ι ∣ ⟧shape η₂} → T₂.shape≈ ∣ constant-free-go Q ι ∣ η₂ x y →
+                 T₁.shape≈ ∣ Q ∣ η₁ (shape-bwd Q η₁ ι η₂ d₁ d₂ vars fresh csok x) (shape-bwd Q η₁ ι η₂ d₁ d₂ vars fresh csok y)
+    shape≈-bwd {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok p =
+      cast-≈ (≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero))
+        (el-cast-≈ (fresh (ι Fin.zero)) p)
+    shape≈-bwd (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok p = elEq-bwd (vars i) p
+    shape≈-bwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok {inj₁ _} {inj₁ _} p =
+      shape≈-bwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) p
+    shape≈-bwd (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok {inj₂ _} {inj₂ _} p =
+      shape≈-bwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) p
+    shape≈-bwd (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok {_ , _} {_ , _} (p ,ₚ q) =
+      shape≈-bwd Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) p
+      ,ₚ shape≈-bwd R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) q
+    shape≈-bwd (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok {x} {y} p =
+      w≈-bwd Q' η₁ ι η₂ d₁ d₂ vars fresh csok {x} {y} p
+
+    elEq-bwd : ∀ {r₁ r₂ dr₁ dr₂} (r : RefRel r₁ r₂ dr₁ dr₂) {x y : T₂.El r₂} →
+               T₂.elEq r₂ x y → T₁.elEq r₁ (el-bwd r x) (el-bwd r y)
+    elEq-bwd (env {p}) q =
+      cast-≈ (cong [ δ , cs ]′ (splitAt-↑ˡ n p k)) q
+    elEq-bwd (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) {x} {y} q =
+      w≈-bwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok {x} {y} q
+
+  -- The fibres of matched trees are equal objects.
+  private
+    fib-el-castF : ∀ {r q} (F : r ≡ inj₁ q) {dr : T₂.DecoAssign r} (z : T₂.El (inj₁ q)) →
+                   T₂.fib-el r dr (≡-subst T₂.El (≡-sym F) z) ≡ T₂.fib-el (inj₁ q) (lift tt) z
+    fib-el-castF ≡-refl z = ≡-refl
+
+    fib-castE : ∀ {B B'} (E : B ≡ B') (x : B' .idx .Carrier) →
+                B .fam .fm (≡-subst Car (≡-sym E) x) ≡ B' .fam .fm x
+    fib-castE ≡-refl x = ≡-refl
+
+  mutual
+    fib-fwd-≡ : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+                (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i))
+                (vars : ∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                (fresh : ∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+                (x : T₁.W ∣ Q ∣ ρ₁) →
+                T₂.fib (constant-free-go Q ι) d₂ (wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x) ≡ T₁.fib Q d₁ x
+    fib-fwd-≡ Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok (T₁.sup x) =
+      fib-shape-≡ Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+        (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+        (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok x
+
+    fib-shape-≡ : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+                  (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                  (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i))
+                  (vars : ∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                  (fresh : ∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                  (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+                  (x : T₁.⟦ ∣ Q ∣ ⟧shape η₁) →
+                  T₂.fib-shape (constant-free-go Q ι) d₂ (shape-fwd Q η₁ ι η₂ d₁ d₂ vars fresh csok x) ≡ T₁.fib-shape Q d₁ x
+    fib-shape-≡ {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok x =
+      ≡-trans (fib-el-castF (fresh (ι Fin.zero)) _)
+        (fib-castE (≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero)) x)
+    fib-shape-≡ (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok x = fib-el-≡ (vars i) x
+    fib-shape-≡ (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₁ x) =
+      fib-shape-≡ Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x
+    fib-shape-≡ (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok (inj₂ y) =
+      fib-shape-≡ R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y
+    fib-shape-≡ (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok (x , y) =
+      cong₂ prod
+        (fib-shape-≡ Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) x)
+        (fib-shape-≡ R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+          (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) y)
+    fib-shape-≡ (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok x = fib-fwd-≡ Q' η₁ ι η₂ d₁ d₂ vars fresh csok x
+
+    fib-el-≡ : ∀ {r₁ r₂ dr₁ dr₂} (r : RefRel r₁ r₂ dr₁ dr₂) (x : T₁.El r₁) →
+               T₂.fib-el r₂ dr₂ (el-fwd r x) ≡ T₁.fib-el r₁ dr₁ x
+    fib-el-≡ (env {p}) x = fib-castE (cong [ δ , cs ]′ (splitAt-↑ˡ n p k)) x
+    fib-el-≡ (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) x = fib-fwd-≡ Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x
+
+  -- Object equalities induce morphisms; the casts commute with the fibre
+  -- transports.
+  private
+    ≡-mor : ∀ {A B : obj} → A ≡ B → A ⇒ B
+    ≡-mor ≡-refl = id _
+
+    -- Leaf square: a cast built from a reference equality and an object
+    -- equality commutes with the underlying family's transport.
+    leaf-compat : ∀ {r q} (F : r ≡ inj₁ q) {dr : T₂.DecoAssign r} {B} (E : δ⁺ q ≡ B)
+                  {x y : B .idx .Carrier} (p : B .idx ._≈s_ x y) →
+                  (≡-mor (≡-sym (≡-trans (fib-el-castF F {dr} (≡-subst Car (≡-sym E) y)) (fib-castE E y)))
+                    ∘ B .fam .subst p)
+                  ≈ (T₂.fib-el-subst r dr (el-cast-≈ (≡-sym F) (cast-≈ (≡-sym E) p))
+                    ∘ ≡-mor (≡-sym (≡-trans (fib-el-castF F {dr} (≡-subst Car (≡-sym E) x)) (fib-castE E x))))
+    leaf-compat ≡-refl ≡-refl p = ≈-trans id-left (≈-sym id-right)
+
+    env-compat : ∀ {B B'} (E : B' ≡ B) {x y : B .idx .Carrier} (p : B .idx ._≈s_ x y) →
+                 (≡-mor (≡-sym (fib-castE E y)) ∘ B .fam .subst p)
+                 ≈ (B' .fam .subst (cast-≈ (≡-sym E) p) ∘ ≡-mor (≡-sym (fib-castE E x)))
+    env-compat ≡-refl p = ≈-trans id-left (≈-sym id-right)
+
+    prod-sq : ∀ {A₁ A₂ B₁ B₂ A₁' A₂' B₁' B₂' : obj}
+              (ey₁ : A₁' ≡ A₁) (ey₂ : A₂' ≡ A₂) (ex₁ : B₁' ≡ B₁) (ex₂ : B₂' ≡ B₂)
+              {s₁ : B₁ ⇒ A₁} {s₂ : B₂ ⇒ A₂} {s₁' : B₁' ⇒ A₁'} {s₂' : B₂' ⇒ A₂'} →
+              (≡-mor (≡-sym ey₁) ∘ s₁) ≈ (s₁' ∘ ≡-mor (≡-sym ex₁)) →
+              (≡-mor (≡-sym ey₂) ∘ s₂) ≈ (s₂' ∘ ≡-mor (≡-sym ex₂)) →
+              (≡-mor (≡-sym (cong₂ prod ey₁ ey₂)) ∘ prod-m s₁ s₂)
+              ≈ (prod-m s₁' s₂' ∘ ≡-mor (≡-sym (cong₂ prod ex₁ ex₂)))
+    prod-sq ≡-refl ≡-refl ≡-refl ≡-refl h₁ h₂ =
+      ≈-trans id-left
+        (≈-trans (prod-m-cong (≈-trans (≈-sym id-left) (≈-trans h₁ id-right))
+                              (≈-trans (≈-sym id-left) (≈-trans h₂ id-right)))
+          (≈-sym id-right))
+
+  mutual
+    w-compat : ∀ {j} (Q : Poly (suc j)) (ρ₁ : Fin j → Fin n ⊎ Sort n)
+               (ι : Fin (#c Q) → Fin k) (ρ₂ : Fin (j +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+               (d₁ : ∀ i → T₁.DecoAssign (ρ₁ i)) (d₂ : ∀ i → T₂.DecoAssign (ρ₂ i))
+               (vars : ∀ i → RefRel (ρ₁ i) (ρ₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+               (fresh : ∀ (c : Fin k) → ρ₂ (j ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+               (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+               {x y : T₁.W ∣ Q ∣ ρ₁} (e : T₁.W-≈ x y) →
+               (≡-mor (≡-sym (fib-fwd-≡ Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok y)) ∘ T₁.fib-subst Q d₁ {x = x} {y = y} e)
+               ≈ (T₂.fib-subst (constant-free-go Q ι) d₂
+                    {x = wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x} {y = wfwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok y}
+                    (w≈-fwd Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok {x} {y} e)
+                  ∘ ≡-mor (≡-sym (fib-fwd-≡ Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok x)))
+    w-compat Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok {T₁.sup x} {T₁.sup y} e =
+      shape-compat Q (extend ρ₁ (inj₂ (mkSort ∣ Q ∣ ρ₁))) ι (extend ρ₂ (inj₂ (mkSort ∣ constant-free-go Q ι ∣ ρ₂)))
+        (T₁.deco-ext Q d₁) (T₂.deco-ext (constant-free-go Q ι) d₂)
+        (extend-vars Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok) (extend-fresh Q ρ₁ ι ρ₂ fresh) csok e
+
+    shape-compat : ∀ {jv} (Q : Poly jv) (η₁ : Fin jv → Fin n ⊎ Sort n)
+                   (ι : Fin (#c Q) → Fin k) (η₂ : Fin (jv +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k))
+                   (d₁ : ∀ i → T₁.DecoAssign (η₁ i)) (d₂ : ∀ i → T₂.DecoAssign (η₂ i))
+                   (vars : ∀ i → RefRel (η₁ i) (η₂ (i ↑ˡ k)) (d₁ i) (d₂ (i ↑ˡ k))) →
+                   (fresh : ∀ (c : Fin k) → η₂ (jv ↑ʳ c) ≡ inj₁ (n ↑ʳ c)) →
+                   (csok : ∀ c → cs (ι c) ≡ consts Q c) →
+                   {x y : T₁.⟦ ∣ Q ∣ ⟧shape η₁} (e : T₁.shape≈ ∣ Q ∣ η₁ x y) →
+                   (≡-mor (≡-sym (fib-shape-≡ Q η₁ ι η₂ d₁ d₂ vars fresh csok y)) ∘ T₁.fib-shape-subst Q d₁ e)
+                   ≈ (T₂.fib-shape-subst (constant-free-go Q ι) d₂ (shape≈-fwd Q η₁ ι η₂ d₁ d₂ vars fresh csok {x} {y} e)
+                      ∘ ≡-mor (≡-sym (fib-shape-≡ Q η₁ ι η₂ d₁ d₂ vars fresh csok x)))
+    shape-compat {jv} (const A) η₁ ι η₂ d₁ d₂ vars fresh csok e =
+      leaf-compat (fresh (ι Fin.zero))
+        (≡-trans (cong [ δ , cs ]′ (splitAt-↑ʳ n k (ι Fin.zero))) (csok Fin.zero)) e
+    shape-compat (var i)   η₁ ι η₂ d₁ d₂ vars fresh csok e = el-compat (vars i) e
+    shape-compat (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok {inj₁ _} {inj₁ _} e =
+      shape-compat Q η₁ (λ c → ι (c ↑ˡ #c R)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))) e
+    shape-compat (Q + R)   η₁ ι η₂ d₁ d₂ vars fresh csok {inj₂ _} {inj₂ _} e =
+      shape-compat R η₁ (λ c → ι (#c Q ↑ʳ c)) η₂ d₁ d₂ vars fresh
+        (λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))) e
+    shape-compat (Q × R)   η₁ ι η₂ d₁ d₂ vars fresh csok {x₁ , x₂} {y₁ , y₂} (e₁ ,ₚ e₂) =
+      prod-sq (fib-shape-≡ Q η₁ ιQ η₂ d₁ d₂ vars fresh csokQ y₁) (fib-shape-≡ R η₁ ιR η₂ d₁ d₂ vars fresh csokR y₂)
+              (fib-shape-≡ Q η₁ ιQ η₂ d₁ d₂ vars fresh csokQ x₁) (fib-shape-≡ R η₁ ιR η₂ d₁ d₂ vars fresh csokR x₂)
+              (shape-compat Q η₁ ιQ η₂ d₁ d₂ vars fresh csokQ e₁)
+              (shape-compat R η₁ ιR η₂ d₁ d₂ vars fresh csokR e₂)
+      where
+        ιQ = λ c → ι (c ↑ˡ #c R)
+        ιR = λ c → ι (#c Q ↑ʳ c)
+        csokQ = λ c → ≡-trans (csok (c ↑ˡ #c R)) (cong [ consts Q , consts R ]′ (splitAt-↑ˡ (#c Q) c (#c R)))
+        csokR = λ c → ≡-trans (csok (#c Q ↑ʳ c)) (cong [ consts Q , consts R ]′ (splitAt-↑ʳ (#c Q) (#c R) c))
+    shape-compat (μ Q')    η₁ ι η₂ d₁ d₂ vars fresh csok {x} {y} e =
+      w-compat Q' η₁ ι η₂ d₁ d₂ vars fresh csok {x} {y} e
+
+    el-compat : ∀ {r₁ r₂ dr₁ dr₂} (r : RefRel r₁ r₂ dr₁ dr₂) {x y : T₁.El r₁} (e : T₁.elEq r₁ x y) →
+                (≡-mor (≡-sym (fib-el-≡ r y)) ∘ T₁.fib-el-subst r₁ dr₁ e)
+                ≈ (T₂.fib-el-subst r₂ dr₂ (elEq-fwd r {x} {y} e) ∘ ≡-mor (≡-sym (fib-el-≡ r x)))
+    el-compat (env {p}) e = env-compat (cong [ δ , cs ]′ (splitAt-↑ˡ n p k)) e
+    el-compat (srt (mk Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok)) {x} {y} e =
+      w-compat Q ρ₁ ι ρ₂ d₁ d₂ vars fresh csok {x} {y} e
+
+  -- Helper kit for the isomorphism assembly.
+  private
+    ≡-mor-cancel : ∀ {A B : obj} (e : A ≡ B) → (≡-mor e ∘ ≡-mor (≡-sym e)) ≈ id B
+    ≡-mor-cancel ≡-refl = id-left
+
+    ≡-mor-cancel' : ∀ {A B : obj} (e : A ≡ B) → (≡-mor (≡-sym e) ∘ ≡-mor e) ≈ id A
+    ≡-mor-cancel' ≡-refl = id-left
+
+    flip-compat : ∀ {A A' B B' : obj} (eA : A' ≡ A) (eB : B' ≡ B)
+                  {f : A ⇒ B} {g : A' ⇒ B'} →
+                  (≡-mor (≡-sym eB) ∘ f) ≈ (g ∘ ≡-mor (≡-sym eA)) →
+                  (f ∘ ≡-mor eA) ≈ (≡-mor eB ∘ g)
+    flip-compat ≡-refl ≡-refl h =
+      ≈-trans id-right (≈-trans (≈-sym id-left) (≈-trans h (≈-trans id-right (≈-sym id-left))))
+
+  -- A polynomial against its constant-free form, at the extended environment.
+  module Inst (P : Poly (suc n)) (ι : Fin (#c P) → Fin k)
+              (csok : ∀ c → cs (ι c) ≡ consts P c) where
+
+    private
+      ρ₀ : Fin n → Fin n ⊎ Sort n
+      ρ₀ i = inj₁ i
+
+      ρ₀' : Fin (n +ℕ k) → Fin (n +ℕ k) ⊎ Sort (n +ℕ k)
+      ρ₀' i = inj₁ i
+
+      d₁₀ : ∀ i → T₁.DecoAssign (ρ₀ i)
+      d₁₀ i = lift tt
+
+      d₂₀ : ∀ i → T₂.DecoAssign (ρ₀' i)
+      d₂₀ i = lift tt
+
+      v₀ : ∀ i → RefRel (ρ₀ i) (ρ₀' (i ↑ˡ k)) (d₁₀ i) (d₂₀ (i ↑ˡ k))
+      v₀ i = env
+
+      f₀ : ∀ (c : Fin k) → ρ₀' (n ↑ʳ c) ≡ inj₁ (n ↑ʳ c)
+      f₀ c = ≡-refl
+
+      Fw : T₁.W ∣ P ∣ ρ₀ → T₂.W ∣ constant-free-go P ι ∣ ρ₀'
+      Fw = wfwd P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok
+
+      Bw : T₂.W ∣ constant-free-go P ι ∣ ρ₀' → T₁.W ∣ P ∣ ρ₀
+      Bw = wbwd P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok
+
+      fibeq : ∀ t → T₂.fib (constant-free-go P ι) d₂₀ (Fw t) ≡ T₁.fib P d₁₀ t
+      fibeq = fib-fwd-≡ P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok
+
+    fwd-mor : Mor (μObj P δ) (μObj (constant-free-go P ι) δ⁺)
+    fwd-mor .idxf .prop-setoid._⇒_.func = Fw
+    fwd-mor .idxf .prop-setoid._⇒_.func-resp-≈ {x₁} {x₂} = w≈-fwd P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok {x₁} {x₂}
+    fwd-mor .famf .transf t = ≡-mor (≡-sym (fibeq t))
+    fwd-mor .famf .natural {t₁} {t₂} e = w-compat P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok {x = t₁} {y = t₂} e
+
+    bwd-mor : Mor (μObj (constant-free-go P ι) δ⁺) (μObj P δ)
+    bwd-mor .idxf .prop-setoid._⇒_.func = Bw
+    bwd-mor .idxf .prop-setoid._⇒_.func-resp-≈ {x₁} {x₂} = w≈-bwd P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok {x₁} {x₂}
+    bwd-mor .famf .transf s =
+      ≡-mor (fibeq (Bw s)) ∘
+      T₂.fib-subst (constant-free-go P ι) d₂₀ {x = s} {y = Fw (Bw s)}
+        (T₂.W-≈-sym {x = Fw (Bw s)} {y = s} (w-bf P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok s))
+    bwd-mor .famf .natural {s₁} {s₂} e =
+      ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (≈-sym (T₂.fib-trans* (constant-free-go P ι) d₂₀
+                                    {x = s₁} {y = s₂} {z = Fw (Bw s₂)} _ _)))
+          (≈-sym
+            (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong₁ (flip-compat (fibeq (Bw s₁)) (fibeq (Bw s₂))
+                          (w-compat P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok {x = Bw s₁} {y = Bw s₂}
+                            (w≈-bwd P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok {s₁} {s₂} e))))
+                (≈-trans (assoc _ _ _)
+                  (∘-cong₂ (≈-sym (T₂.fib-trans* (constant-free-go P ι) d₂₀
+                                     {x = s₁} {y = Fw (Bw s₁)} {z = Fw (Bw s₂)} _ _))))))))
+
+    private
+      st-collapse₁ : ∀ {j} (Q : Poly (suc j)) {ρ} (d : ∀ i → T₁.DecoAssign (ρ i)) {a b : T₁.W ∣ Q ∣ ρ}
+                     (p : T₁.W-≈ a b) (q : T₁.W-≈ b a) →
+                     (T₁.fib-subst Q d {x = b} {y = a} q ∘ T₁.fib-subst Q d {x = a} {y = b} p) ≈ id (T₁.fib Q d a)
+      st-collapse₁ Q d {a} {b} p q =
+        ≈-trans (≈-sym (T₁.fib-trans* Q d {x = a} {y = b} {z = a} q p)) (T₁.fib-refl* Q d a)
+
+      st-collapse₂ : ∀ {j} (Q : Poly (suc j)) {ρ} (d : ∀ i → T₂.DecoAssign (ρ i)) {a b : T₂.W ∣ Q ∣ ρ}
+                     (p : T₂.W-≈ a b) (q : T₂.W-≈ b a) →
+                     (T₂.fib-subst Q d {x = b} {y = a} q ∘ T₂.fib-subst Q d {x = a} {y = b} p) ≈ id (T₂.fib Q d a)
+      st-collapse₂ Q d {a} {b} p q =
+        ≈-trans (≈-sym (T₂.fib-trans* Q d {x = a} {y = b} {z = a} q p)) (T₂.fib-refl* Q d a)
+
+    fb-≃ : Fam𝒞._≈_ (Mor-∘ fwd-mor bwd-mor) (Mor-id _)
+    fb-≃ ._≃_.idxf-eq = prop-setoid.mk-≃m (λ s → w-bf P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok s)
+    fb-≃ ._≃_.famf-eq ._≃f_.transf-eq {s} =
+      ≈-trans (∘-cong₂ id-left)
+        (≈-trans (∘-cong₂ (≈-trans (≈-sym (assoc _ _ _))
+            (≈-trans (∘-cong₁ (≡-mor-cancel' (fibeq (Bw s)))) id-left)))
+          (st-collapse₂ (constant-free-go P ι) d₂₀ {a = s} {b = Fw (Bw s)} _ _))
+
+    bf-≃ : Fam𝒞._≈_ (Mor-∘ bwd-mor fwd-mor) (Mor-id _)
+    bf-≃ ._≃_.idxf-eq = prop-setoid.mk-≃m (λ t → w-fb P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok t)
+    bf-≃ ._≃_.famf-eq ._≃f_.transf-eq {t} =
+      ≈-trans (∘-cong₂ id-left)
+        (≈-trans (∘-cong₂ (≈-trans (assoc _ _ _)
+            (≈-trans (∘-cong₂ (≈-sym (w-compat P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok
+                {x = t} {y = Bw (Fw t)}
+                (T₁.W-≈-sym {x = Bw (Fw t)} {y = t} (w-fb P ρ₀ ι ρ₀' d₁₀ d₂₀ v₀ f₀ csok t)))))
+              (≈-trans (≈-sym (assoc _ _ _))
+                (≈-trans (∘-cong₁ (≡-mor-cancel (fibeq (Bw (Fw t))))) id-left)))))
+          (st-collapse₁ P d₁₀ {a = t} {b = Bw (Fw t)} _ _))
+
+    constant-free-inst-iso : Fam𝒞.Iso (μObj P δ) (μObj (constant-free-go P ι) δ⁺)
+    constant-free-inst-iso .Fam𝒞.Iso.fwd = fwd-mor
+    constant-free-inst-iso .Fam𝒞.Iso.bwd = bwd-mor
+    constant-free-inst-iso .Fam𝒞.Iso.fwd∘bwd≈id = fb-≃
+    constant-free-inst-iso .Fam𝒞.Iso.bwd∘fwd≈id = bf-≃
+
+-- The μ-carrier of a polynomial coincides with its constant-free
+-- form at the environment extended by its constants.
+constant-free-μ-iso : ∀ {n} (P : Poly (suc n)) (δ : Fin n → Obj) →
+                 Fam𝒞.Iso (μObj P δ) (μObj (constant-free P) (δ ++e consts P))
+constant-free-μ-iso P δ = constant-free-inst-iso
+  where open ConstantFree δ (consts P)
+        open Inst P (λ c → c) (λ c → ≡-refl)
diff --git a/agda/src/fam-mu-types/fibre.agda b/agda/src/fam-mu-types/fibre.agda
new file mode 100644
index 00000000..b4ca7fce
--- /dev/null
+++ b/agda/src/fam-mu-types/fibre.agda
@@ -0,0 +1,195 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- Fibre layer of the Fam μ-type construction, over the category-free sort
+-- layer. A decoration of a sort is a μ-body erasing to it, together with
+-- decorations of the sorts in its assignment; the fibre of a tree reads the
+-- decoration's constants and the environment's fibres by structural recursion
+-- on the tree.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_; Lift; lift) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Data.Product using (_,_)
+open import Data.Unit using (⊤; tt)
+open import prop using (_,_)
+open import categories using (Category; HasTerminal; HasProducts)
+open import functor using (Functor)
+open import indexed-family using (Fam; _⇒f_)
+open import prop-setoid using (Setoid)
+import setoid-cat
+import fam
+import polynomial-functor
+import fam-mu-types.sort
+
+module fam-mu-types.fibre {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open Category 𝒞
+open Functor
+open HasProducts P
+open fam.CategoryOfFamilies os (os ⊔ es) 𝒞
+open Obj
+open Mor
+open Fam
+open _≃_
+module Sh = fam-mu-types.sort os es
+open Sh using (mkSort)
+
+Poly-C = polynomial-functor.Poly cat
+open polynomial-functor.Poly
+open polynomial-functor using (extend; Poly-map)
+
+private module SC = Category (setoid-cat.SetoidCat os (os ⊔ es))
+
+-- The index functor: a family to its index setoid, a morphism to its index map.
+Idx : Functor cat (setoid-cat.SetoidCat os (os ⊔ es))
+Idx .fobj X = X .idx
+Idx .fmor f = f .idxf
+Idx .fmor-cong e = e .idxf-eq
+Idx .fmor-id = SC.≈-refl
+Idx .fmor-comp f g = SC.≈-refl
+
+∣_∣ : ∀ {n} → Poly-C n → Sh.Poly n
+∣_∣ = Poly-map Idx
+
+private
+  ℓD : Level
+  ℓD = o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es
+
+module Fibre {n} (δ : Fin n → Obj) where
+  open Sh.Tree (λ i → δ i .idx)
+
+  -- A decoration of a sort: a μ-body erasing to it, with the sorts in its
+  -- assignment decorated in turn. The sort is recovered by projection.
+  data Deco : Sh.Sort n → Set ℓD
+
+  DecoAssign : Fin n ⊎ Sh.Sort n → Set ℓD
+  DecoAssign (inj₁ _) = Lift ℓD ⊤
+  DecoAssign (inj₂ s) = Deco s
+
+  data Deco where
+    mkDeco : ∀ {k} (Q : Poly-C (suc k)) {ρ̄ : Fin k → Fin n ⊎ Sh.Sort n} →
+             ((i : Fin k) → DecoAssign (ρ̄ i)) → Deco (mkSort ∣ Q ∣ ρ̄)
+
+  -- The body environment of a decorated μ-binder: slot 0 is the binder's own
+  -- decoration, the rest are the ambient ones.
+  deco-ext : ∀ {k} (Q : Poly-C (suc k)) {ρ̄ : Fin k → Fin n ⊎ Sh.Sort n}
+             (d : ∀ i → DecoAssign (ρ̄ i)) →
+             ∀ i → DecoAssign (extend ρ̄ (inj₂ (mkSort ∣ Q ∣ ρ̄)) i)
+  deco-ext Q d Fin.zero = mkDeco Q d
+  deco-ext Q d (Fin.suc i) = d i
+
+  -- The fibre object at each tree: 𝒞-products at ×, parameter/const fibres at
+  -- the leaves, the decoration supplying the constants.
+  mutual
+    fib : ∀ {k} (Q : Poly-C (suc k)) {ρ̄ : Fin k → Fin n ⊎ Sh.Sort n}
+          (d : ∀ i → DecoAssign (ρ̄ i)) → W ∣ Q ∣ ρ̄ → obj
+    fib Q d (sup x) = fib-shape Q (deco-ext Q d) x
+
+    fib-shape : ∀ {j} (Q : Poly-C j) {η̄ : Fin j → Fin n ⊎ Sh.Sort n}
+                (d : ∀ i → DecoAssign (η̄ i)) → ⟦ ∣ Q ∣ ⟧shape η̄ → obj
+    fib-shape (const A) d x = A .fam .fm x
+    fib-shape (var i)   d x = fib-el _ (d i) x
+    fib-shape (P + Q) d (inj₁ x) = fib-shape P d x
+    fib-shape (P + Q) d (inj₂ y) = fib-shape Q d y
+    fib-shape (P × Q) d (x , y) = prod (fib-shape P d x) (fib-shape Q d y)
+    fib-shape (μ Q') d x = fib Q' d x
+
+    fib-el : (r : Fin n ⊎ Sh.Sort n) → DecoAssign r → El r → obj
+    fib-el (inj₁ p) _ x = δ p .fam .fm x
+    fib-el (inj₂ _) (mkDeco Q ρd) x = fib Q ρd x
+
+  -- Transport of fibres along bisimilarity, by recursion on the W-≈ proof.
+  mutual
+    fib-subst : ∀ {k} (Q : Poly-C (suc k)) {ρ̄ : Fin k → Fin n ⊎ Sh.Sort n}
+                (d : ∀ i → DecoAssign (ρ̄ i)) {x y : W ∣ Q ∣ ρ̄} →
+                W-≈ x y → fib Q d x ⇒ fib Q d y
+    fib-subst Q d {sup x} {sup y} p = fib-shape-subst Q (deco-ext Q d) p
+
+    fib-shape-subst : ∀ {j} (Q : Poly-C j) {η̄ : Fin j → Fin n ⊎ Sh.Sort n}
+                      (d : ∀ i → DecoAssign (η̄ i)) {x y : ⟦ ∣ Q ∣ ⟧shape η̄} →
+                      shape≈ ∣ Q ∣ η̄ x y → fib-shape Q d x ⇒ fib-shape Q d y
+    fib-shape-subst (const A) d p = A .fam .subst p
+    fib-shape-subst (var i)   d p = fib-el-subst _ (d i) p
+    fib-shape-subst (P + Q) d {inj₁ _} {inj₁ _} p = fib-shape-subst P d p
+    fib-shape-subst (P + Q) d {inj₂ _} {inj₂ _} p = fib-shape-subst Q d p
+    fib-shape-subst (P × Q) d {_ , _} {_ , _} (p₁ , p₂) =
+      prod-m (fib-shape-subst P d p₁) (fib-shape-subst Q d p₂)
+    fib-shape-subst (μ Q') d {x} {y} p = fib-subst Q' d {x = x} {y = y} p
+
+    fib-el-subst : (r : Fin n ⊎ Sh.Sort n) (dr : DecoAssign r) {x y : El r} →
+                   elEq r x y → fib-el r dr x ⇒ fib-el r dr y
+    fib-el-subst (inj₁ p) _ e = δ p .fam .subst e
+    fib-el-subst (inj₂ _) (mkDeco Q ρd) {x} {y} e = fib-subst Q ρd {x = x} {y = y} e
+
+  -- Transport along reflexivity is the identity.
+  mutual
+    fib-refl* : ∀ {k} (Q : Poly-C (suc k)) {ρ̄ : Fin k → Fin n ⊎ Sh.Sort n}
+                (d : ∀ i → DecoAssign (ρ̄ i)) (x : W ∣ Q ∣ ρ̄) →
+                fib-subst Q d {x = x} {y = x} (W-≈-refl x) ≈ id (fib Q d x)
+    fib-refl* Q d (sup x) = fib-shape-refl* Q (deco-ext Q d) x
+
+    fib-shape-refl* : ∀ {j} (Q : Poly-C j) {η̄ : Fin j → Fin n ⊎ Sh.Sort n}
+                      (d : ∀ i → DecoAssign (η̄ i)) (x : ⟦ ∣ Q ∣ ⟧shape η̄) →
+                      fib-shape-subst Q d (shape≈-refl ∣ Q ∣ η̄ x) ≈ id (fib-shape Q d x)
+    fib-shape-refl* (const A) d x = A .fam .refl*
+    fib-shape-refl* (var i)   d x = fib-el-refl* _ (d i) x
+    fib-shape-refl* (P + Q) d (inj₁ x) = fib-shape-refl* P d x
+    fib-shape-refl* (P + Q) d (inj₂ y) = fib-shape-refl* Q d y
+    fib-shape-refl* (P × Q) d (x , y) =
+      ≈-trans (prod-m-cong (fib-shape-refl* P d x) (fib-shape-refl* Q d y)) prod-m-id
+    fib-shape-refl* (μ Q') d x = fib-refl* Q' d x
+
+    fib-el-refl* : (r : Fin n ⊎ Sh.Sort n) (dr : DecoAssign r) (x : El r) →
+                   fib-el-subst r dr (elEq-refl r x) ≈ id (fib-el r dr x)
+    fib-el-refl* (inj₁ p) _ x = δ p .fam .refl*
+    fib-el-refl* (inj₂ _) (mkDeco Q ρd) x = fib-refl* Q ρd x
+
+  -- Transport is functorial: a composite is the composite of the transports.
+  mutual
+    fib-trans* : ∀ {k} (Q : Poly-C (suc k)) {ρ̄ : Fin k → Fin n ⊎ Sh.Sort n}
+                 (d : ∀ i → DecoAssign (ρ̄ i)) {x y z : W ∣ Q ∣ ρ̄}
+                 (q : W-≈ y z) (p : W-≈ x y) →
+                 fib-subst Q d {x = x} {y = z} (W-≈-trans {x = x} {y = y} {z = z} p q)
+                   ≈ (fib-subst Q d {x = y} {y = z} q ∘ fib-subst Q d {x = x} {y = y} p)
+    fib-trans* Q d {sup x} {sup y} {sup z} q p = fib-shape-trans* Q (deco-ext Q d) q p
+
+    fib-shape-trans* : ∀ {j} (Q : Poly-C j) {η̄ : Fin j → Fin n ⊎ Sh.Sort n}
+                       (d : ∀ i → DecoAssign (η̄ i)) {x y z : ⟦ ∣ Q ∣ ⟧shape η̄}
+                       (q : shape≈ ∣ Q ∣ η̄ y z) (p : shape≈ ∣ Q ∣ η̄ x y) →
+                       fib-shape-subst Q d (shape≈-trans ∣ Q ∣ η̄ p q)
+                         ≈ (fib-shape-subst Q d q ∘ fib-shape-subst Q d p)
+    fib-shape-trans* (const A) d q p = A .fam .trans* q p
+    fib-shape-trans* (var i)   d q p = fib-el-trans* _ (d i) q p
+    fib-shape-trans* (P + Q) d {inj₁ _} {inj₁ _} {inj₁ _} q p = fib-shape-trans* P d q p
+    fib-shape-trans* (P + Q) d {inj₂ _} {inj₂ _} {inj₂ _} q p = fib-shape-trans* Q d q p
+    fib-shape-trans* (P × Q) d {_ , _} {_ , _} {_ , _} (q₁ , q₂) (p₁ , p₂) =
+      ≈-trans (prod-m-cong (fib-shape-trans* P d q₁ p₁) (fib-shape-trans* Q d q₂ p₂))
+              (prod-m-comp _ _ _ _)
+    fib-shape-trans* (μ Q') d {x} {y} {z} q p = fib-trans* Q' d {x = x} {y = y} {z = z} q p
+
+    fib-el-trans* : (r : Fin n ⊎ Sh.Sort n) (dr : DecoAssign r) {x y z : El r}
+                    (q : elEq r y z) (p : elEq r x y) →
+                    fib-el-subst r dr (elEq-trans r p q)
+                      ≈ (fib-el-subst r dr q ∘ fib-el-subst r dr p)
+    fib-el-trans* (inj₁ i) _ q p = δ i .fam .trans* q p
+    fib-el-trans* (inj₂ _) (mkDeco Q ρd) {x} {y} {z} q p = fib-trans* Q ρd {x = x} {y = y} {z = z} q p
+
+  -- The fibre family of the μ-type at a decorated sort.
+  WFam : ∀ {k} (Q : Poly-C (suc k)) {ρ̄ : Fin k → Fin n ⊎ Sh.Sort n}
+         (d : ∀ i → DecoAssign (ρ̄ i)) → Fam (WSetoid ∣ Q ∣ ρ̄) 𝒞
+  WFam Q d .fm = fib Q d
+  WFam Q d .subst {x} {y} = fib-subst Q d {x = x} {y = y}
+  WFam Q d .refl* {x} = fib-refl* Q d x
+  WFam Q d .trans* {x} {y} {z} e₁ e₂ = fib-trans* Q d {x = x} {y = y} {z = z} e₁ e₂
+
+-- The μ-type at the root sort: index by the category-free sort layer, fibres
+-- by the canonical decoration, which resolves the μ-body's free variables to
+-- the parameters.
+μObj : ∀ {n} → Poly-C (suc n) → (Fin n → Obj) → Obj
+μObj P δ .idx = Sh.Tree.WSetoid (λ i → δ i .idx) ∣ P ∣ (λ i → inj₁ i)
+μObj P δ .fam = Fibre.WFam δ P {ρ̄ = λ i → inj₁ i} (λ i → lift tt)
diff --git a/agda/src/fam-mu-types/fold.agda b/agda/src/fam-mu-types/fold.agda
new file mode 100644
index 00000000..8d4996e6
--- /dev/null
+++ b/agda/src/fam-mu-types/fold.agda
@@ -0,0 +1,219 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- The strong catamorphism: folding a μ-carrier in an ambient context Γ, so no
+-- exponentials are required. FMor is the fold-specific reindex morphism, again
+-- first-order for termination, carrying the decorations of both sides.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_; lift) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Product using (_,_)
+open import Data.Unit using (tt)
+open import prop using (_,_)
+open import categories using (Category; HasTerminal; HasProducts)
+open import prop-setoid as PS using ()
+open import indexed-family using (_⇒f_)
+import fam-mu-types.reindex
+
+module fam-mu-types.fold {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open fam-mu-types.reindex os es T P public
+
+-- The fold (catamorphism) for the μ-type, lifted to a standalone module so its
+-- mutual recursion is termination-checked independently of the `hasMu` copattern.
+module FoldDef {n} {Γ A : Obj} {P : Poly (suc n)} {δ : Fin n → Obj}
+               (alg : Mor (Fam𝒞-P.prod Γ (fobj μObj P (extend δ A))) A) where
+    module Tδ = Tree δ
+    module TA' = Tree (extend δ A)
+    -- Fold-specific reindex morphism (first-order, like `MorD`): `fbase` sends the outer
+    -- recursion slot to the fold and parameters to themselves; `fbind` records a binder.
+    data FMor : ∀ {k} (ρ : Fin k → Fin n ⊎ Sort n) (ρ' : Fin k → Fin (suc n) ⊎ Sort (suc n)) →
+                (∀ v → Tδ.DecoAssign (ρ v)) → (∀ v → TA'.DecoAssign (ρ' v)) →
+                Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+      fbase : FMor (Sh.η₀ ∣ P ∣) (λ v → inj₁ v)
+                   (Tδ.deco-ext P {ρ̄ = λ i → inj₁ i} (λ i → lift tt)) (λ v → lift tt)
+      fbind : ∀ {k} {ρ ρ' d d'} (Q : Poly (suc k)) → FMor ρ ρ' d d' →
+              FMor (extend ρ (inj₂ (mkSort ∣ Q ∣ ρ))) (extend ρ' (inj₂ (mkSort ∣ Q ∣ ρ')))
+                   (Tδ.deco-ext Q d) (TA'.deco-ext Q d')
+    -- Fold the outer μ via `alg`; nested μ are reindexed into the `extend δ A` context,
+    -- the recursion slot carrying the fold itself (inlined, so every call is structural).
+    mutual
+      fold-idx : Γ .idx .Carrier → Tδ.W ∣ P ∣ (λ i → inj₁ i) → A .idx .Carrier
+      fold-idx γ (Tδ.sup x) = alg .idxf .PS._⇒_.func (γ , fold-shape-idx P γ x)
+
+      fold-shape-idx : (Q : Poly (suc n)) → Γ .idx .Carrier → Tδ.⟦ ∣ Q ∣ ⟧shape (Sh.η₀ ∣ P ∣) →
+                      fobj μObj Q (extend δ A) .idx .Carrier
+      fold-shape-idx (const A')        γ a = a
+      fold-shape-idx (var Fin.zero)    γ t = fold-idx γ t
+      fold-shape-idx (var (Fin.suc i)) γ a = a
+      fold-shape-idx (Q₁ + Q₂) γ (inj₁ x) = inj₁ (fold-shape-idx Q₁ γ x)
+      fold-shape-idx (Q₁ + Q₂) γ (inj₂ y) = inj₂ (fold-shape-idx Q₂ γ y)
+      fold-shape-idx (Q₁ × Q₂) γ (x , y) = fold-shape-idx Q₁ γ x , fold-shape-idx Q₂ γ y
+      fold-shape-idx (μ Q')    γ t = fold-reindex {Q = Q'} γ fbase t
+
+      fold-reindex : ∀ {k} {Q : Poly (suc k)} {ρ ρ' d d'} (γ : Γ .idx .Carrier) (fm : FMor ρ ρ' d d') →
+                     Tδ.W ∣ Q ∣ ρ → TA'.W ∣ Q ∣ ρ'
+      fold-reindex {Q = Q} γ fm (Tδ.sup x) = TA'.sup (fold-reindex-shape γ Q (fbind Q fm) x)
+
+      fold-reindex-shape : ∀ {j} (γ : Γ .idx .Carrier) (R : Poly j) {ηA ηB dA dB} (fm : FMor ηA ηB dA dB) →
+                           Tδ.⟦ ∣ R ∣ ⟧shape ηA → TA'.⟦ ∣ R ∣ ⟧shape ηB
+      fold-reindex-shape γ (const A') fm a = a
+      fold-reindex-shape γ (var v)    fm a = fold-apply γ fm v a
+      fold-reindex-shape γ (P' + Q') fm (inj₁ a) = inj₁ (fold-reindex-shape γ P' fm a)
+      fold-reindex-shape γ (P' + Q') fm (inj₂ b) = inj₂ (fold-reindex-shape γ Q' fm b)
+      fold-reindex-shape γ (P' × Q') fm (a , b) = fold-reindex-shape γ P' fm a , fold-reindex-shape γ Q' fm b
+      fold-reindex-shape γ (μ Q'')   fm t = fold-reindex {Q = Q''} γ fm t
+
+      fold-apply : ∀ {k} {ρ ρ' d d'} (γ : Γ .idx .Carrier) (fm : FMor ρ ρ' d d') (v : Fin k) →
+                   Tδ.El (ρ v) → TA'.El (ρ' v)
+      fold-apply γ fbase        Fin.zero    t = fold-idx γ t
+      fold-apply γ fbase        (Fin.suc i) a = a
+      fold-apply γ (fbind Q fm) Fin.zero    a = fold-reindex {Q = Q} γ fm a
+      fold-apply γ (fbind Q fm) (Fin.suc v) a = fold-apply γ fm v a
+
+    -- The index fold respects ≈ (in both Γ and the tree).
+    mutual
+      fold-idx-resp : ∀ {γ γ'} (γ≈ : _≈s_ (Γ .idx) γ γ') {t t'} (p : Tδ.W-≈ t t') →
+                      _≈s_ (A .idx) (fold-idx γ t) (fold-idx γ' t')
+      fold-idx-resp γ≈ {Tδ.sup x} {Tδ.sup y} p = alg .idxf .PS._⇒_.func-resp-≈ (γ≈ , fold-shape-idx-resp P γ≈ p)
+
+      fold-shape-idx-resp : (Q : Poly (suc n)) → ∀ {γ γ'} (γ≈ : _≈s_ (Γ .idx) γ γ') {x x'}
+                           (p : Tδ.shape≈ ∣ Q ∣ (Sh.η₀ ∣ P ∣) x x') →
+                           _≈s_ (fobj μObj Q (extend δ A) .idx) (fold-shape-idx Q γ x) (fold-shape-idx Q γ' x')
+      fold-shape-idx-resp (const A')        γ≈ p = p
+      fold-shape-idx-resp (var Fin.zero)    γ≈ {x} {x'} p = fold-idx-resp γ≈ {x} {x'} p
+      fold-shape-idx-resp (var (Fin.suc i)) γ≈ p = p
+      fold-shape-idx-resp (Q₁ + Q₂) γ≈ {inj₁ _} {inj₁ _} p = fold-shape-idx-resp Q₁ γ≈ p
+      fold-shape-idx-resp (Q₁ + Q₂) γ≈ {inj₂ _} {inj₂ _} p = fold-shape-idx-resp Q₂ γ≈ p
+      fold-shape-idx-resp (Q₁ × Q₂) γ≈ {_ , _} {_ , _} (p₁ , p₂) =
+        fold-shape-idx-resp Q₁ γ≈ p₁ , fold-shape-idx-resp Q₂ γ≈ p₂
+      fold-shape-idx-resp (μ Q')    γ≈ {x} {x'} p = fold-reindex-resp {Q = Q'} γ≈ fbase {x} {x'} p
+
+      fold-reindex-resp : ∀ {k} {Q : Poly (suc k)} {ρ ρ' d d'} {γ γ'} (γ≈ : _≈s_ (Γ .idx) γ γ') (fm : FMor ρ ρ' d d')
+                          {t t' : Tδ.W ∣ Q ∣ ρ} (p : Tδ.W-≈ t t') →
+                          TA'.W-≈ (fold-reindex γ fm t) (fold-reindex γ' fm t')
+      fold-reindex-resp {Q = Q} γ≈ fm {Tδ.sup x} {Tδ.sup y} p = fold-reindex-shape-resp γ≈ Q (fbind Q fm) {x} {y} p
+
+      fold-reindex-shape-resp : ∀ {j} {γ γ'} (γ≈ : _≈s_ (Γ .idx) γ γ') (R : Poly j) {ηA ηB dA dB} (fm : FMor ηA ηB dA dB)
+                                {a a' : Tδ.⟦ ∣ R ∣ ⟧shape ηA} (p : Tδ.shape≈ ∣ R ∣ ηA a a') →
+                                TA'.shape≈ ∣ R ∣ ηB (fold-reindex-shape γ R fm a) (fold-reindex-shape γ' R fm a')
+      fold-reindex-shape-resp γ≈ (const A') fm p = p
+      fold-reindex-shape-resp γ≈ (var v)    fm p = fold-apply-resp γ≈ fm v p
+      fold-reindex-shape-resp γ≈ (P' + Q') fm {inj₁ _} {inj₁ _} p = fold-reindex-shape-resp γ≈ P' fm p
+      fold-reindex-shape-resp γ≈ (P' + Q') fm {inj₂ _} {inj₂ _} p = fold-reindex-shape-resp γ≈ Q' fm p
+      fold-reindex-shape-resp γ≈ (P' × Q') fm {_ , _} {_ , _} (p₁ , p₂) =
+        fold-reindex-shape-resp γ≈ P' fm p₁ , fold-reindex-shape-resp γ≈ Q' fm p₂
+      fold-reindex-shape-resp γ≈ (μ Q'')   fm {a} {a'} p = fold-reindex-resp {Q = Q''} γ≈ fm {a} {a'} p
+
+      fold-apply-resp : ∀ {k} {ρ ρ' d d'} {γ γ'} (γ≈ : _≈s_ (Γ .idx) γ γ') (fm : FMor ρ ρ' d d') (v : Fin k)
+                        {a a'} (p : Tδ.elEq (ρ v) a a') →
+                        TA'.elEq (ρ' v) (fold-apply γ fm v a) (fold-apply γ' fm v a')
+      fold-apply-resp γ≈ fbase        Fin.zero    {a} {a'} p = fold-idx-resp γ≈ {a} {a'} p
+      fold-apply-resp γ≈ fbase        (Fin.suc i) p = p
+      fold-apply-resp γ≈ (fbind Q fm) Fin.zero    {a} {a'} p = fold-reindex-resp {Q = Q} γ≈ fm {a} {a'} p
+      fold-apply-resp γ≈ (fbind Q fm) (Fin.suc v) p = fold-apply-resp γ≈ fm v p
+
+    -- The fibre fold: collapse the tree's fibre via `alg.famf`, threading the Γ-fibre.
+    mutual
+      fold-fam : (γ : Γ .idx .Carrier) (t : Tδ.W ∣ P ∣ (λ i → inj₁ i)) →
+                 prod (Γ .fam .fm γ) (Tδ.fib P (λ i → lift tt) t) ⇒ A .fam .fm (fold-idx γ t)
+      fold-fam γ (Tδ.sup x) =
+        alg .famf ._⇒f_.transf (γ , fold-shape-idx P γ x) ∘ pair p₁ (fold-shape-fam P γ x)
+
+      fold-shape-fam : (Q : Poly (suc n)) (γ : Γ .idx .Carrier) (x : Tδ.⟦ ∣ Q ∣ ⟧shape (Sh.η₀ ∣ P ∣)) →
+                       prod (Γ .fam .fm γ) (Tδ.fib-shape Q (Tδ.deco-ext P (λ i → lift tt)) x)
+                         ⇒ fobj μObj Q (extend δ A) .fam .fm (fold-shape-idx Q γ x)
+      fold-shape-fam (const A')        γ a = p₂
+      fold-shape-fam (var Fin.zero)    γ t = fold-fam γ t
+      fold-shape-fam (var (Fin.suc i)) γ a = p₂
+      fold-shape-fam (Q₁ + Q₂) γ (inj₁ x) = fold-shape-fam Q₁ γ x
+      fold-shape-fam (Q₁ + Q₂) γ (inj₂ y) = fold-shape-fam Q₂ γ y
+      fold-shape-fam (Q₁ × Q₂) γ (x , y) = strong-prod-m (fold-shape-fam Q₁ γ x) (fold-shape-fam Q₂ γ y)
+      fold-shape-fam (μ Q')    γ t = fold-reindex-fam {Q = Q'} γ fbase t
+
+      fold-reindex-fam : ∀ {k} {Q : Poly (suc k)} {ρ ρ' d d'} (γ : Γ .idx .Carrier) (md : FMor ρ ρ' d d') (t : Tδ.W ∣ Q ∣ ρ) →
+                         prod (Γ .fam .fm γ) (Tδ.fib Q d t) ⇒ TA'.fib Q d' (fold-reindex γ md t)
+      fold-reindex-fam {Q = Q} γ md (Tδ.sup x) = fold-reindex-shape-fam γ Q (fbind Q md) x
+
+      fold-reindex-shape-fam : ∀ {j} (γ : Γ .idx .Carrier) (R : Poly j) {ηA ηB dA dB} (md : FMor ηA ηB dA dB) (a : Tδ.⟦ ∣ R ∣ ⟧shape ηA) →
+                               prod (Γ .fam .fm γ) (Tδ.fib-shape R dA a) ⇒ TA'.fib-shape R dB (fold-reindex-shape γ R md a)
+      fold-reindex-shape-fam γ (const A') md a = p₂
+      fold-reindex-shape-fam γ (var v)    md a = fold-apply-fam γ md v a
+      fold-reindex-shape-fam γ (P' + Q') md (inj₁ a) = fold-reindex-shape-fam γ P' md a
+      fold-reindex-shape-fam γ (P' + Q') md (inj₂ b) = fold-reindex-shape-fam γ Q' md b
+      fold-reindex-shape-fam γ (P' × Q') md (a , b) =
+        strong-prod-m (fold-reindex-shape-fam γ P' md a) (fold-reindex-shape-fam γ Q' md b)
+      fold-reindex-shape-fam γ (μ Q'')   md t = fold-reindex-fam {Q = Q''} γ md t
+
+      fold-apply-fam : ∀ {k} {ρ ρ' d d'} (γ : Γ .idx .Carrier) (md : FMor ρ ρ' d d') (v : Fin k) (a : Tδ.El (ρ v)) →
+                       prod (Γ .fam .fm γ) (Tδ.fib-el (ρ v) (d v) a) ⇒ TA'.fib-el (ρ' v) (d' v) (fold-apply γ md v a)
+      fold-apply-fam γ fbase        Fin.zero    t = fold-fam γ t
+      fold-apply-fam γ fbase        (Fin.suc i) a = p₂
+      fold-apply-fam γ (fbind Q md) Fin.zero    a = fold-reindex-fam {Q = Q} γ md a
+      fold-apply-fam γ (fbind Q md) (Fin.suc v) a = fold-apply-fam γ md v a
+
+    -- The fibre fold is natural: it commutes with `subst` (in both Γ and the tree).
+    mutual
+      fold-fam-natural : ∀ {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {t t'} (p : Tδ.W-≈ t t') →
+                         fold-fam γ₂ t' ∘ prod-m (Γ .fam .subst γ≈) (Tδ.fib-subst P (λ i → lift tt) {x = t} {y = t'} p) ≈
+                         A .fam .subst (fold-idx-resp γ≈ {t} {t'} p) ∘ fold-fam γ₁ t
+      fold-fam-natural {γ₁} {γ₂} γ≈ {Tδ.sup x} {Tδ.sup y} p =
+        ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong ≈-refl (pair-natural _ _ _))
+        (≈-trans (∘-cong ≈-refl (pair-cong (pair-p₁ _ _) (fold-shape-fam-natural P γ≈ {x} {y} p)))
+        (≈-trans (∘-cong ≈-refl (≈-sym (pair-compose _ _ _ _)))
+        (≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong (alg .famf ._⇒f_.natural (γ≈ , fold-shape-idx-resp P γ≈ {x} {y} p)) ≈-refl)
+                 (assoc _ _ _))))))
+
+      fold-shape-fam-natural : (Q : Poly (suc n)) → ∀ {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {x x'}
+                               (p : Tδ.shape≈ ∣ Q ∣ (Sh.η₀ ∣ P ∣) x x') →
+                               fold-shape-fam Q γ₂ x' ∘ prod-m (Γ .fam .subst γ≈) (Tδ.fib-shape-subst Q (Tδ.deco-ext P (λ i → lift tt)) p) ≈
+                               fobj μObj Q (extend δ A) .fam .subst (fold-shape-idx-resp Q γ≈ p) ∘ fold-shape-fam Q γ₁ x
+      fold-shape-fam-natural (const A')        γ≈ p = pair-p₂ _ _
+      fold-shape-fam-natural (var Fin.zero)    γ≈ {x} {x'} p = fold-fam-natural γ≈ {x} {x'} p
+      fold-shape-fam-natural (var (Fin.suc i)) γ≈ p = pair-p₂ _ _
+      fold-shape-fam-natural (Q₁ + Q₂) γ≈ {inj₁ _} {inj₁ _} p = fold-shape-fam-natural Q₁ γ≈ p
+      fold-shape-fam-natural (Q₁ + Q₂) γ≈ {inj₂ _} {inj₂ _} p = fold-shape-fam-natural Q₂ γ≈ p
+      fold-shape-fam-natural (Q₁ × Q₂) γ≈ {x₁ , x₂} {x₁' , x₂'} (p₁p , p₂p) =
+        strong-prod-m-natural (fold-shape-fam-natural Q₁ γ≈ p₁p) (fold-shape-fam-natural Q₂ γ≈ p₂p)
+      fold-shape-fam-natural (μ Q')    γ≈ {x} {x'} p = fold-reindex-fam-natural {Q = Q'} γ≈ fbase {x} {x'} p
+
+      fold-reindex-fam-natural : ∀ {k} {Q : Poly (suc k)} {ρ ρ' d d'} {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂)
+                             (md : FMor ρ ρ' d d') {t t' : Tδ.W ∣ Q ∣ ρ} (p : Tδ.W-≈ t t') →
+                             (fold-reindex-fam γ₂ md t' ∘ prod-m (Γ .fam .subst γ≈) (Tδ.fib-subst Q d {x = t} {y = t'} p))
+                               ≈ (TA'.fib-subst Q d' {x = fold-reindex γ₁ md t} {y = fold-reindex γ₂ md t'}
+                                                (fold-reindex-resp γ≈ md {t} {t'} p) ∘ fold-reindex-fam γ₁ md t)
+      fold-reindex-fam-natural {Q = Q} γ≈ md {Tδ.sup x} {Tδ.sup y} p = fold-reindex-shape-fam-natural γ≈ Q (fbind Q md) {x} {y} p
+
+      fold-reindex-shape-fam-natural : ∀ {j} {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) (R : Poly j) {ηA ηB dA dB} (md : FMor ηA ηB dA dB)
+                                   {a a' : Tδ.⟦ ∣ R ∣ ⟧shape ηA} (p : Tδ.shape≈ ∣ R ∣ ηA a a') →
+                                   (fold-reindex-shape-fam γ₂ R md a' ∘ prod-m (Γ .fam .subst γ≈) (Tδ.fib-shape-subst R dA p))
+                                     ≈ (TA'.fib-shape-subst R dB (fold-reindex-shape-resp γ≈ R md p) ∘ fold-reindex-shape-fam γ₁ R md a)
+      fold-reindex-shape-fam-natural γ≈ (const A') md p = pair-p₂ _ _
+      fold-reindex-shape-fam-natural γ≈ (var v)    md p = fold-apply-fam-natural γ≈ md v p
+      fold-reindex-shape-fam-natural γ≈ (P' + Q') md {inj₁ _} {inj₁ _} p = fold-reindex-shape-fam-natural γ≈ P' md p
+      fold-reindex-shape-fam-natural γ≈ (P' + Q') md {inj₂ _} {inj₂ _} p = fold-reindex-shape-fam-natural γ≈ Q' md p
+      fold-reindex-shape-fam-natural γ≈ (P' × Q') md {a₁ , a₂} {a₁' , a₂'} (p₁p , p₂p) =
+        strong-prod-m-natural (fold-reindex-shape-fam-natural γ≈ P' md p₁p) (fold-reindex-shape-fam-natural γ≈ Q' md p₂p)
+      fold-reindex-shape-fam-natural γ≈ (μ Q'')   md {a} {a'} p = fold-reindex-fam-natural {Q = Q''} γ≈ md {a} {a'} p
+
+      fold-apply-fam-natural : ∀ {k} {ρ ρ' d d'} {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) (md : FMor ρ ρ' d d') (v : Fin k)
+                               {a a'} (p : Tδ.elEq (ρ v) a a') →
+                               fold-apply-fam γ₂ md v a' ∘ prod-m (Γ .fam .subst γ≈) (Tδ.fib-el-subst (ρ v) (d v) p) ≈
+                               TA'.fib-el-subst (ρ' v) (d' v) (fold-apply-resp γ≈ md v p) ∘ fold-apply-fam γ₁ md v a
+      fold-apply-fam-natural γ≈ fbase        Fin.zero    {a} {a'} p = fold-fam-natural γ≈ {a} {a'} p
+      fold-apply-fam-natural γ≈ fbase        (Fin.suc i) p = pair-p₂ _ _
+      fold-apply-fam-natural γ≈ (fbind Q md) Fin.zero    {a} {a'} p = fold-reindex-fam-natural {Q = Q} γ≈ md {a} {a'} p
+      fold-apply-fam-natural γ≈ (fbind Q md) (Fin.suc v) p = fold-apply-fam-natural γ≈ md v p
+
+    foldMor : Mor (Fam𝒞-P.prod Γ (μObj P δ)) A
+    foldMor .idxf .PS._⇒_.func (γ , t) = fold-idx γ t
+    foldMor .idxf .PS._⇒_.func-resp-≈ {γ , t} {γ' , t'} (γ≈ , t≈) = fold-idx-resp γ≈ {t} {t'} t≈
+    foldMor .famf ._⇒f_.transf (γ , t) = fold-fam γ t
+    foldMor .famf ._⇒f_.natural {γ₁ , t₁} {γ₂ , t₂} (γ≈ , t≈) = fold-fam-natural γ≈ {t₁} {t₂} t≈
diff --git a/agda/src/fam-mu-types/in-map.agda b/agda/src/fam-mu-types/in-map.agda
new file mode 100644
index 00000000..0e2c2157
--- /dev/null
+++ b/agda/src/fam-mu-types/in-map.agda
@@ -0,0 +1,160 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- inMap, the canonical iso between the categorical one-step unfolding
+-- fobj P (δ, μ P δ) and the concrete carrier, via the embed/unembed bridges;
+-- packaged with the fold as the HasMu instance.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_; lift) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Product using (_,_)
+open import Data.Unit using (tt)
+open import prop using (_,_)
+open import categories using (Category; HasTerminal; HasProducts)
+open import prop-setoid as PS using ()
+open import indexed-family using (_⇒f_)
+import fam-mu-types.fold
+
+module fam-mu-types.in-map {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open fam-mu-types.fold os es T P public
+
+-- α's reconstruction machinery.
+module InMapDef {n} (P : Poly (suc n)) (δ : Fin n → Obj) where
+    δ' = extend δ (μObj P δ)
+    module Tδ = Tree δ
+    module TX = Tree δ'
+    module R  = Reindex δ' δ
+
+    -- Bridge `fobj`'s native structure to our `⟦_⟧shape` (identity at leaves and μ).
+    embed-idx : (Q : Poly (suc n)) → fobj μObj Q δ' .idx .Carrier → TX.⟦ ∣ Q ∣ ⟧shape (λ v → inj₁ v)
+    embed-idx (const A) a = a
+    embed-idx (var v)   a = a
+    embed-idx (Q₁ + Q₂) (inj₁ x) = inj₁ (embed-idx Q₁ x)
+    embed-idx (Q₁ + Q₂) (inj₂ y) = inj₂ (embed-idx Q₂ y)
+    embed-idx (Q₁ × Q₂) (x , y) = embed-idx Q₁ x , embed-idx Q₂ y
+    embed-idx (μ Q')    t = t
+    embed-idx-resp : (Q : Poly (suc n)) {x y : fobj μObj Q δ' .idx .Carrier} →
+                     _≈s_ (fobj μObj Q δ' .idx) x y → TX.shape≈ ∣ Q ∣ (λ v → inj₁ v) (embed-idx Q x) (embed-idx Q y)
+    embed-idx-resp (const A) p = p
+    embed-idx-resp (var v)   p = p
+    embed-idx-resp (Q₁ + Q₂) {inj₁ _} {inj₁ _} p = embed-idx-resp Q₁ p
+    embed-idx-resp (Q₁ + Q₂) {inj₂ _} {inj₂ _} p = embed-idx-resp Q₂ p
+    embed-idx-resp (Q₁ × Q₂) {_ , _} {_ , _} (p₁ , p₂) = embed-idx-resp Q₁ p₁ , embed-idx-resp Q₂ p₂
+    embed-idx-resp (μ Q')    p = p
+    -- Inverse bridge: `⟦_⟧shape` over the fresh context back to `fobj`'s native
+    -- structure (identity at leaves and μ, like `embed-idx`).
+    unembed-idx : (Q : Poly (suc n)) → TX.⟦ ∣ Q ∣ ⟧shape (λ v → inj₁ v) → fobj μObj Q δ' .idx .Carrier
+    unembed-idx (const A) a = a
+    unembed-idx (var v)   a = a
+    unembed-idx (Q₁ + Q₂) (inj₁ x) = inj₁ (unembed-idx Q₁ x)
+    unembed-idx (Q₁ + Q₂) (inj₂ y) = inj₂ (unembed-idx Q₂ y)
+    unembed-idx (Q₁ × Q₂) (x , y) = unembed-idx Q₁ x , unembed-idx Q₂ y
+    unembed-idx (μ Q')    t = t
+
+    unembed-idx-resp : (Q : Poly (suc n)) {x y : TX.⟦ ∣ Q ∣ ⟧shape (λ v → inj₁ v)} →
+                       TX.shape≈ ∣ Q ∣ (λ v → inj₁ v) x y →
+                       _≈s_ (fobj μObj Q δ' .idx) (unembed-idx Q x) (unembed-idx Q y)
+    unembed-idx-resp (const A) p = p
+    unembed-idx-resp (var v)   p = p
+    unembed-idx-resp (Q₁ + Q₂) {inj₁ _} {inj₁ _} p = unembed-idx-resp Q₁ p
+    unembed-idx-resp (Q₁ + Q₂) {inj₂ _} {inj₂ _} p = unembed-idx-resp Q₂ p
+    unembed-idx-resp (Q₁ × Q₂) {_ , _} {_ , _} (p₁ , p₂) = unembed-idx-resp Q₁ p₁ , unembed-idx-resp Q₂ p₂
+    unembed-idx-resp (μ Q')    p = p
+
+    -- Embedding after unembedding is the identity.
+    embed-unembed : (Q : Poly (suc n)) (x : TX.⟦ ∣ Q ∣ ⟧shape (λ v → inj₁ v)) →
+                    TX.shape≈ ∣ Q ∣ (λ v → inj₁ v) (embed-idx Q (unembed-idx Q x)) x
+    embed-unembed (const A) a = A .idx .isEquivalence .refl
+    embed-unembed (var v)   a = TX.elEq-refl (inj₁ v) a
+    embed-unembed (Q₁ + Q₂) (inj₁ x) = embed-unembed Q₁ x
+    embed-unembed (Q₁ + Q₂) (inj₂ y) = embed-unembed Q₂ y
+    embed-unembed (Q₁ × Q₂) (x , y) = embed-unembed Q₁ x , embed-unembed Q₂ y
+    embed-unembed (μ Q')    t = TX.W-≈-refl t
+
+    m₀ : ∀ v → TX.El (inj₁ v) → Tδ.El (Sh.η₀ ∣ P ∣ v)
+    m₀ Fin.zero    a = a
+    m₀ (Fin.suc i) a = a
+    m₀-resp : ∀ v {a a'} → TX.elEq (inj₁ v) a a' → Tδ.elEq (Sh.η₀ ∣ P ∣ v) (m₀ v a) (m₀ v a')
+    m₀-resp Fin.zero    p = p
+    m₀-resp (Fin.suc i) p = p
+    m₀-fam : ∀ v (a : TX.El (inj₁ v)) →
+             TX.fib-el (inj₁ v) (lift tt) a ⇒ Tδ.fib-el (Sh.η₀ ∣ P ∣ v) (Tδ.deco-ext P (λ i → lift tt) v) (m₀ v a)
+    m₀-fam Fin.zero    a = id _
+    m₀-fam (Fin.suc i) a = id _
+    m₀-fam-natural : ∀ v {a a'} (p : TX.elEq (inj₁ v) a a') →
+                 (m₀-fam v a' ∘ TX.fib-el-subst (inj₁ v) (lift tt) p)
+                   ≈ (Tδ.fib-el-subst (Sh.η₀ ∣ P ∣ v) (Tδ.deco-ext P (λ i → lift tt) v) (m₀-resp v p) ∘ m₀-fam v a)
+    m₀-fam-natural Fin.zero    p = ≈-trans id-left (≈-sym id-right)
+    m₀-fam-natural (Fin.suc i) p = ≈-trans id-left (≈-sym id-right)
+    mor₀ : R.MorD (λ v → inj₁ v) (Sh.η₀ ∣ P ∣) (λ v → lift tt) (Tδ.deco-ext P (λ i → lift tt))
+    mor₀ = R.base m₀ m₀-resp m₀-fam m₀-fam-natural
+    -- Fibre bridge: `fobj`'s fibre to our `fib-shape` (identity at leaves, products at ×).
+    embed-fam : (Q : Poly (suc n)) (x : fobj μObj Q δ' .idx .Carrier) →
+                fobj μObj Q δ' .fam .fm x ⇒ TX.fib-shape Q (λ v → lift tt) (embed-idx Q x)
+    embed-fam (const A) a = id _
+    embed-fam (var v)   a = id _
+    embed-fam (Q₁ + Q₂) (inj₁ x) = embed-fam Q₁ x
+    embed-fam (Q₁ + Q₂) (inj₂ y) = embed-fam Q₂ y
+    embed-fam (Q₁ × Q₂) (x , y) = prod-m (embed-fam Q₁ x) (embed-fam Q₂ y)
+    embed-fam (μ Q')    t = id _
+    embed-fam-natural : (Q : Poly (suc n)) {x y : fobj μObj Q δ' .idx .Carrier} (e : _≈s_ (fobj μObj Q δ' .idx) x y) →
+                        (embed-fam Q y ∘ fobj μObj Q δ' .fam .subst e)
+                          ≈ (TX.fib-shape-subst Q (λ v → lift tt) (embed-idx-resp Q e) ∘ embed-fam Q x)
+    embed-fam-natural (const A) e = ≈-trans id-left (≈-sym id-right)
+    embed-fam-natural (var v)   e = ≈-trans id-left (≈-sym id-right)
+    embed-fam-natural (Q₁ + Q₂) {inj₁ _} {inj₁ _} e = embed-fam-natural Q₁ e
+    embed-fam-natural (Q₁ + Q₂) {inj₂ _} {inj₂ _} e = embed-fam-natural Q₂ e
+    embed-fam-natural (Q₁ × Q₂) {_ , _} {_ , _} (e₁ , e₂) =
+      ≈-trans (≈-sym (prod-m-comp _ _ _ _))
+      (≈-trans (prod-m-cong (embed-fam-natural Q₁ e₁) (embed-fam-natural Q₂ e₂)) (prod-m-comp _ _ _ _))
+    embed-fam-natural (μ Q')    e = ≈-trans id-left (≈-sym id-right)
+
+    -- Fibre half of the inverse bridge.
+    unembed-fam : (Q : Poly (suc n)) (y : TX.⟦ ∣ Q ∣ ⟧shape (λ v → inj₁ v)) →
+                  TX.fib-shape Q (λ v → lift tt) y ⇒ fobj μObj Q δ' .fam .fm (unembed-idx Q y)
+    unembed-fam (const A) a = id _
+    unembed-fam (var v)   a = id _
+    unembed-fam (Q₁ + Q₂) (inj₁ x) = unembed-fam Q₁ x
+    unembed-fam (Q₁ + Q₂) (inj₂ y) = unembed-fam Q₂ y
+    unembed-fam (Q₁ × Q₂) (x , y) = prod-m (unembed-fam Q₁ x) (unembed-fam Q₂ y)
+    unembed-fam (μ Q')    t = id _
+
+    -- Embedding after unembedding is the identity on fibres too.
+    embed-unembed-fam : (Q : Poly (suc n)) (y : TX.⟦ ∣ Q ∣ ⟧shape (λ v → inj₁ v)) →
+                        (TX.fib-shape-subst Q (λ v → lift tt) (embed-unembed Q y)
+                         ∘ (embed-fam Q (unembed-idx Q y) ∘ unembed-fam Q y))
+                        ≈ id _
+    embed-unembed-fam (const A) a =
+      ≈-trans (∘-cong (A .fam .refl*) ≈-refl) (≈-trans id-left id-left)
+    embed-unembed-fam (var v) a =
+      ≈-trans (∘-cong (TX.fib-el-refl* (inj₁ v) (lift tt) a) ≈-refl) (≈-trans id-left id-left)
+    embed-unembed-fam (Q₁ + Q₂) (inj₁ x) = embed-unembed-fam Q₁ x
+    embed-unembed-fam (Q₁ + Q₂) (inj₂ y) = embed-unembed-fam Q₂ y
+    embed-unembed-fam (Q₁ × Q₂) (x , y) =
+      ≈-trans (∘-cong ≈-refl (≈-sym (prod-m-comp _ _ _ _)))
+        (≈-trans (≈-sym (prod-m-comp _ _ _ _))
+          (≈-trans (prod-m-cong (embed-unembed-fam Q₁ x) (embed-unembed-fam Q₂ y)) prod-m-id))
+    embed-unembed-fam (μ Q') t =
+      ≈-trans (∘-cong (TX.fib-refl* Q' (λ v → lift tt) t) ≈-refl) (≈-trans id-left id-left)
+
+    inMor : Mor (fobj μObj P δ') (μObj P δ)
+    inMor .idxf .PS._⇒_.func i = Tδ.sup (R.reindex-shape ∣ P ∣ mor₀ (embed-idx P i))
+    inMor .idxf .PS._⇒_.func-resp-≈ x≈y = R.reindex-shape-resp ∣ P ∣ mor₀ (embed-idx-resp P x≈y)
+    inMor .famf ._⇒f_.transf x = R.reindex-fam P mor₀ ∘ embed-fam P x
+    inMor .famf ._⇒f_.natural e =
+      ≈-trans (assoc _ _ _)
+      (≈-trans (∘-cong₂ (embed-fam-natural P e))
+      (≈-trans (≈-sym (assoc _ _ _))
+      (≈-trans (∘-cong₁ (R.reindex-fam-natural P mor₀ (embed-idx-resp P e)))
+               (assoc _ _ _))))
+
+hasMu : HasMu
+hasMu .HasMu.μ-obj = μObj
+hasMu .HasMu.inMap P δ = InMapDef.inMor P δ
+hasMu .HasMu.⦅_⦆ alg = FoldDef.foldMor alg
diff --git a/agda/src/fam-mu-types/reindex-fusion.agda b/agda/src/fam-mu-types/reindex-fusion.agda
new file mode 100644
index 00000000..860336b3
--- /dev/null
+++ b/agda/src/fam-mu-types/reindex-fusion.agda
@@ -0,0 +1,380 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- Free-family fusion: a single index-only reindex along a pointwise family
+-- equals the strong functorial action of the family, on indices (fuse-idx) and
+-- fibres (fuse-fam). The workhorse naturality lemma for the nested-μ cases of
+-- both initial-algebra laws.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_; lift) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Product using (_,_)
+open import Data.Unit using (tt)
+open import prop using (_,_)
+open import categories using (Category; HasTerminal; HasProducts)
+open import prop-setoid as PS using ()
+open import indexed-family using (_⇒f_)
+import fam-mu-types.in-map
+
+module fam-mu-types.reindex-fusion {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open fam-mu-types.in-map os es T P public
+
+-- General free-family fusion: a single reindex (the collapsed double-reindex, via combine-lemma)
+-- equals the functorial map. Families sₛ/sₜ are FREE so the nested-μ recursion's family fits.
+fuse-idx : ∀ {n} {Γ : Obj} {sₛ sₜ : Fin n → Obj} (Q : Poly (suc n)) →
+               let module Rs = Reindex sₛ sₜ in
+               (cmb : Γ .idx .Carrier → Rs.IMorD (λ v → inj₁ v) (λ v → inj₁ v))
+               (fsk : ∀ i → Mor (Fam𝒞-P.prod Γ (sₛ i)) (sₜ i))
+               (corr : ∀ i {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {a₁ a₂} (a≈ : _≈s_ (sₛ i .idx) a₁ a₂) →
+                       _≈s_ (sₜ i .idx) (Rs.iapply (cmb γ₁) i a₁) (fsk i .idxf .PS._⇒_.func (γ₂ , a₂))) →
+               ∀ {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {m₁ m₂}
+               (m≈ : _≈s_ (μObj Q sₛ .idx) m₁ m₂) →
+               _≈s_ (μObj Q sₜ .idx) (Rs.ireindex (cmb γ₁) m₁) (HasMu.strong-fmor hasMu (μ Q) fsk .idxf .PS._⇒_.func (γ₂ , m₂))
+fuse-shape : ∀ {n} {Γ : Obj} {sₛ sₜ : Fin n → Obj} (Q : Poly (suc n)) →
+                 let module Rs = Reindex sₛ sₜ
+                     module Ts = Tree sₛ
+                     module Tt = Tree sₜ
+                     module At = InMapDef Q sₜ in
+                 (cmb : Γ .idx .Carrier → Rs.IMorD (λ v → inj₁ v) (λ v → inj₁ v))
+                 (fsk : ∀ i → Mor (Fam𝒞-P.prod Γ (sₛ i)) (sₜ i))
+                 (corr : ∀ i {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {a₁ a₂} (a≈ : _≈s_ (sₛ i .idx) a₁ a₂) →
+                         _≈s_ (sₜ i .idx) (Rs.iapply (cmb γ₁) i a₁) (fsk i .idxf .PS._⇒_.func (γ₂ , a₂))) →
+                 let module Ft = FoldDef {Γ = Γ} {A = μObj Q sₜ} {P = Q} {δ = sₛ}
+                                   (Mor-∘ At.inMor (HasMu.strong-fmor hasMu Q (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂))) in
+                 (R : Poly (suc n)) →
+                 ∀ {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {x₁ x₂}
+                 (x≈ : Ts.shape≈ ∣ R ∣ (Sh.η₀ ∣ Q ∣) x₁ x₂) →
+                 Tt.shape≈ ∣ R ∣ (Sh.η₀ ∣ Q ∣)
+                   (Rs.ireindex-shape ∣ R ∣ (Rs.ibind ∣ Q ∣ (cmb γ₁)) x₁)
+                   (At.R.reindex-shape ∣ R ∣ At.mor₀
+                    (At.embed-idx R (HasMu.strong-fmor hasMu R (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂) .idxf .PS._⇒_.func
+                      (γ₂ , Ft.fold-shape-idx R γ₂ x₂))))
+
+fuse-idx Q cmb fsk corr γ≈ {Tree.sup x₁} {Tree.sup x₂} m≈ = fuse-shape Q cmb fsk corr Q γ≈ {x₁} {x₂} m≈
+
+fuse-shape Q cmb fsk corr (const A')                  γ≈ x≈ = x≈
+fuse-shape Q cmb fsk corr (var Fin.zero)              γ≈ {x₁} {x₂} x≈ = fuse-idx Q cmb fsk corr γ≈ {x₁} {x₂} x≈
+fuse-shape Q cmb fsk corr (var (Fin.suc i))           γ≈ x≈ = corr i γ≈ x≈
+fuse-shape Q cmb fsk corr (R₁ + R₂) γ≈ {inj₁ _} {inj₁ _} x≈ = fuse-shape Q cmb fsk corr R₁ γ≈ x≈
+fuse-shape Q cmb fsk corr (R₁ + R₂) γ≈ {inj₂ _} {inj₂ _} x≈ = fuse-shape Q cmb fsk corr R₂ γ≈ x≈
+fuse-shape Q cmb fsk corr (R₁ × R₂) γ≈ {_ , _} {_ , _} (x≈₁ , x≈₂) =
+  fuse-shape Q cmb fsk corr R₁ γ≈ x≈₁ , fuse-shape Q cmb fsk corr R₂ γ≈ x≈₂
+fuse-shape {Γ = Γ} {sₛ = sₛ} {sₜ = sₜ} Q cmb fsk corr (μ R'') {γ₁} {γ₂} γ≈ {x₁} {x₂} x≈ =
+  Tt.W-≈-trans {x = Rs.ireindex-shape ∣ μ R'' ∣ (Rs.ibind ∣ Q ∣ (cmb γ₁)) x₁}
+               {z = At.R.reindex-shape ∣ μ R'' ∣ At.mor₀ (At.embed-idx (μ R'')
+                      (HasMu.strong-fmor hasMu (μ R'') (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂)
+                        .idxf .PS._⇒_.func (γ₂ , w)))}
+               telescope
+               (At.R.reindex-resp At.mor₀
+                 {t = Rs'.ireindex (cmb' γ₁) wm₁}
+                 {t' = HasMu.strong-fmor hasMu (μ R'') (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂) .idxf .PS._⇒_.func (γ₂ , w)}
+                 rec)
+  where
+    module Tt = Tree sₜ
+    module Ts = Tree sₛ
+    module At = InMapDef Q sₜ
+    module Rs = Reindex sₛ sₜ
+    module Rs' = Reindex (extend sₛ (μObj Q sₜ)) (extend sₜ (μObj Q sₜ))
+    module Ft = FoldDef {Γ = Γ} {A = μObj Q sₜ} {P = Q} {δ = sₛ}
+                  (Mor-∘ At.inMor (HasMu.strong-fmor hasMu Q (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂)))
+    wm₁ = Ft.fold-reindex {Q = R''} γ₁ Ft.fbase x₁
+    w   = Ft.fold-reindex {Q = R''} γ₂ Ft.fbase x₂
+    cmb' : Γ .idx .Carrier → Rs'.IMorD (λ v → inj₁ v) (λ v → inj₁ v)
+    cmb' γ = Rs'.ibase (λ { Fin.zero a → a ; (Fin.suc i) a → Rs.iapply (cmb γ) i a })
+                       (λ { Fin.zero p → p ; (Fin.suc i) p → Rs.iapply-resp (cmb γ) i p })
+    rec : _≈s_ (μObj R'' (extend sₜ (μObj Q sₜ)) .idx)
+               (Rs'.ireindex (cmb' γ₁) wm₁)
+               (HasMu.strong-fmor hasMu (μ R'') (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂) .idxf .PS._⇒_.func (γ₂ , w))
+    rec = fuse-idx R'' cmb' (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂)
+            (λ { Fin.zero γ≈ a≈ → a≈ ; (Fin.suc j) γ≈ a≈ → corr j γ≈ a≈ })
+            γ≈ {m₁ = wm₁} {m₂ = w}  (Ft.fold-reindex-resp {Q = R''} γ≈ Ft.fbase {x₁} {x₂} x≈)
+    mutual
+      data TeleRel : ∀ {j} {ηA ηB ηC ηD}
+                     {dA : ∀ v → Ts.DecoAssign (ηA v)} {dB : ∀ v → Tt.DecoAssign (ηB v)}
+                     {dC : ∀ v → At.TX.DecoAssign (ηC v)} {dD : ∀ v → Ft.TA'.DecoAssign (ηD v)} →
+                     Rs.IMorD {j} ηA ηB → At.R.MorD {j} ηC ηB dC dB → Rs'.IMorD {j} ηD ηC → Ft.FMor {j} ηA ηD dA dD →
+                     Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+        tbase : TeleRel (Rs.ibind ∣ Q ∣ (cmb γ₁)) At.mor₀ (cmb' γ₁) Ft.fbase
+        tbind : ∀ {j} {ηA ηB ηC ηD} {dA dB dC dD} {md mdA md' fm} (S' : Poly (suc j)) →
+                TeleRel {j} {ηA} {ηB} {ηC} {ηD} {dA} {dB} {dC} {dD} md mdA md' fm →
+                TeleRel (Rs.ibind ∣ S' ∣ md) (At.R.bind S' mdA) (Rs'.ibind ∣ S' ∣ md') (Ft.fbind S' fm)
+
+      tele-shape : ∀ {j} (S : Poly j) {ηA ηB ηC ηD} {dA dB dC dD}
+                   {md : Rs.IMorD ηA ηB} {mdA : At.R.MorD ηC ηB dC dB} {md' : Rs'.IMorD ηD ηC} {fm : Ft.FMor ηA ηD dA dD}
+                   (rel : TeleRel md mdA md' fm) (z : Ft.Tδ.⟦ ∣ S ∣ ⟧shape ηA) →
+                   Tt.shape≈ ∣ S ∣ ηB
+                     (Rs.ireindex-shape ∣ S ∣ md z)
+                     (At.R.reindex-shape ∣ S ∣ mdA (Rs'.ireindex-shape ∣ S ∣ md' (Ft.fold-reindex-shape γ₁ S fm z)))
+      tele-shape (const A') rel z = A' .idx .isEquivalence .refl
+      tele-shape (var v) rel z = tele-apply rel v
+      tele-shape (S₁ + S₂) rel (inj₁ z) = tele-shape S₁ rel z
+      tele-shape (S₁ + S₂) rel (inj₂ z) = tele-shape S₂ rel z
+      tele-shape (S₁ × S₂) rel (z₁ , z₂) = tele-shape S₁ rel z₁ , tele-shape S₂ rel z₂
+      tele-shape (μ S') rel (Ts.sup z') = tele-shape S' (tbind S' rel) z'
+
+      tele-apply : ∀ {j} {ηA ηB ηC ηD} {dA dB dC dD}
+                   {md : Rs.IMorD ηA ηB} {mdA : At.R.MorD ηC ηB dC dB} {md' : Rs'.IMorD ηD ηC} {fm : Ft.FMor ηA ηD dA dD}
+                   (rel : TeleRel md mdA md' fm) (v : Fin j) {z} →
+                   Tt.elEq (ηB v) (Rs.iapply md v z) (At.R.apply mdA v (Rs'.iapply md' v (Ft.fold-apply γ₁ fm v z)))
+      tele-apply (tbind S' r) Fin.zero    {z} = tele-shape (μ S') r z
+      tele-apply (tbind S' r) (Fin.suc v)     = tele-apply r v
+      tele-apply tbase Fin.zero    {z} =
+        fuse-idx Q cmb fsk corr (Γ .idx .isEquivalence .refl {γ₁}) {m₁ = z} {m₂ = z}
+          (μObj Q sₛ .idx .isEquivalence .refl {z})
+      tele-apply tbase (Fin.suc i) {z} = Tt.elEq-refl (inj₁ i) (Rs.iapply (cmb γ₁) i z)
+
+    telescope : Tt.W-≈ (Rs.ireindex-shape ∣ μ R'' ∣ (Rs.ibind ∣ Q ∣ (cmb γ₁)) x₁)
+                       (At.R.reindex At.mor₀ (Rs'.ireindex (cmb' γ₁) wm₁))
+    telescope = tele-shape (μ R'') tbase x₁
+
+-- Fibre analogue of `fuse-idx`: the fibre reindex (via the external fold action `act`) equals the strong
+-- functorial action's fibre, transported along the index fusion. Mirrors `fuse-idx`'s interface so the
+-- μ-recursion can build nested index equations, plus the fibre `act`/`corr-fam` (at the fixed `γ`).
+fuse-fam : ∀ {n} {Γ : Obj} (γ : Γ .idx .Carrier) {sₛ sₜ : Fin n → Obj} (Q : Poly (suc n)) →
+               let module Rs = Reindex sₛ sₜ
+                   module FR = FReindex {δA = sₛ} {δB = sₜ} (Γ .fam .fm γ) in
+               (cmb : Γ .idx .Carrier → Rs.IMorD (λ v → inj₁ v) (λ v → inj₁ v))
+               (act : FR.FAct (cmb γ) (λ v → lift tt) (λ v → lift tt))
+               (fsk : ∀ i → Mor (Fam𝒞-P.prod Γ (sₛ i)) (sₜ i))
+               (corr : ∀ i {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {a₁ a₂} (a≈ : _≈s_ (sₛ i .idx) a₁ a₂) →
+                       _≈s_ (sₜ i .idx) (Rs.iapply (cmb γ₁) i a₁) (fsk i .idxf .PS._⇒_.func (γ₂ , a₂)))
+               (corr-fam : ∀ i {a} →
+                  Category._≈_ 𝒞
+                    (sₜ i .fam .subst (corr i (Γ .idx .isEquivalence .refl) (sₛ i .idx .isEquivalence .refl {a}))
+                     ∘ FR.aapply act i a)
+                    (fsk i .famf ._⇒f_.transf (γ , a))) →
+               ∀ {m} →
+               Category._≈_ 𝒞
+                 (μObj Q sₜ .fam .subst {x = Rs.ireindex (cmb γ) m}
+                    (fuse-idx Q cmb fsk corr (Γ .idx .isEquivalence .refl)
+                      {m} {m} (μObj Q sₛ .idx .isEquivalence .refl {m}))
+                  ∘ FR.freindex-fam act {m})
+                 (HasMu.strong-fmor hasMu (μ Q) fsk .famf ._⇒f_.transf (γ , m))
+
+-- Shape-level recursion for `fuse-fam` (mirrors `fuse-shape`): the fibre reindex of
+-- the μ-body sub-poly `R` equals the embed ∘ reindex ∘ strong ∘ fold fibre composite.
+fuse-shape-fam : ∀ {n} {Γ : Obj} (γ : Γ .idx .Carrier) {sₛ sₜ : Fin n → Obj} (Q : Poly (suc n)) →
+                     let module Rs = Reindex sₛ sₜ
+                         module Ts = Tree sₛ
+                         module Tt = Tree sₜ
+                         module At = InMapDef Q sₜ
+                         module FR = FReindex {δA = sₛ} {δB = sₜ} (Γ .fam .fm γ) in
+                     (cmb : Γ .idx .Carrier → Rs.IMorD (λ v → inj₁ v) (λ v → inj₁ v))
+                     (act : FR.FAct (cmb γ) (λ v → lift tt) (λ v → lift tt))
+                     (fsk : ∀ i → Mor (Fam𝒞-P.prod Γ (sₛ i)) (sₜ i))
+                     (corr : ∀ i {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {a₁ a₂} (a≈ : _≈s_ (sₛ i .idx) a₁ a₂) →
+                             _≈s_ (sₜ i .idx) (Rs.iapply (cmb γ₁) i a₁) (fsk i .idxf .PS._⇒_.func (γ₂ , a₂)))
+                     (corr-fam : ∀ i {a} →
+                        Category._≈_ 𝒞
+                          (sₜ i .fam .subst (corr i (Γ .idx .isEquivalence .refl) (sₛ i .idx .isEquivalence .refl {a}))
+                           ∘ FR.aapply act i a)
+                          (fsk i .famf ._⇒f_.transf (γ , a))) →
+                     let module Ft = FoldDef {Γ = Γ} {A = μObj Q sₜ} {P = Q} {δ = sₛ}
+                                       (Mor-∘ At.inMor (HasMu.strong-fmor hasMu Q (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂)))
+                         fsk' = HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂ in
+                     (R : Poly (suc n))
+                     {x : Ts.⟦ ∣ R ∣ ⟧shape (Sh.η₀ ∣ Q ∣)} →
+                     Category._≈_ 𝒞
+                       (Tt.fib-shape-subst R (Tt.deco-ext Q (λ i → lift tt))
+                          (fuse-shape Q cmb fsk corr R (Γ .idx .isEquivalence .refl) (Ts.shape≈-refl ∣ R ∣ (Sh.η₀ ∣ Q ∣) x))
+                        ∘ FR.freindex-shape-fam R (FR.abind Q (cmb γ) act) {x})
+                       (At.R.reindex-fam R At.mor₀
+                        ∘ (At.embed-fam R (HasMu.strong-fmor hasMu R fsk' .idxf .PS._⇒_.func (γ , Ft.fold-shape-idx R γ x))
+                           ∘ (HasMu.strong-fmor hasMu R fsk' .famf ._⇒f_.transf (γ , Ft.fold-shape-idx R γ x)
+                              ∘ pair p₁ (Ft.fold-shape-fam R γ x))))
+
+fuse-fam γ Q cmb act fsk corr corr-fam {Tree.sup x} =
+  ≈-trans (fuse-shape-fam γ Q cmb act fsk corr corr-fam Q {x})
+    (≈-sym (≈-trans (∘-cong id-left ≈-refl) (≈-trans (assoc _ _ _) (assoc _ _ _))))
+fuse-shape-fam γ Q cmb act fsk corr corr-fam (const A') =
+  ≈-trans (∘-cong (A' .fam .refl*) ≈-refl)
+    (≈-trans id-left (≈-sym (≈-trans id-left (≈-trans id-left (pair-p₂ _ _)))))
+fuse-shape-fam γ Q cmb act fsk corr corr-fam (var Fin.zero) {x} =
+  ≈-trans (fuse-fam γ Q cmb act fsk corr corr-fam {x})
+    (≈-sym (≈-trans id-left (≈-trans id-left (pair-p₂ _ _))))
+fuse-shape-fam γ Q cmb act fsk corr corr-fam (var (Fin.suc i)) {x} =
+  ≈-trans (corr-fam i)
+    (≈-sym (≈-trans id-left (≈-trans id-left (≈-trans (∘-cong ≈-refl pair-ext0) id-right))))
+fuse-shape-fam γ Q cmb act fsk corr corr-fam (R₁ + R₂) {inj₁ a} =
+  ≈-trans (fuse-shape-fam γ Q cmb act fsk corr corr-fam R₁ {a})
+    (∘-cong ≈-refl (∘-cong ≈-refl (∘-cong (≈-sym (≈-trans id-left id-left)) ≈-refl)))
+fuse-shape-fam γ Q cmb act fsk corr corr-fam (R₁ + R₂) {inj₂ b} =
+  ≈-trans (fuse-shape-fam γ Q cmb act fsk corr corr-fam R₂ {b})
+    (∘-cong ≈-refl (∘-cong ≈-refl (∘-cong (≈-sym (≈-trans id-left id-left)) ≈-refl)))
+fuse-shape-fam γ Q cmb act fsk corr corr-fam (R₁ × R₂) {a , b} =
+  ≈-trans (pair-compose _ _ _ _)
+    (≈-trans (pair-cong
+               (≈-trans (≈-sym (assoc _ _ _))
+                 (≈-trans (∘-cong (fuse-shape-fam γ Q cmb act fsk corr corr-fam R₁ {a}) ≈-refl)
+                   (≈-trans (assoc _ _ _)
+                     (∘-cong ≈-refl
+                       (≈-trans (assoc _ _ _)
+                         (∘-cong ≈-refl
+                           (≈-trans (assoc _ _ _)
+                             (≈-trans (∘-cong ≈-refl (≈-trans (pair-natural _ _ _) (pair-cong (pair-p₁ _ _) ≈-refl)))
+                               (≈-sym
+                                 (≈-trans (∘-cong id-left ≈-refl)
+                                   (≈-trans (assoc _ _ _)
+                                     (∘-cong ≈-refl
+                                       (≈-trans (pair-natural _ _ _)
+                                         (pair-cong (pair-p₁ _ _)
+                                           (≈-trans (∘-cong id-left ≈-refl)
+                                             (≈-trans (assoc _ _ _)
+                                               (≈-trans (∘-cong ≈-refl (pair-p₂ _ _)) (pair-p₁ _ _))))))))))))))))))
+               (≈-trans (≈-sym (assoc _ _ _))
+                 (≈-trans (∘-cong (fuse-shape-fam γ Q cmb act fsk corr corr-fam R₂ {b}) ≈-refl)
+                   (≈-trans (assoc _ _ _)
+                     (∘-cong ≈-refl
+                       (≈-trans (assoc _ _ _)
+                         (∘-cong ≈-refl
+                           (≈-trans (assoc _ _ _)
+                             (≈-trans (∘-cong ≈-refl (≈-trans (pair-natural _ _ _) (pair-cong (pair-p₁ _ _) ≈-refl)))
+                               (≈-sym
+                                 (≈-trans (∘-cong id-left ≈-refl)
+                                   (≈-trans (assoc _ _ _)
+                                     (∘-cong ≈-refl
+                                       (≈-trans (pair-natural _ _ _)
+                                         (pair-cong (pair-p₁ _ _)
+                                           (≈-trans (∘-cong id-left ≈-refl)
+                                             (≈-trans (assoc _ _ _)
+                                               (≈-trans (∘-cong ≈-refl (pair-p₂ _ _)) (pair-p₂ _ _)))))))))))))))))))
+      (≈-sym (≈-trans (∘-cong ≈-refl (∘-cong ≈-refl (pair-natural _ _ _)))
+                (≈-trans (∘-cong ≈-refl (pair-compose _ _ _ _))
+                  (pair-compose _ _ _ _)))))
+fuse-shape-fam {Γ = Γ} γ {sₛ = sₛ} {sₜ = sₜ} Q cmb act fsk corr corr-fam (μ R'') {x} =
+  ≈-trans (∘-cong (Tt.fib-trans* R'' (Tt.deco-ext Q (λ i → lift tt))
+                     {x = Rs.ireindex-shape ∣ μ R'' ∣ (Rs.ibind ∣ Q ∣ (cmb γ)) x}
+                     {y = At.R.reindex At.mor₀ (Rs'.ireindex (cmb' γ) wm₁)}
+                     {z = At.R.reindex At.mor₀ (HasMu.strong-fmor hasMu (μ R'') fsk' .idxf .PS._⇒_.func (γ , wm₁))}
+                     (At.R.reindex-resp At.mor₀
+                        {t = Rs'.ireindex (cmb' γ) wm₁}
+                        {t' = HasMu.strong-fmor hasMu (μ R'') fsk' .idxf .PS._⇒_.func (γ , wm₁)}
+                        rec-idx)
+                     (tele-shape (μ R'') tbase x)) ≈-refl)
+    (≈-trans (assoc _ _ _)
+      (≈-trans (∘-cong ≈-refl (tele-shape-fam (μ R'') tbase x))
+        (≈-trans (≈-sym (assoc _ _ _))
+          (≈-trans (∘-cong (≈-sym (At.R.reindex-fam-W-natural {Q = R''} At.mor₀
+                                     {t = Rs'.ireindex (cmb' γ) wm₁}
+                                     {t' = HasMu.strong-fmor hasMu (μ R'') fsk' .idxf .PS._⇒_.func (γ , wm₁)}
+                                     rec-idx)) ≈-refl)
+            (≈-trans (assoc _ _ _)
+              (∘-cong ≈-refl
+                (≈-trans (≈-sym (assoc _ _ _))
+                  (≈-trans (∘-cong rec-fam ≈-refl) (≈-sym id-left)))))))))
+  where
+    module Tt = Tree sₜ
+    module Ts = Tree sₛ
+    module At = InMapDef Q sₜ
+    module Rs = Reindex sₛ sₜ
+    module Rs' = Reindex (extend sₛ (μObj Q sₜ)) (extend sₜ (μObj Q sₜ))
+    module FR = FReindex {δA = sₛ} {δB = sₜ} (Γ .fam .fm γ)
+    module FR' = FReindex {δA = extend sₛ (μObj Q sₜ)} {δB = extend sₜ (μObj Q sₜ)} (Γ .fam .fm γ)
+    module Ft = FoldDef {Γ = Γ} {A = μObj Q sₜ} {P = Q} {δ = sₛ}
+                  (Mor-∘ At.inMor (HasMu.strong-fmor hasMu Q (HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂)))
+    fsk' = HasMu.strong-extend-mor hasMu fsk Fam𝒞-P.p₂
+    wm₁ = Ft.fold-reindex {Q = R''} γ Ft.fbase x
+    cmb' : Γ .idx .Carrier → Rs'.IMorD (λ v → inj₁ v) (λ v → inj₁ v)
+    cmb' γ' = Rs'.ibase (λ { Fin.zero a → a ; (Fin.suc i) a → Rs.iapply (cmb γ') i a })
+                        (λ { Fin.zero p → p ; (Fin.suc i) p → Rs.iapply-resp (cmb γ') i p })
+    act' : FR'.FAct (cmb' γ) (λ v → lift tt) (λ v → lift tt)
+    act' = FR'.abase (λ { Fin.zero a → p₂ ; (Fin.suc i) a → FR.aapply act i a })
+    corr' : ∀ i {γ₁ γ₂} (γ≈ : _≈s_ (Γ .idx) γ₁ γ₂) {a₁ a₂} (a≈ : _≈s_ (extend sₛ (μObj Q sₜ) i .idx) a₁ a₂) →
+            _≈s_ (extend sₜ (μObj Q sₜ) i .idx) (Rs'.iapply (cmb' γ₁) i a₁) (fsk' i .idxf .PS._⇒_.func (γ₂ , a₂))
+    corr' Fin.zero    γ≈ a≈ = a≈
+    corr' (Fin.suc j) γ≈ a≈ = corr j γ≈ a≈
+    corr-fam' : ∀ i {a} → Category._≈_ 𝒞
+                  (extend sₜ (μObj Q sₜ) i .fam .subst
+                     (corr' i (Γ .idx .isEquivalence .refl) (extend sₛ (μObj Q sₜ) i .idx .isEquivalence .refl {a}))
+                   ∘ FR'.aapply act' i a)
+                  (fsk' i .famf ._⇒f_.transf (γ , a))
+    corr-fam' Fin.zero {a} = ≈-trans (∘-cong (μObj Q sₜ .fam .refl* {a}) ≈-refl) id-left
+    corr-fam' (Fin.suc j) = corr-fam j
+    rec-fam : Category._≈_ 𝒞
+                (μObj R'' (extend sₜ (μObj Q sₜ)) .fam .subst {x = Rs'.ireindex (cmb' γ) wm₁}
+                   (fuse-idx R'' cmb' fsk' corr' (Γ .idx .isEquivalence .refl)
+                     {wm₁} {wm₁} (μObj R'' (extend sₛ (μObj Q sₜ)) .idx .isEquivalence .refl {wm₁}))
+                 ∘ FR'.freindex-fam act' {wm₁})
+                (HasMu.strong-fmor hasMu (μ R'') fsk' .famf ._⇒f_.transf (γ , wm₁))
+    rec-fam = fuse-fam γ R'' cmb' act' fsk' corr' corr-fam' {wm₁}
+    rec-idx = fuse-idx R'' cmb' fsk' corr' (Γ .idx .isEquivalence .refl)
+                {wm₁} {wm₁} (μObj R'' (extend sₛ (μObj Q sₜ)) .idx .isEquivalence .refl {wm₁})
+    mutual
+      data TeleRel : ∀ {j} {ηA ηB ηC ηD}
+                     {dA : ∀ v → Ts.DecoAssign (ηA v)} {dB : ∀ v → Tt.DecoAssign (ηB v)}
+                     {dC : ∀ v → At.TX.DecoAssign (ηC v)} {dD : ∀ v → Ft.TA'.DecoAssign (ηD v)}
+                     (md : Rs.IMorD {j} ηA ηB) (mdA : At.R.MorD {j} ηC ηB dC dB) (md' : Rs'.IMorD {j} ηD ηC) (fm : Ft.FMor {j} ηA ηD dA dD) →
+                     FR.FAct md dA dB → FR'.FAct md' dD dC → Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+        tbase : TeleRel (Rs.ibind ∣ Q ∣ (cmb γ)) At.mor₀ (cmb' γ) Ft.fbase (FR.abind Q (cmb γ) act) act'
+        tbind : ∀ {j} {ηA ηB ηC ηD} {dA dB dC dD} {md : Rs.IMorD ηA ηB} {mdA : At.R.MorD ηC ηB dC dB} {md' : Rs'.IMorD ηD ηC} {fm : Ft.FMor ηA ηD dA dD}
+                {am : FR.FAct md dA dB} {am' : FR'.FAct md' dD dC} (S' : Poly (suc j)) →
+                TeleRel md mdA md' fm am am' →
+                TeleRel (Rs.ibind ∣ S' ∣ md) (At.R.bind S' mdA) (Rs'.ibind ∣ S' ∣ md') (Ft.fbind S' fm)
+                        (FR.abind S' md am) (FR'.abind S' md' am')
+
+      tele-shape : ∀ {j} (S : Poly j) {ηA ηB ηC ηD} {dA dB dC dD}
+                   {md : Rs.IMorD ηA ηB} {mdA : At.R.MorD ηC ηB dC dB} {md' : Rs'.IMorD ηD ηC} {fm : Ft.FMor ηA ηD dA dD}
+                   {am : FR.FAct md dA dB} {am' : FR'.FAct md' dD dC}
+                   (rel : TeleRel md mdA md' fm am am') (z : Ft.Tδ.⟦ ∣ S ∣ ⟧shape ηA) →
+                   Tt.shape≈ ∣ S ∣ ηB
+                     (Rs.ireindex-shape ∣ S ∣ md z)
+                     (At.R.reindex-shape ∣ S ∣ mdA (Rs'.ireindex-shape ∣ S ∣ md' (Ft.fold-reindex-shape γ S fm z)))
+      tele-shape (const A') rel z = A' .idx .isEquivalence .refl
+      tele-shape (var v) rel z = tele-apply rel v
+      tele-shape (S₁ + S₂) rel (inj₁ z) = tele-shape S₁ rel z
+      tele-shape (S₁ + S₂) rel (inj₂ z) = tele-shape S₂ rel z
+      tele-shape (S₁ × S₂) rel (z₁ , z₂) = tele-shape S₁ rel z₁ , tele-shape S₂ rel z₂
+      tele-shape (μ S') rel (Ts.sup z') = tele-shape S' (tbind S' rel) z'
+
+      tele-apply : ∀ {j} {ηA ηB ηC ηD} {dA dB dC dD}
+                   {md : Rs.IMorD ηA ηB} {mdA : At.R.MorD ηC ηB dC dB} {md' : Rs'.IMorD ηD ηC} {fm : Ft.FMor ηA ηD dA dD}
+                   {am : FR.FAct md dA dB} {am' : FR'.FAct md' dD dC}
+                   (rel : TeleRel md mdA md' fm am am') (v : Fin j) {z} →
+                   Tt.elEq (ηB v) (Rs.iapply md v z) (At.R.apply mdA v (Rs'.iapply md' v (Ft.fold-apply γ fm v z)))
+      tele-apply (tbind S' r) Fin.zero    {z} = tele-shape (μ S') r z
+      tele-apply (tbind S' r) (Fin.suc v)     = tele-apply r v
+      tele-apply tbase Fin.zero    {z} =
+        fuse-idx Q cmb fsk corr (Γ .idx .isEquivalence .refl {γ}) {m₁ = z} {m₂ = z}
+          (μObj Q sₛ .idx .isEquivalence .refl {z})
+      tele-apply tbase (Fin.suc i) {z} = Tt.elEq-refl (inj₁ i) (Rs.iapply (cmb γ) i z)
+
+      tele-shape-fam : ∀ {j} (S : Poly j) {ηA ηB ηC ηD} {dA dB dC dD}
+                       {md : Rs.IMorD ηA ηB} {mdA : At.R.MorD ηC ηB dC dB} {md' : Rs'.IMorD ηD ηC} {fm : Ft.FMor ηA ηD dA dD}
+                       {am : FR.FAct md dA dB} {am' : FR'.FAct md' dD dC}
+                       (rel : TeleRel md mdA md' fm am am') (z : Ft.Tδ.⟦ ∣ S ∣ ⟧shape ηA) →
+                       (Tt.fib-shape-subst S dB (tele-shape S rel z) ∘ FR.freindex-shape-fam S am {z})
+                       ≈ (At.R.reindex-fam S mdA
+                          ∘ (FR'.freindex-shape-fam S am' {Ft.fold-reindex-shape γ S fm z}
+                             ∘ pair p₁ (Ft.fold-reindex-shape-fam γ S fm z)))
+      tele-shape-fam (const A') rel z =
+        ≈-trans (∘-cong (A' .fam .refl*) ≈-refl) (≈-trans id-left (≈-sym (≈-trans id-left (pair-p₂ _ _))))
+      tele-shape-fam (var v) rel z = tele-apply-fam rel v
+      tele-shape-fam (S₁ + S₂) rel (inj₁ z) = tele-shape-fam S₁ rel z
+      tele-shape-fam (S₁ + S₂) rel (inj₂ z) = tele-shape-fam S₂ rel z
+      tele-shape-fam (S₁ × S₂) rel (z₁ , z₂) =
+        ≈-trans (strong-prod-m-post _ _ _ _)
+          (≈-trans (strong-prod-m-cong (tele-shape-fam S₁ rel z₁) (tele-shape-fam S₂ rel z₂))
+            (≈-sym (≈-trans (∘-cong ≈-refl (strong-prod-m-comp _ _ _ _)) (strong-prod-m-post _ _ _ _))))
+      tele-shape-fam (μ S') rel (Ts.sup z') = tele-shape-fam S' (tbind S' rel) z'
+
+      tele-apply-fam : ∀ {j} {ηA ηB ηC ηD} {dA dB dC dD}
+                       {md : Rs.IMorD ηA ηB} {mdA : At.R.MorD ηC ηB dC dB} {md' : Rs'.IMorD ηD ηC} {fm : Ft.FMor ηA ηD dA dD}
+                       {am : FR.FAct md dA dB} {am' : FR'.FAct md' dD dC}
+                       (rel : TeleRel md mdA md' fm am am') (v : Fin j) {z} →
+                       (Tt.fib-el-subst (ηB v) (dB v) (tele-apply rel v {z}) ∘ FR.aapply am v z)
+                       ≈ (At.R.apply-fam mdA v (Rs'.iapply md' v (Ft.fold-apply γ fm v z))
+                          ∘ (FR'.aapply am' v (Ft.fold-apply γ fm v z)
+                             ∘ pair p₁ (Ft.fold-apply-fam γ fm v z)))
+      tele-apply-fam (tbind S' r) Fin.zero    {z} = tele-shape-fam (μ S') r z
+      tele-apply-fam (tbind S' r) (Fin.suc v)     = tele-apply-fam r v
+      tele-apply-fam tbase Fin.zero    {z} =
+        ≈-trans (fuse-fam γ Q cmb act fsk corr corr-fam {z}) (≈-sym (≈-trans id-left (pair-p₂ _ _)))
+      tele-apply-fam tbase (Fin.suc i) {z} =
+        ≈-trans (∘-cong (sₜ i .fam .refl*) ≈-refl)
+          (≈-trans id-left (≈-sym (≈-trans id-left (≈-trans (∘-cong ≈-refl pair-ext0) id-right))))
diff --git a/agda/src/fam-mu-types/reindex.agda b/agda/src/fam-mu-types/reindex.agda
new file mode 100644
index 00000000..d57a4983
--- /dev/null
+++ b/agda/src/fam-mu-types/reindex.agda
@@ -0,0 +1,216 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- Reindexing of carrier trees along context morphisms: MorD carries index and
+-- fibre data, IMorD the index action only (MorD's index side factors through it
+-- via `erase`), and FReindex's FAct pairs an IMorD with an "external" Γ-dependent
+-- fibre action. The morphisms are first-order data so the recursion stays
+-- structural. The index actions work on the category-free shapes; the fibre
+-- actions carry the decorations of both sides.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Product using (_,_)
+open import prop using (_,_)
+open import categories using (Category; HasTerminal; HasProducts)
+import fam-mu-types.carrier
+
+module fam-mu-types.reindex {o m e} (os es : Level) {𝒞 : Category o m e}
+    (T : HasTerminal 𝒞) (P : HasProducts 𝒞) where
+
+open fam-mu-types.carrier os es T P public
+
+-- Reindex a tree from one parameter context to another along a context morphism.
+-- The morphism is first-order data: `base` carries the leaf maps (applied only at
+-- leaves), `bind` records one binder. So `reindex`'s recursive calls are syntactically
+-- direct and structurally terminating — no closure, no fuel.
+module Reindex {nA nB} (δA : Fin nA → Obj) (δB : Fin nB → Obj) where
+  private
+    module TA = Tree δA
+    module TB = Tree δB
+
+  data MorD : ∀ {k} (ρA : Fin k → Fin nA ⊎ Sort nA) (ρB : Fin k → Fin nB ⊎ Sort nB) →
+              (∀ v → TA.DecoAssign (ρA v)) → (∀ v → TB.DecoAssign (ρB v)) →
+              Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+    base : ∀ {k} {ρA ρB dA dB} (f : ∀ v → TA.El (ρA v) → TB.El (ρB v))
+           (f-resp : ∀ v {a a'} → TA.elEq (ρA v) a a' → TB.elEq (ρB v) (f v a) (f v a'))
+           (ffam : ∀ v a → TA.fib-el (ρA v) (dA v) a ⇒ TB.fib-el (ρB v) (dB v) (f v a)) →
+           (∀ v {a a'} (p : TA.elEq (ρA v) a a') →
+              (ffam v a' ∘ TA.fib-el-subst (ρA v) (dA v) p) ≈ (TB.fib-el-subst (ρB v) (dB v) (f-resp v p) ∘ ffam v a)) →
+           MorD {k} ρA ρB dA dB
+    bind : ∀ {k} {ρA ρB dA dB} (Q : Poly (suc k)) → MorD ρA ρB dA dB →
+           MorD (extend ρA (inj₂ (mkSort ∣ Q ∣ ρA))) (extend ρB (inj₂ (mkSort ∣ Q ∣ ρB)))
+                (TA.deco-ext Q dA) (TB.deco-ext Q dB)
+
+  -- Index-only reindex: the index action of a context morphism, with no fibre data,
+  -- so entirely at the category-free shapes. Carries both `MorD`'s index side (via
+  -- `erase` below) and the fusion morphisms (`combine`), whose Γ-dependent fibre
+  -- action lives externally in `FReindex`.
+  data IMorD : ∀ {k} → (Fin k → Fin nA ⊎ Sort nA) → (Fin k → Fin nB ⊎ Sort nB) →
+               Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+    ibase : ∀ {k} {ρA ρB} (f : ∀ v → TA.El (ρA v) → TB.El (ρB v))
+            (f-resp : ∀ v {a a'} → TA.elEq (ρA v) a a' → TB.elEq (ρB v) (f v a) (f v a')) →
+            IMorD {k} ρA ρB
+    ibind : ∀ {k} {ρA ρB} (R : Sh.Poly (suc k)) → IMorD ρA ρB →
+            IMorD (extend ρA (inj₂ (mkSort R ρA))) (extend ρB (inj₂ (mkSort R ρB)))
+
+  mutual
+    ireindex : ∀ {k} {R : Sh.Poly (suc k)} {ρA ρB} (md : IMorD ρA ρB) → TA.W R ρA → TB.W R ρB
+    ireindex {R = R} md (TA.sup x) = TB.sup (ireindex-shape R (ibind R md) x)
+
+    ireindex-shape : ∀ {j} (R : Sh.Poly j) {ηA ηB} (md : IMorD ηA ηB) → TA.⟦ R ⟧shape ηA → TB.⟦ R ⟧shape ηB
+    ireindex-shape (const S) md a = a
+    ireindex-shape (var v) md a = iapply md v a
+    ireindex-shape (P + Q) md (inj₁ a) = inj₁ (ireindex-shape P md a)
+    ireindex-shape (P + Q) md (inj₂ b) = inj₂ (ireindex-shape Q md b)
+    ireindex-shape (P × Q) md (a , b) = ireindex-shape P md a , ireindex-shape Q md b
+    ireindex-shape (μ Q') md t = ireindex md t
+
+    iapply : ∀ {k} {ρA ρB} (md : IMorD {k} ρA ρB) (v : Fin k) → TA.El (ρA v) → TB.El (ρB v)
+    iapply (ibase f _) v a = f v a
+    iapply (ibind R md) Fin.zero a = ireindex md a
+    iapply (ibind R md) (Fin.suc v) a = iapply md v a
+
+  mutual
+    ireindex-resp : ∀ {k} {R : Sh.Poly (suc k)} {ρA ρB} (md : IMorD ρA ρB) {t t' : TA.W R ρA} →
+                    TA.W-≈ t t' → TB.W-≈ (ireindex md t) (ireindex md t')
+    ireindex-resp {R = R} md {TA.sup x} {TA.sup y} p = ireindex-shape-resp R (ibind R md) {x} {y} p
+
+    ireindex-shape-resp : ∀ {j} (R : Sh.Poly j) {ηA ηB} (md : IMorD ηA ηB) {a a' : TA.⟦ R ⟧shape ηA} →
+                          TA.shape≈ R ηA a a' → TB.shape≈ R ηB (ireindex-shape R md a) (ireindex-shape R md a')
+    ireindex-shape-resp (const S) md p = p
+    ireindex-shape-resp (var v)   md p = iapply-resp md v p
+    ireindex-shape-resp (P + Q) md {inj₁ _} {inj₁ _} p = ireindex-shape-resp P md p
+    ireindex-shape-resp (P + Q) md {inj₂ _} {inj₂ _} p = ireindex-shape-resp Q md p
+    ireindex-shape-resp (P × Q) md {_ , _} {_ , _} (p₁ , p₂) = ireindex-shape-resp P md p₁ , ireindex-shape-resp Q md p₂
+    ireindex-shape-resp (μ Q') md {a} {a'} p = ireindex-resp md {a} {a'} p
+
+    iapply-resp : ∀ {k} {ρA ρB} (md : IMorD {k} ρA ρB) (v : Fin k) {a a'} →
+                  TA.elEq (ρA v) a a' → TB.elEq (ρB v) (iapply md v a) (iapply md v a')
+    iapply-resp (ibase f f-resp) v p = f-resp v p
+    iapply-resp (ibind R md) Fin.zero {a} {a'} p = ireindex-resp md {a} {a'} p
+    iapply-resp (ibind R md) (Fin.suc v) p = iapply-resp md v p
+
+  -- Erase the fibre fields; `MorD`'s index-level operations are `IMorD`'s.
+  erase : ∀ {k} {ρA ρB dA dB} → MorD {k} ρA ρB dA dB → IMorD ρA ρB
+  erase (base f f-resp _ _) = ibase f f-resp
+  erase (bind Q md) = ibind ∣ Q ∣ (erase md)
+
+  reindex : ∀ {k} {R : Sh.Poly (suc k)} {ρA ρB dA dB} → MorD ρA ρB dA dB → TA.W R ρA → TB.W R ρB
+  reindex md = ireindex (erase md)
+
+  reindex-shape : ∀ {j} (R : Sh.Poly j) {ηA ηB dA dB} → MorD ηA ηB dA dB → TA.⟦ R ⟧shape ηA → TB.⟦ R ⟧shape ηB
+  reindex-shape R md = ireindex-shape R (erase md)
+
+  apply : ∀ {k} {ρA ρB dA dB} (md : MorD {k} ρA ρB dA dB) (v : Fin k) → TA.El (ρA v) → TB.El (ρB v)
+  apply md = iapply (erase md)
+
+  reindex-resp : ∀ {k} {R : Sh.Poly (suc k)} {ρA ρB dA dB} (md : MorD ρA ρB dA dB) {t t' : TA.W R ρA} →
+                 TA.W-≈ t t' → TB.W-≈ (reindex md t) (reindex md t')
+  reindex-resp md {t} {t'} = ireindex-resp (erase md) {t} {t'}
+
+  reindex-shape-resp : ∀ {j} (R : Sh.Poly j) {ηA ηB dA dB} (md : MorD ηA ηB dA dB) {a a' : TA.⟦ R ⟧shape ηA} →
+                       TA.shape≈ R ηA a a' → TB.shape≈ R ηB (reindex-shape R md a) (reindex-shape R md a')
+  reindex-shape-resp R md {a} {a'} = ireindex-shape-resp R (erase md) {a} {a'}
+
+  apply-resp : ∀ {k} {ρA ρB dA dB} (md : MorD {k} ρA ρB dA dB) (v : Fin k) {a a'} →
+               TA.elEq (ρA v) a a' → TB.elEq (ρB v) (apply md v a) (apply md v a')
+  apply-resp md v {a} {a'} = iapply-resp (erase md) v {a} {a'}
+
+  -- The fibre side of `reindex`: a 𝒞-morphism into the reindexed fibre.
+  mutual
+    reindex-fam : ∀ {j} (R : Poly j) {ηA ηB dA dB} (md : MorD ηA ηB dA dB) {a : TA.⟦ ∣ R ∣ ⟧shape ηA} →
+                  TA.fib-shape R dA a ⇒ TB.fib-shape R dB (reindex-shape ∣ R ∣ md a)
+    reindex-fam (const A) md = id _
+    reindex-fam (var v) md {a} = apply-fam md v a
+    reindex-fam (P + Q) md {inj₁ a} = reindex-fam P md
+    reindex-fam (P + Q) md {inj₂ b} = reindex-fam Q md
+    reindex-fam (P × Q) md {a , b} = prod-m (reindex-fam P md) (reindex-fam Q md)
+    reindex-fam (μ Q') md {t} = reindex-fam-W md {t}
+
+    reindex-fam-W : ∀ {k} {Q : Poly (suc k)} {ρA ρB dA dB} (md : MorD ρA ρB dA dB) {t : TA.W ∣ Q ∣ ρA} →
+                    TA.fib Q dA t ⇒ TB.fib Q dB (reindex md t)
+    reindex-fam-W {Q = Q} md {TA.sup x} = reindex-fam Q (bind Q md)
+
+    apply-fam : ∀ {k} {ρA ρB dA dB} (md : MorD {k} ρA ρB dA dB) (v : Fin k) (a : TA.El (ρA v)) →
+                TA.fib-el (ρA v) (dA v) a ⇒ TB.fib-el (ρB v) (dB v) (apply md v a)
+    apply-fam (base _ _ ffam _) v a = ffam v a
+    apply-fam (bind Q md) Fin.zero a = reindex-fam-W md {a}
+    apply-fam (bind Q md) (Fin.suc v) a = apply-fam md v a
+
+  -- The fibre reindex commutes with subst (naturality).
+  mutual
+    reindex-fam-natural : ∀ {j} (R : Poly j) {ηA ηB dA dB} (md : MorD ηA ηB dA dB)
+                      {a a' : TA.⟦ ∣ R ∣ ⟧shape ηA} (p : TA.shape≈ ∣ R ∣ ηA a a') →
+                      (reindex-fam R md {a'} ∘ TA.fib-shape-subst R dA p)
+                        ≈ (TB.fib-shape-subst R dB (reindex-shape-resp ∣ R ∣ md p) ∘ reindex-fam R md {a})
+    reindex-fam-natural (const A) md p = ≈-trans id-left (≈-sym id-right)
+    reindex-fam-natural (var v)   md {a} {a'} p = apply-fam-natural md v {a} {a'} p
+    reindex-fam-natural (P + Q) md {inj₁ a} {inj₁ a'} p = reindex-fam-natural P md p
+    reindex-fam-natural (P + Q) md {inj₂ b} {inj₂ b'} p = reindex-fam-natural Q md p
+    reindex-fam-natural (P × Q) md {a , b} {a' , b'} (p₁ , p₂) =
+      ≈-trans (≈-sym (prod-m-comp _ _ _ _))
+      (≈-trans (prod-m-cong (reindex-fam-natural P md p₁) (reindex-fam-natural Q md p₂))
+               (prod-m-comp _ _ _ _))
+    reindex-fam-natural (μ Q') md {t} {t'} p = reindex-fam-W-natural md {t} {t'} p
+
+    reindex-fam-W-natural : ∀ {k} {Q : Poly (suc k)} {ρA ρB dA dB} (md : MorD ρA ρB dA dB)
+                        {t t' : TA.W ∣ Q ∣ ρA} (p : TA.W-≈ t t') →
+                        (reindex-fam-W md {t'} ∘ TA.fib-subst Q dA {x = t} {y = t'} p)
+                          ≈ (TB.fib-subst Q dB {x = reindex md t} {y = reindex md t'}
+                                          (reindex-resp md {t} {t'} p) ∘ reindex-fam-W md {t})
+    reindex-fam-W-natural {Q = Q} md {TA.sup x} {TA.sup y} p = reindex-fam-natural Q (bind Q md) {x} {y} p
+
+    apply-fam-natural : ∀ {k} {ρA ρB dA dB} (md : MorD {k} ρA ρB dA dB) (v : Fin k) {a a'}
+                    (p : TA.elEq (ρA v) a a') →
+                    (apply-fam md v a' ∘ TA.fib-el-subst (ρA v) (dA v) p)
+                      ≈ (TB.fib-el-subst (ρB v) (dB v) (apply-resp md v p) ∘ apply-fam md v a)
+    apply-fam-natural (base _ _ _ ffam-natural) v p = ffam-natural v p
+    apply-fam-natural (bind Q md) Fin.zero    {a} {a'} p = reindex-fam-W-natural md {a} {a'} p
+    apply-fam-natural (bind Q md) (Fin.suc v) p = apply-fam-natural md v p
+
+-- Fibre reindex over an index-only reindex `cmb`, driven by an "external" per-variable action `act`: a
+-- fold's fibre action is Γ-dependent, so it can't live in a reindex morphism and is carried separately.
+-- The ambient Γ-fibre is `G`.
+module FReindex {nA nB} {δA : Fin nA → Obj} {δB : Fin nB → Obj} (G : obj) where
+  private
+    module TA = Tree δA
+    module TB = Tree δB
+  open Reindex δA δB using (IMorD; ireindex; ireindex-shape; iapply; ibind)
+
+  -- Defunctionalised action: `abase` supplies all var fibres directly (a Γ-dependent fold);
+  -- `abind` extends across a binder. Data (not a function) so the recursion stays structural.
+  data FAct : ∀ {k} {ρA : Fin k → Fin nA ⊎ Sort nA} {ρB : Fin k → Fin nB ⊎ Sort nB} →
+              IMorD ρA ρB → (∀ v → TA.DecoAssign (ρA v)) → (∀ v → TB.DecoAssign (ρB v)) →
+              Set (o ⊔ m ⊔ e ⊔ lsuc os ⊔ lsuc es) where
+    abase : ∀ {k} {ρA ρB} {cmb : IMorD {k} ρA ρB} {dA dB}
+            (afib : ∀ v (a : TA.El (ρA v)) → prod G (TA.fib-el (ρA v) (dA v) a) ⇒ TB.fib-el (ρB v) (dB v) (iapply cmb v a)) →
+            FAct cmb dA dB
+    abind : ∀ {k} {ρA ρB} (Q : Poly (suc k)) (cmb : IMorD ρA ρB) {dA dB} → FAct cmb dA dB →
+            FAct (ibind ∣ Q ∣ cmb) (TA.deco-ext Q dA) (TB.deco-ext Q dB)
+
+  mutual
+    freindex-fam : ∀ {k} {Q : Poly (suc k)} {ρA ρB} {cmb : IMorD ρA ρB} {dA dB} (act : FAct cmb dA dB)
+                   {t : TA.W ∣ Q ∣ ρA} → prod G (TA.fib Q dA t) ⇒ TB.fib Q dB (ireindex cmb t)
+    freindex-fam {Q = Q} {cmb = cmb} act {TA.sup x} = freindex-shape-fam Q (abind Q cmb act) {x}
+
+    freindex-shape-fam : ∀ {j} (R : Poly j) {ηA ηB} {cmb : IMorD ηA ηB} {dA dB} (act : FAct cmb dA dB)
+                         {a : TA.⟦ ∣ R ∣ ⟧shape ηA} →
+                         prod G (TA.fib-shape R dA a) ⇒ TB.fib-shape R dB (ireindex-shape ∣ R ∣ cmb a)
+    freindex-shape-fam (const A') act = p₂
+    freindex-shape-fam (var v)    act {a} = aapply act v a
+    freindex-shape-fam (P + Q) act {inj₁ a} = freindex-shape-fam P act {a}
+    freindex-shape-fam (P + Q) act {inj₂ b} = freindex-shape-fam Q act {b}
+    freindex-shape-fam (P × Q) act {a , b} =
+      strong-prod-m (freindex-shape-fam P act {a}) (freindex-shape-fam Q act {b})
+    freindex-shape-fam (μ Q') act {t} = freindex-fam act {t}
+
+    aapply : ∀ {k} {ρA ρB} {cmb : IMorD {k} ρA ρB} {dA dB} (act : FAct cmb dA dB) (v : Fin k) (a : TA.El (ρA v)) →
+             prod G (TA.fib-el (ρA v) (dA v) a) ⇒ TB.fib-el (ρB v) (dB v) (iapply cmb v a)
+    aapply (abase afib)      v           a = afib v a
+    aapply (abind Q cmb act) Fin.zero    a = freindex-fam act {a}
+    aapply (abind Q cmb act) (Fin.suc v) a = aapply act v a
diff --git a/agda/src/fam-mu-types/sort.agda b/agda/src/fam-mu-types/sort.agda
new file mode 100644
index 00000000..64351ec2
--- /dev/null
+++ b/agda/src/fam-mu-types/sort.agda
@@ -0,0 +1,135 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+------------------------------------------------------------------------------
+-- Category-free sort layer of the Fam μ-type construction. Sorts and trees
+-- are built from index sets alone: the construction is parameterised by the
+-- index setoids of the kinding environment, and constants enter as their index
+-- setoids, so the layer mentions no category. The fibre layer over a specific
+-- category is built separately on top.
+------------------------------------------------------------------------------
+
+open import Level using (Level; _⊔_) renaming (suc to lsuc)
+open import Data.Nat using (ℕ; suc)
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Data.Product using (_,_) renaming (_×_ to _×T_)
+open import prop using (_∧_; _,_; ⊥)
+open import prop-setoid using (Setoid; IsEquivalence)
+import setoid-cat
+import polynomial-functor
+
+module fam-mu-types.sort (os es : Level) where
+
+open Setoid using (Carrier; isEquivalence) renaming (_≈_ to _≈s_)
+open IsEquivalence
+
+-- Index-erased polynomials: constants are index setoids.
+𝒮 = setoid-cat.SetoidCat os (os ⊔ es)
+Poly = polynomial-functor.Poly 𝒮
+open polynomial-functor.Poly
+open polynomial-functor using (extend)
+
+-- A sort is an index-erased μ-body together with a assignment of its free
+-- variables to parameters or other sorts.
+data Sort (n : ℕ) : Set (lsuc os ⊔ lsuc es) where
+  mkSort : ∀ {k} → Poly (suc k) → (Fin k → Fin n ⊎ Sort n) → Sort n
+
+-- The body environment of a μ-binder: slot 0 is the binder's own sort, the rest
+-- are the ambient parameters.
+η₀ : ∀ {n} → Poly (suc n) → Fin (suc n) → Fin n ⊎ Sort n
+η₀ P = extend (λ i → inj₁ i) (inj₂ (mkSort P (λ i → inj₁ i)))
+
+module Tree {n} (ι : Fin n → Setoid os (os ⊔ es)) where
+  mutual
+    data W {k} (Q : Poly (suc k)) (ρ : Fin k → Fin n ⊎ Sort n) : Set os where
+      sup : ⟦ Q ⟧shape (extend ρ (inj₂ (mkSort Q ρ))) → W Q ρ
+
+    ⟦_⟧shape : ∀ {k} → Poly k → (Fin k → Fin n ⊎ Sort n) → Set os
+    ⟦ const S ⟧shape η = S .Carrier
+    ⟦ var j   ⟧shape η = El (η j)
+    ⟦ P + Q   ⟧shape η = ⟦ P ⟧shape η ⊎ ⟦ Q ⟧shape η
+    ⟦ P × Q   ⟧shape η = ⟦ P ⟧shape η ×T ⟦ Q ⟧shape η
+    ⟦ μ Q'    ⟧shape η = W Q' η
+
+    El : Fin n ⊎ Sort n → Set os
+    El (inj₁ p)            = ι p .Carrier
+    El (inj₂ (mkSort Q ρ)) = W Q ρ
+
+  mutual
+    W-≈ : ∀ {k} {Q : Poly (suc k)} {ρ : Fin k → Fin n ⊎ Sort n} → W Q ρ → W Q ρ → Prop (os ⊔ es)
+    W-≈ {Q = Q} {ρ = ρ} (sup x) (sup y) = shape≈ Q (extend ρ (inj₂ (mkSort Q ρ))) x y
+
+    shape≈ : ∀ {j} (Q : Poly j) (η : Fin j → Fin n ⊎ Sort n) →
+             ⟦ Q ⟧shape η → ⟦ Q ⟧shape η → Prop (os ⊔ es)
+    shape≈ (const S) η x y = _≈s_ S x y
+    shape≈ (var j)   η x y = elEq (η j) x y
+    shape≈ (P + Q) η (inj₁ x) (inj₁ y) = shape≈ P η x y
+    shape≈ (P + Q) η (inj₁ _) (inj₂ _) = ⊥
+    shape≈ (P + Q) η (inj₂ _) (inj₁ _) = ⊥
+    shape≈ (P + Q) η (inj₂ x) (inj₂ y) = shape≈ Q η x y
+    shape≈ (P × Q) η (x₁ , x₂) (y₁ , y₂) = shape≈ P η x₁ y₁ ∧ shape≈ Q η x₂ y₂
+    shape≈ (μ Q') η x y = W-≈ x y
+
+    elEq : (r : Fin n ⊎ Sort n) → El r → El r → Prop (os ⊔ es)
+    elEq (inj₁ p)            x y = _≈s_ (ι p) x y
+    elEq (inj₂ (mkSort Q ρ)) x y = W-≈ x y
+
+  mutual
+    W-≈-refl : ∀ {k} {Q : Poly (suc k)} {ρ} (x : W Q ρ) → W-≈ x x
+    W-≈-refl {Q = Q} {ρ = ρ} (sup x) = shape≈-refl Q (extend ρ (inj₂ (mkSort Q ρ))) x
+
+    shape≈-refl : ∀ {j} (Q : Poly j) (η : Fin j → Fin n ⊎ Sort n) (x : ⟦ Q ⟧shape η) → shape≈ Q η x x
+    shape≈-refl (const S) η x = S .isEquivalence .refl
+    shape≈-refl (var j)   η x = elEq-refl (η j) x
+    shape≈-refl (P + Q) η (inj₁ x) = shape≈-refl P η x
+    shape≈-refl (P + Q) η (inj₂ y) = shape≈-refl Q η y
+    shape≈-refl (P × Q) η (x₁ , x₂) = shape≈-refl P η x₁ , shape≈-refl Q η x₂
+    shape≈-refl (μ Q') η x = W-≈-refl x
+
+    elEq-refl : (r : Fin n ⊎ Sort n) (x : El r) → elEq r x x
+    elEq-refl (inj₁ p)            x = ι p .isEquivalence .refl
+    elEq-refl (inj₂ (mkSort Q ρ)) x = W-≈-refl x
+
+  mutual
+    W-≈-sym : ∀ {k} {Q : Poly (suc k)} {ρ} {x y : W Q ρ} → W-≈ x y → W-≈ y x
+    W-≈-sym {Q = Q} {ρ = ρ} {sup x} {sup y} p = shape≈-sym Q (extend ρ (inj₂ (mkSort Q ρ))) p
+
+    shape≈-sym : ∀ {j} (Q : Poly j) (η : Fin j → Fin n ⊎ Sort n) {x y : ⟦ Q ⟧shape η} →
+                 shape≈ Q η x y → shape≈ Q η y x
+    shape≈-sym (const S) η p = S .isEquivalence .sym p
+    shape≈-sym (var j)   η p = elEq-sym (η j) p
+    shape≈-sym (P + Q) η {inj₁ _} {inj₁ _} p = shape≈-sym P η p
+    shape≈-sym (P + Q) η {inj₂ _} {inj₂ _} p = shape≈-sym Q η p
+    shape≈-sym (P × Q) η {_ , _} {_ , _} (p₁ , p₂) = shape≈-sym P η p₁ , shape≈-sym Q η p₂
+    shape≈-sym (μ Q') η {x} {y} p = W-≈-sym {x = x} {y = y} p
+
+    elEq-sym : (r : Fin n ⊎ Sort n) {x y : El r} → elEq r x y → elEq r y x
+    elEq-sym (inj₁ p)            e = ι p .isEquivalence .sym e
+    elEq-sym (inj₂ (mkSort Q ρ)) {x} {y} e = W-≈-sym {x = x} {y = y} e
+
+  mutual
+    W-≈-trans : ∀ {k} {Q : Poly (suc k)} {ρ} {x y z : W Q ρ} → W-≈ x y → W-≈ y z → W-≈ x z
+    W-≈-trans {Q = Q} {ρ = ρ} {sup x} {sup y} {sup z} p q = shape≈-trans Q (extend ρ (inj₂ (mkSort Q ρ))) p q
+
+    shape≈-trans : ∀ {j} (Q : Poly j) (η : Fin j → Fin n ⊎ Sort n) {x y z : ⟦ Q ⟧shape η} →
+                   shape≈ Q η x y → shape≈ Q η y z → shape≈ Q η x z
+    shape≈-trans (const S) η p q = S .isEquivalence .trans p q
+    shape≈-trans (var j)   η p q = elEq-trans (η j) p q
+    shape≈-trans (P + Q) η {inj₁ _} {inj₁ _} {inj₁ _} p q = shape≈-trans P η p q
+    shape≈-trans (P + Q) η {inj₂ _} {inj₂ _} {inj₂ _} p q = shape≈-trans Q η p q
+    shape≈-trans (P × Q) η {_ , _} {_ , _} {_ , _} (p₁ , p₂) (q₁ , q₂) =
+      shape≈-trans P η p₁ q₁ , shape≈-trans Q η p₂ q₂
+    shape≈-trans (μ Q') η {x} {y} {z} p q = W-≈-trans {x = x} {y = y} {z = z} p q
+
+    elEq-trans : (r : Fin n ⊎ Sort n) {x y z : El r} → elEq r x y → elEq r y z → elEq r x z
+    elEq-trans (inj₁ p)            e f = ι p .isEquivalence .trans e f
+    elEq-trans (inj₂ (mkSort Q ρ)) {x} {y} {z} e f = W-≈-trans {x = x} {y = y} {z = z} e f
+
+  -- The carrier setoid of the μ-type at sort (Q , ρ).
+  WSetoid : ∀ {k} (Q : Poly (suc k)) (ρ : Fin k → Fin n ⊎ Sort n) → Setoid os (os ⊔ es)
+  WSetoid Q ρ .Carrier = W Q ρ
+  WSetoid Q ρ ._≈s_ = W-≈
+  WSetoid Q ρ .isEquivalence .refl {x} = W-≈-refl x
+  WSetoid Q ρ .isEquivalence .sym {x} {y} = W-≈-sym {x = x} {y = y}
+  WSetoid Q ρ .isEquivalence .trans {x} {y} {z} = W-≈-trans {x = x} {y = y} {z = z}
diff --git a/agda/src/fam-presentation.agda b/agda/src/fam-presentation.agda
new file mode 100644
index 00000000..fbfd1e96
--- /dev/null
+++ b/agda/src/fam-presentation.agda
@@ -0,0 +1,109 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Canonical presentation of a family as the set-indexed coproduct of its
+-- singleton fibres. Every object of a Fam category is the coproduct, over its
+-- index set, of the one-point families on its fibres. This exhibits an
+-- arbitrary family as a diagram that the set-indexed coproduct preservation
+-- lemmas can consume.
+
+open import Level using (Level; lift)
+import Data.Product as Prod
+open import categories using (Category; setoid→category; HasProducts)
+open import functor using (Functor; Colimit)
+open import prop using (_,_; ⟪_⟫)
+open import Data.Unit using (tt)
+open import prop-setoid using (Setoid; IsEquivalence; idS; 𝟙; ≃m-isEquivalence)
+open import indexed-family using (Fam; _⇒f_; _≃f_)
+import fam
+
+module fam-presentation {o m e} (os es : Level) {𝒞 : Category o m e} where
+
+open fam.CategoryOfFamilies os es 𝒞
+open Obj
+open Mor
+open Fam
+open _⇒f_
+open _≃_
+open _≃f_
+open IsEquivalence
+open Category cat using (Iso; ≈-refl; _≈_; _∘_)
+open Iso
+open Functor
+open Colimit
+open prop-setoid._⇒_
+open prop-setoid._≃m_
+
+private
+  module 𝒞 = Category 𝒞
+
+-- The diagram of singleton fibres of a family, indexed by its index set.
+singletons : (X : Obj) → Functor (setoid→category (X .idx)) cat
+singletons X .fobj s = simple[ 𝟙 , X .fam .fm s ]
+singletons X .fmor ⟪ p ⟫ = simplef[ idS 𝟙 , X .fam .subst p ]
+singletons X .fmor-cong _ = ≈-refl
+singletons X .fmor-id .idxf-eq = ≃m-isEquivalence .refl
+singletons X .fmor-id .famf-eq .transf-eq = 𝒞.≈-trans 𝒞.id-left (X .fam .refl*)
+singletons X .fmor-comp ⟪ p ⟫ ⟪ q ⟫ .idxf-eq = ≃m-isEquivalence .sym prop-setoid.id-left
+singletons X .fmor-comp ⟪ p ⟫ ⟪ q ⟫ .famf-eq .transf-eq =
+  𝒞.≈-trans 𝒞.id-left (𝒞.≈-trans (X .fam .trans* p q) (𝒞.≈-sym 𝒞.id-left))
+
+-- A family is the set-indexed coproduct of its singleton fibres.
+present : (X : Obj) → Iso (bigCoproducts (X .idx) (singletons X) .apex) X
+present X .fwd .idxf .func (s Prod., _) = s
+present X .fwd .idxf .func-resp-≈ (e , _) = e
+present X .fwd .famf .transf _ = 𝒞.id _
+present X .fwd .famf .natural _ =
+  𝒞.≈-trans 𝒞.id-left (𝒞.≈-trans 𝒞.id-left (𝒞.≈-sym 𝒞.id-right))
+present X .bwd .idxf .func s = s Prod., lift tt
+present X .bwd .idxf .func-resp-≈ e = e , _
+present X .bwd .famf .transf _ = 𝒞.id _
+present X .bwd .famf .natural _ =
+  𝒞.≈-trans 𝒞.id-left (𝒞.≈-sym (𝒞.≈-trans 𝒞.id-right 𝒞.id-left))
+present X .fwd∘bwd≈id .idxf-eq .func-eq e = e
+present X .fwd∘bwd≈id .famf-eq .transf-eq =
+  𝒞.≈-trans (𝒞.∘-cong (X .fam .refl*) (𝒞.≈-trans 𝒞.id-left 𝒞.id-left)) 𝒞.id-left
+present X .bwd∘fwd≈id .idxf-eq .func-eq (e , _) = e , _
+present X .bwd∘fwd≈id .famf-eq .transf-eq =
+  𝒞.≈-trans
+    (𝒞.∘-cong (𝒞.≈-trans 𝒞.id-left (X .fam .refl*)) (𝒞.≈-trans 𝒞.id-left 𝒞.id-left))
+    𝒞.id-left
+
+-- simple preserves finite products: a singleton on a product is the product of
+-- the singletons. Lets the fibrewise carrier comparison move a product past GF.
+module _ (Prods : HasProducts 𝒞) where
+  private
+    module ⊗M = products Prods
+    module PH = HasProducts Prods
+    module FPH = HasProducts ⊗M.products
+  open ⊗M using (_⊗_)
+
+  simple-⊗ : ∀ {a b} → Iso simple[ 𝟙 , PH.prod a b ] (simple[ 𝟙 , a ] ⊗ simple[ 𝟙 , b ])
+  simple-⊗ .fwd .idxf .func _ = lift tt Prod., lift tt
+  simple-⊗ .fwd .idxf .func-resp-≈ _ = _
+  simple-⊗ .fwd .famf .transf _ = 𝒞.id _
+  simple-⊗ .fwd .famf .natural _ =
+    𝒞.≈-trans 𝒞.id-left (𝒞.≈-sym (𝒞.≈-trans 𝒞.id-right PH.prod-m-id))
+  simple-⊗ .bwd .idxf .func _ = lift tt
+  simple-⊗ .bwd .idxf .func-resp-≈ _ = _
+  simple-⊗ .bwd .famf .transf _ = 𝒞.id _
+  simple-⊗ .bwd .famf .natural _ =
+    𝒞.≈-trans (𝒞.≈-trans 𝒞.id-left PH.prod-m-id) (𝒞.≈-sym 𝒞.id-left)
+  simple-⊗ .fwd∘bwd≈id .idxf-eq .func-eq _ = _ , _
+  simple-⊗ .fwd∘bwd≈id .famf-eq .transf-eq =
+    𝒞.≈-trans (𝒞.∘-cong PH.prod-m-id (𝒞.≈-trans 𝒞.id-left 𝒞.id-left)) 𝒞.id-left
+  simple-⊗ .bwd∘fwd≈id .idxf-eq .func-eq _ = _
+  simple-⊗ .bwd∘fwd≈id .famf-eq .transf-eq =
+    𝒞.≈-trans 𝒞.id-left (𝒞.≈-trans 𝒞.id-left 𝒞.id-left)
+
+  -- The product comparison is natural in both fibres.
+  simple-⊗-natural : ∀ {a a' b b'} (f : a 𝒞.⇒ a') (g : b 𝒞.⇒ b') →
+    (simple-⊗ .fwd ∘ simplef[ idS 𝟙 , PH.prod-m f g ]) ≈
+    (FPH.prod-m simplef[ idS 𝟙 , f ] simplef[ idS 𝟙 , g ] ∘ simple-⊗ .fwd)
+  simple-⊗-natural f g .idxf-eq .func-eq _ = _
+  simple-⊗-natural f g .famf-eq .transf-eq =
+    𝒞.≈-trans (𝒞.∘-cong PH.prod-m-id 𝒞.≈-refl)
+      (𝒞.≈-trans 𝒞.id-left
+        (𝒞.≈-trans 𝒞.id-left
+          (𝒞.≈-trans 𝒞.id-left
+            (𝒞.≈-sym (𝒞.≈-trans 𝒞.id-left
+              (𝒞.≈-trans 𝒞.id-right (PH.pair-cong 𝒞.id-left 𝒞.id-left)))))))
diff --git a/agda/src/fam-realisation.agda b/agda/src/fam-realisation.agda
new file mode 100644
index 00000000..2b01df54
--- /dev/null
+++ b/agda/src/fam-realisation.agda
@@ -0,0 +1,781 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Realisation of a family as the set-indexed coproduct of its fibres: the
+-- counit of the free coproduct completion, for a category with setoid-indexed
+-- colimits.
+
+open import Level using (Level; lift)
+open import Data.Product using (_,_)
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Unit using (tt)
+open import prop using (⟪_⟫) renaming (_,_ to _,ₚ_)
+open import prop-setoid using (Setoid; IsEquivalence; 𝟙; to-𝟙; module ≈-Reasoning)
+  renaming (_⇒_ to _⇒s_; _≃m_ to _≃s_)
+open import categories using (Category; setoid→category; HasTerminal; IsTerminal; HasProducts; HasExponentials; HasCoproducts)
+open import functor
+  using (Functor; HasColimits; Colimit; IsColimit; NatTrans; constF; constFmor; ≃-NatTrans)
+  renaming (_∘_ to _∘N_; _∘F_ to _∘F_)
+open import indexed-family using (Fam; _⇒f_; fam→functor)
+import fam
+import product-cocontinuity
+
+module fam-realisation {o m e} (os es : Level) {ℰ : Category o m e}
+  (ℰC : ∀ (A : Setoid os es) → HasColimits (setoid→category A) ℰ)
+  where
+
+open Category ℰ
+open fam.CategoryOfFamilies os es ℰ using (cat; Mor-∘; bigCoproducts; terminal; simple[_,_]; simplef[_,_]; coproducts)
+open fam.CategoryOfFamilies.Obj
+open fam.CategoryOfFamilies.Mor
+open fam.CategoryOfFamilies._≃_
+open Functor
+open NatTrans
+open ≃-NatTrans
+open Colimit
+open IsColimit
+open Fam
+open _⇒f_
+open _⇒s_ renaming (func to _$s_)
+open prop-setoid._≃m_ using (func-eq)
+
+private
+  colim : (X : Category.obj cat) → Colimit (fam→functor (X .fam))
+  colim X = ℰC (X .idx) (fam→functor (X .fam))
+
+  -- The cocone on the realisation of the target induced by a morphism of
+  -- families.
+  push : ∀ {X Y} → Category._⇒_ cat X Y →
+         NatTrans (fam→functor (X .fam)) (constF (setoid→category (X .idx)) (colim Y .apex))
+  push {X} {Y} f .transf x = colim Y .cocone .transf (f .idxf $s x) ∘ f .famf .transf x
+  push {X} {Y} f .natural {x₁} {x₂} ⟪ e ⟫ =
+    begin
+      id _ ∘ (colim Y .cocone .transf (f .idxf $s x₁) ∘ f .famf .transf x₁)
+    ≈⟨ id-left ⟩
+      colim Y .cocone .transf (f .idxf $s x₁) ∘ f .famf .transf x₁
+    ≈⟨ ∘-cong (≈-trans (≈-sym id-left) (colim Y .cocone .natural ⟪ f .idxf .func-resp-≈ e ⟫)) ≈-refl ⟩
+      (colim Y .cocone .transf (f .idxf $s x₂) ∘ Y .fam .subst (f .idxf .func-resp-≈ e)) ∘ f .famf .transf x₁
+    ≈⟨ assoc _ _ _ ⟩
+      colim Y .cocone .transf (f .idxf $s x₂) ∘ (Y .fam .subst (f .idxf .func-resp-≈ e) ∘ f .famf .transf x₁)
+    ≈˘⟨ ∘-cong ≈-refl (f .famf .natural e) ⟩
+      colim Y .cocone .transf (f .idxf $s x₂) ∘ (f .famf .transf x₂ ∘ X .fam .subst e)
+    ≈˘⟨ assoc _ _ _ ⟩
+      (colim Y .cocone .transf (f .idxf $s x₂) ∘ f .famf .transf x₂) ∘ X .fam .subst e
+    ∎ where open ≈-Reasoning isEquiv
+
+realise : Functor cat ℰ
+realise .fobj X = colim X .apex
+realise .fmor {X} {Y} f = colim X .isColimit .colambda _ (push f)
+realise .fmor-cong {X} {Y} {f} {g} f≃g =
+  colim X .isColimit .colambda-cong eq
+  where
+    eq : ≃-NatTrans (push f) (push g)
+    eq .transf-eq x =
+      begin
+        colim Y .cocone .transf (f .idxf $s x) ∘ f .famf .transf x
+      ≈⟨ ∘-cong (≈-trans (≈-sym id-left) (colim Y .cocone .natural ⟪ f≃g .idxf-eq .func-eq (X .idx .Setoid.refl) ⟫)) ≈-refl ⟩
+        (colim Y .cocone .transf (g .idxf $s x) ∘ Y .fam .subst (f≃g .idxf-eq .func-eq (X .idx .Setoid.refl))) ∘ f .famf .transf x
+      ≈⟨ assoc _ _ _ ⟩
+        colim Y .cocone .transf (g .idxf $s x) ∘ (Y .fam .subst (f≃g .idxf-eq .func-eq (X .idx .Setoid.refl)) ∘ f .famf .transf x)
+      ≈⟨ ∘-cong ≈-refl (f≃g .famf-eq .indexed-family._≃f_.transf-eq {x}) ⟩
+        colim Y .cocone .transf (g .idxf $s x) ∘ g .famf .transf x
+      ∎ where open ≈-Reasoning isEquiv
+realise .fmor-id {X} =
+  ≈-trans (colim X .isColimit .colambda-cong eq) (colim X .isColimit .colambda-ext _ (id _))
+  where
+    eq : ≃-NatTrans (push (Category.id cat X)) (constFmor (id _) ∘N colim X .cocone)
+    eq .transf-eq x = ≈-trans id-right (≈-sym id-left)
+realise .fmor-comp {X} {Y} {Z} f g =
+  ≈-trans (colim X .isColimit .colambda-cong eq)
+    (colim X .isColimit .colambda-ext _
+      (colim Y .isColimit .colambda _ (push f) ∘ colim X .isColimit .colambda _ (push g)))
+  where
+    eq : ≃-NatTrans (push (Mor-∘ f g))
+           (constFmor (colim Y .isColimit .colambda _ (push f) ∘ colim X .isColimit .colambda _ (push g))
+             ∘N colim X .cocone)
+    eq .transf-eq x =
+      begin
+        colim Z .cocone .transf (f .idxf $s (g .idxf $s x)) ∘
+          (id _ ∘ (f .famf .transf (g .idxf $s x) ∘ g .famf .transf x))
+      ≈⟨ ∘-cong ≈-refl id-left ⟩
+        colim Z .cocone .transf (f .idxf $s (g .idxf $s x)) ∘ (f .famf .transf (g .idxf $s x) ∘ g .famf .transf x)
+      ≈˘⟨ assoc _ _ _ ⟩
+        (colim Z .cocone .transf (f .idxf $s (g .idxf $s x)) ∘ f .famf .transf (g .idxf $s x)) ∘ g .famf .transf x
+      ≈˘⟨ ∘-cong (colim Y .isColimit .colambda-coeval _ (push f) .transf-eq (g .idxf $s x)) ≈-refl ⟩
+        (colim Y .isColimit .colambda _ (push f) ∘ colim Y .cocone .transf (g .idxf $s x)) ∘ g .famf .transf x
+      ≈⟨ assoc _ _ _ ⟩
+        colim Y .isColimit .colambda _ (push f) ∘ (colim Y .cocone .transf (g .idxf $s x) ∘ g .famf .transf x)
+      ≈˘⟨ ∘-cong ≈-refl (colim X .isColimit .colambda-coeval _ (push g) .transf-eq x) ⟩
+        colim Y .isColimit .colambda _ (push f) ∘ (colim X .isColimit .colambda _ (push g) ∘ colim X .cocone .transf x)
+      ≈˘⟨ assoc _ _ _ ⟩
+        (colim Y .isColimit .colambda _ (push f) ∘ colim X .isColimit .colambda _ (push g)) ∘ colim X .cocone .transf x
+      ∎ where open ≈-Reasoning isEquiv
+
+-- Realisation preserves setoid-indexed coproducts: the realise-image of the
+-- coproduct cocone in the category of families is a colimit in ℰ.
+module _ (S : Setoid os es) (D : Functor (setoid→category S) cat) where
+
+  private
+    module C = Category cat
+    ⨿D = bigCoproducts S D
+
+    inS : ∀ s → Category._⇒_ cat (D .fobj s) (⨿D .apex)
+    inS s = ⨿D .cocone .transf s
+
+  realiseCocone : NatTrans (realise ∘F D) (constF (setoid→category S) (realise .fobj (⨿D .apex)))
+  realiseCocone .transf s = realise .fmor (inS s)
+  realiseCocone .natural {s₁} {s₂} ⟪ e ⟫ =
+    ≈-trans id-left
+      (≈-trans (realise .fmor-cong (C.≈-trans (C.≈-sym C.id-left) (⨿D .cocone .natural ⟪ e ⟫)))
+        (realise .fmor-comp _ _))
+
+  private
+    -- Flatten a cocone under realise ∘F D to a cocone on the total family.
+    flat : ∀ x (α : NatTrans (realise ∘F D) (constF (setoid→category S) x)) →
+           NatTrans (fam→functor (⨿D .apex .fam)) (constF (setoid→category (⨿D .apex .idx)) x)
+    flat x α .transf (s , d) = α .transf s ∘ colim (D .fobj s) .cocone .transf d
+    flat x α .natural {s₁ , d₁} {s₂ , d₂} ⟪ es ,ₚ ed ⟫ =
+      begin
+        id _ ∘ (α .transf s₁ ∘ colim (D .fobj s₁) .cocone .transf d₁)
+      ≈⟨ id-left ⟩
+        α .transf s₁ ∘ colim (D .fobj s₁) .cocone .transf d₁
+      ≈⟨ ∘-cong (≈-trans (≈-sym id-left) (α .natural ⟪ es ⟫)) ≈-refl ⟩
+        (α .transf s₂ ∘ realise .fmor (D .fmor ⟪ es ⟫)) ∘ colim (D .fobj s₁) .cocone .transf d₁
+      ≈⟨ assoc _ _ _ ⟩
+        α .transf s₂ ∘ (realise .fmor (D .fmor ⟪ es ⟫) ∘ colim (D .fobj s₁) .cocone .transf d₁)
+      ≈⟨ ∘-cong ≈-refl (colim (D .fobj s₁) .isColimit .colambda-coeval _ (push (D .fmor ⟪ es ⟫)) .transf-eq d₁) ⟩
+        α .transf s₂ ∘ (colim (D .fobj s₂) .cocone .transf (D .fmor ⟪ es ⟫ .idxf $s d₁) ∘ D .fmor ⟪ es ⟫ .famf .transf d₁)
+      ≈⟨ ∘-cong ≈-refl (∘-cong (≈-trans (≈-sym id-left) (colim (D .fobj s₂) .cocone .natural ⟪ ed ⟫)) ≈-refl) ⟩
+        α .transf s₂ ∘ ((colim (D .fobj s₂) .cocone .transf d₂ ∘ D .fobj s₂ .fam .subst ed) ∘ D .fmor ⟪ es ⟫ .famf .transf d₁)
+      ≈⟨ ∘-cong ≈-refl (assoc _ _ _) ⟩
+        α .transf s₂ ∘ (colim (D .fobj s₂) .cocone .transf d₂ ∘ (D .fobj s₂ .fam .subst ed ∘ D .fmor ⟪ es ⟫ .famf .transf d₁))
+      ≈˘⟨ assoc _ _ _ ⟩
+        (α .transf s₂ ∘ colim (D .fobj s₂) .cocone .transf d₂) ∘ (D .fobj s₂ .fam .subst ed ∘ D .fmor ⟪ es ⟫ .famf .transf d₁)
+      ∎ where open ≈-Reasoning isEquiv
+
+  realise-preserves-coproducts : IsColimit (realise ∘F D) (realise .fobj (⨿D .apex)) realiseCocone
+  realise-preserves-coproducts .IsColimit.colambda x α =
+    colim (⨿D .apex) .isColimit .colambda x (flat x α)
+  realise-preserves-coproducts .IsColimit.colambda-cong {x} {α} {β} α≃β =
+    colim (⨿D .apex) .isColimit .colambda-cong eq
+    where
+      eq : ≃-NatTrans (flat x α) (flat x β)
+      eq .transf-eq (s , d) = ∘-cong (α≃β .transf-eq s) ≈-refl
+  realise-preserves-coproducts .IsColimit.colambda-coeval x α .transf-eq s =
+    ≈-trans (≈-sym (colim (D .fobj s) .isColimit .colambda-ext x h))
+      (≈-trans (colim (D .fobj s) .isColimit .colambda-cong eq)
+        (colim (D .fobj s) .isColimit .colambda-ext x (α .transf s)))
+    where
+      h : Category._⇒_ ℰ (realise .fobj (D .fobj s)) x
+      h = colim (⨿D .apex) .isColimit .colambda x (flat x α) ∘ realise .fmor (inS s)
+
+      eq : ≃-NatTrans (constFmor h ∘N colim (D .fobj s) .cocone)
+                      (constFmor (α .transf s) ∘N colim (D .fobj s) .cocone)
+      eq .transf-eq d =
+        begin
+          h ∘ colim (D .fobj s) .cocone .transf d
+        ≈⟨ assoc _ _ _ ⟩
+          colim (⨿D .apex) .isColimit .colambda x (flat x α) ∘ (realise .fmor (inS s) ∘ colim (D .fobj s) .cocone .transf d)
+        ≈⟨ ∘-cong ≈-refl (colim (D .fobj s) .isColimit .colambda-coeval _ (push (inS s)) .transf-eq d) ⟩
+          colim (⨿D .apex) .isColimit .colambda x (flat x α) ∘ (colim (⨿D .apex) .cocone .transf (s , d) ∘ id _)
+        ≈⟨ ∘-cong ≈-refl id-right ⟩
+          colim (⨿D .apex) .isColimit .colambda x (flat x α) ∘ colim (⨿D .apex) .cocone .transf (s , d)
+        ≈⟨ colim (⨿D .apex) .isColimit .colambda-coeval _ (flat x α) .transf-eq (s , d) ⟩
+          α .transf s ∘ colim (D .fobj s) .cocone .transf d
+        ∎ where open ≈-Reasoning isEquiv
+  realise-preserves-coproducts .IsColimit.colambda-ext x f =
+    ≈-trans (colim (⨿D .apex) .isColimit .colambda-cong eq)
+      (colim (⨿D .apex) .isColimit .colambda-ext x f)
+    where
+      eq : ≃-NatTrans _ _
+      eq .transf-eq (s , d) =
+        begin
+          (f ∘ realise .fmor (inS s)) ∘ colim (D .fobj s) .cocone .transf d
+        ≈⟨ assoc _ _ _ ⟩
+          f ∘ (realise .fmor (inS s) ∘ colim (D .fobj s) .cocone .transf d)
+        ≈⟨ ∘-cong ≈-refl (colim (D .fobj s) .isColimit .colambda-coeval _ (push (inS s)) .transf-eq d) ⟩
+          f ∘ (colim (⨿D .apex) .cocone .transf (s , d) ∘ id _)
+        ≈⟨ ∘-cong ≈-refl id-right ⟩
+          f ∘ colim (⨿D .apex) .cocone .transf (s , d)
+        ∎ where open ≈-Reasoning isEquiv
+
+-- Realisation preserves the terminal object: the coproduct over the singleton
+-- setoid of the terminal fibre is terminal.
+module _ (ℰT : HasTerminal ℰ) where
+
+  private
+    module ℰT = HasTerminal ℰT
+
+    𝟙F = terminal ℰT .HasTerminal.witness
+
+    inT = colim 𝟙F .cocone .transf (lift tt)
+
+    roundtrip : (inT ∘ ℰT.to-terminal) ≈ id (realise .fobj 𝟙F)
+    roundtrip =
+      ≈-trans (≈-sym (colim 𝟙F .isColimit .colambda-ext _ (inT ∘ ℰT.to-terminal)))
+        (≈-trans (colim 𝟙F .isColimit .colambda-cong eq)
+          (colim 𝟙F .isColimit .colambda-ext _ (id _)))
+      where
+        eq : ≃-NatTrans (constFmor (inT ∘ ℰT.to-terminal) ∘N colim 𝟙F .cocone)
+                        (constFmor (id _) ∘N colim 𝟙F .cocone)
+        eq .transf-eq u =
+          begin
+            (inT ∘ ℰT.to-terminal) ∘ colim 𝟙F .cocone .transf u
+          ≈⟨ assoc _ _ _ ⟩
+            inT ∘ (ℰT.to-terminal ∘ colim 𝟙F .cocone .transf u)
+          ≈⟨ ∘-cong ≈-refl (ℰT.to-terminal-unique _ (id _)) ⟩
+            inT ∘ id _
+          ≈⟨ id-right ⟩
+            inT
+          ≈˘⟨ id-left ⟩
+            id _ ∘ colim 𝟙F .cocone .transf u
+          ∎ where open ≈-Reasoning isEquiv
+
+  realise-terminal : IsTerminal ℰ (realise .fobj 𝟙F)
+  realise-terminal .IsTerminal.to-terminal = inT ∘ ℰT.to-terminal
+  realise-terminal .IsTerminal.to-terminal-ext f =
+    begin
+      inT ∘ ℰT.to-terminal
+    ≈⟨ ∘-cong ≈-refl (ℰT.to-terminal-ext (ℰT.to-terminal ∘ f)) ⟩
+      inT ∘ (ℰT.to-terminal ∘ f)
+    ≈˘⟨ assoc _ _ _ ⟩
+      (inT ∘ ℰT.to-terminal) ∘ f
+    ≈⟨ ∘-cong roundtrip ≈-refl ⟩
+      id _ ∘ f
+    ≈⟨ id-left ⟩
+      f
+    ∎ where open ≈-Reasoning isEquiv
+
+-- Realisation preserves binary products, given products and exponentials on ℰ
+-- (the exponentials supplying distributivity of products over the colimits).
+module _ (ℰP : HasProducts ℰ) (ℰE : HasExponentials ℰ ℰP) where
+
+  private
+    module ℰP = HasProducts ℰP
+    module PC = product-cocontinuity ℰP ℰE
+
+    open fam.CategoryOfFamilies.products os es ℰ ℰP using (_⊗_) renaming (products to famProducts)
+
+  module _ (X Y : Category.obj cat) where
+
+    private
+      DX = fam→functor (X .fam)
+      DY = fam→functor (Y .fam)
+      D⊗ = fam→functor ((X ⊗ Y) .fam)
+      R×R = ℰP.prod (realise .fobj X) (realise .fobj Y)
+
+    prodCocone : NatTrans D⊗ (constF (setoid→category ((X ⊗ Y) .idx)) R×R)
+    prodCocone .transf (i , j) = ℰP.prod-m (colim X .cocone .transf i) (colim Y .cocone .transf j)
+    prodCocone .natural {i₁ , j₁} {i₂ , j₂} ⟪ ei ,ₚ ej ⟫ =
+      begin
+        id _ ∘ ℰP.prod-m (colim X .cocone .transf i₁) (colim Y .cocone .transf j₁)
+      ≈⟨ id-left ⟩
+        ℰP.prod-m (colim X .cocone .transf i₁) (colim Y .cocone .transf j₁)
+      ≈⟨ ℰP.prod-m-cong (≈-trans (≈-sym id-left) (colim X .cocone .natural ⟪ ei ⟫))
+                        (≈-trans (≈-sym id-left) (colim Y .cocone .natural ⟪ ej ⟫)) ⟩
+        ℰP.prod-m (colim X .cocone .transf i₂ ∘ X .fam .subst ei) (colim Y .cocone .transf j₂ ∘ Y .fam .subst ej)
+      ≈⟨ ℰP.prod-m-comp _ _ _ _ ⟩
+        ℰP.prod-m (colim X .cocone .transf i₂) (colim Y .cocone .transf j₂) ∘ ℰP.prod-m (X .fam .subst ei) (Y .fam .subst ej)
+      ∎ where open ≈-Reasoning isEquiv
+
+    private
+      -- Restrict a cocone on the total diagram to the fibre at i.
+      restr : ∀ x (α : NatTrans D⊗ (constF (setoid→category ((X ⊗ Y) .idx)) x)) i →
+              NatTrans (PC.B×D' (X .fam .fm i) DY (colim Y)) (constF (setoid→category (Y .idx)) x)
+      restr x α i .transf j = α .transf (i , j)
+      restr x α i .natural {j₁} {j₂} ⟪ e ⟫ =
+        begin
+          id _ ∘ α .transf (i , j₁)
+        ≈⟨ α .natural ⟪ X .idx .Setoid.refl ,ₚ e ⟫ ⟩
+          α .transf (i , j₂) ∘ ℰP.prod-m (X .fam .subst (X .idx .Setoid.refl)) (Y .fam .subst e)
+        ≈⟨ ∘-cong ≈-refl (ℰP.prod-m-cong (X .fam .refl*) ≈-refl) ⟩
+          α .transf (i , j₂) ∘ ℰP.prod-m (id _) (Y .fam .subst e)
+        ∎ where open ≈-Reasoning isEquiv
+
+      -- Mediate each fibre through the left-handed cocontinuity of the product.
+      inner : ∀ x α i → Category._⇒_ ℰ (ℰP.prod (X .fam .fm i) (realise .fobj Y)) x
+      inner x α i = PC.B×-preserves-colimit (X .fam .fm i) DY (colim Y) .colambda x (restr x α i)
+
+      eq₁ : ∀ x α i₁ i₂ (e : X .idx .Setoid._≈_ i₁ i₂) →
+            ≃-NatTrans (constFmor (inner x α i₁) ∘N PC.B×-cocone (X .fam .fm i₁) DY (colim Y))
+                       (constFmor (inner x α i₂ ∘ ℰP.prod-m (X .fam .subst e) (id _)) ∘N PC.B×-cocone (X .fam .fm i₁) DY (colim Y))
+      eq₁ x α i₁ i₂ e .transf-eq j =
+        begin
+          inner x α i₁ ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j)
+        ≈⟨ PC.B×-preserves-colimit _ DY (colim Y) .colambda-coeval x (restr x α i₁) .transf-eq j ⟩
+          α .transf (i₁ , j)
+        ≈⟨ ≈-trans (≈-sym id-left) (α .natural ⟪ e ,ₚ Y .idx .Setoid.refl ⟫) ⟩
+          α .transf (i₂ , j) ∘ ℰP.prod-m (X .fam .subst e) (Y .fam .subst (Y .idx .Setoid.refl))
+        ≈⟨ ∘-cong ≈-refl (ℰP.prod-m-cong ≈-refl (Y .fam .refl*)) ⟩
+          α .transf (i₂ , j) ∘ ℰP.prod-m (X .fam .subst e) (id _)
+        ≈˘⟨ ∘-cong (PC.B×-preserves-colimit _ DY (colim Y) .colambda-coeval x (restr x α i₂) .transf-eq j) ≈-refl ⟩
+          (inner x α i₂ ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j)) ∘ ℰP.prod-m (X .fam .subst e) (id _)
+        ≈⟨ assoc _ _ _ ⟩
+          inner x α i₂ ∘ (ℰP.prod-m (id _) (colim Y .cocone .transf j) ∘ ℰP.prod-m (X .fam .subst e) (id _))
+        ≈˘⟨ ∘-cong ≈-refl (ℰP.prod-m-comp _ _ _ _) ⟩
+          inner x α i₂ ∘ ℰP.prod-m (id _ ∘ X .fam .subst e) (colim Y .cocone .transf j ∘ id _)
+        ≈⟨ ∘-cong ≈-refl (ℰP.prod-m-cong (≈-trans id-left (≈-sym id-right)) (≈-trans id-right (≈-sym id-left))) ⟩
+          inner x α i₂ ∘ ℰP.prod-m (X .fam .subst e ∘ id _) (id _ ∘ colim Y .cocone .transf j)
+        ≈⟨ ∘-cong ≈-refl (ℰP.prod-m-comp _ _ _ _) ⟩
+          inner x α i₂ ∘ (ℰP.prod-m (X .fam .subst e) (id _) ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j))
+        ≈˘⟨ assoc _ _ _ ⟩
+          (inner x α i₂ ∘ ℰP.prod-m (X .fam .subst e) (id _)) ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j)
+        ∎ where open ≈-Reasoning isEquiv
+
+      -- The fibrewise mediators form a cocone on the X-side diagram.
+      outer : ∀ x α → NatTrans (PC.D×B DX (realise .fobj Y) (colim X)) (constF (setoid→category (X .idx)) x)
+      outer x α .transf i = inner x α i
+      outer x α .natural {i₁} {i₂} ⟪ e ⟫ =
+        begin
+          id _ ∘ inner x α i₁
+        ≈⟨ id-left ⟩
+          inner x α i₁
+        ≈˘⟨ PC.B×-preserves-colimit _ DY (colim Y) .colambda-ext x (inner x α i₁) ⟩
+          PC.B×-preserves-colimit _ DY (colim Y) .colambda x (constFmor (inner x α i₁) ∘N PC.B×-cocone _ DY (colim Y))
+        ≈⟨ PC.B×-preserves-colimit _ DY (colim Y) .colambda-cong (eq₁ x α i₁ i₂ e) ⟩
+          PC.B×-preserves-colimit _ DY (colim Y) .colambda x
+            (constFmor (inner x α i₂ ∘ ℰP.prod-m (X .fam .subst e) (id _)) ∘N PC.B×-cocone _ DY (colim Y))
+        ≈⟨ PC.B×-preserves-colimit _ DY (colim Y) .colambda-ext x _ ⟩
+          inner x α i₂ ∘ ℰP.prod-m (X .fam .subst e) (id _)
+        ∎ where open ≈-Reasoning isEquiv
+
+    realise-preserves-products : IsColimit D⊗ R×R prodCocone
+    realise-preserves-products .colambda x α =
+      PC.×B-preserves-colimit DX (realise .fobj Y) (colim X) .colambda x (outer x α)
+    realise-preserves-products .colambda-cong {x} {α} {β} α≃β =
+      PC.×B-preserves-colimit DX (realise .fobj Y) (colim X) .colambda-cong eq
+      where
+        eq : ≃-NatTrans (outer x α) (outer x β)
+        eq .transf-eq i =
+          PC.B×-preserves-colimit _ DY (colim Y) .colambda-cong eq'
+          where
+            eq' : ≃-NatTrans (restr x α i) (restr x β i)
+            eq' .transf-eq j = α≃β .transf-eq (i , j)
+    realise-preserves-products .colambda-coeval x α .transf-eq (i , j) =
+      begin
+        realise-preserves-products .colambda x α ∘ ℰP.prod-m (colim X .cocone .transf i) (colim Y .cocone .transf j)
+      ≈⟨ ∘-cong ≈-refl (≈-trans (ℰP.prod-m-cong (≈-sym id-right) (≈-sym id-left)) (ℰP.prod-m-comp _ _ _ _)) ⟩
+        realise-preserves-products .colambda x α ∘ (ℰP.prod-m (colim X .cocone .transf i) (id _) ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j))
+      ≈˘⟨ assoc _ _ _ ⟩
+        (realise-preserves-products .colambda x α ∘ ℰP.prod-m (colim X .cocone .transf i) (id _)) ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j)
+      ≈⟨ ∘-cong (PC.×B-preserves-colimit DX (realise .fobj Y) (colim X) .colambda-coeval x (outer x α) .transf-eq i) ≈-refl ⟩
+        inner x α i ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j)
+      ≈⟨ PC.B×-preserves-colimit _ DY (colim Y) .colambda-coeval x (restr x α i) .transf-eq j ⟩
+        α .transf (i , j)
+      ∎ where open ≈-Reasoning isEquiv
+    realise-preserves-products .colambda-ext x f =
+      ≈-trans
+        (PC.×B-preserves-colimit DX (realise .fobj Y) (colim X) .colambda-cong eq)
+        (PC.×B-preserves-colimit DX (realise .fobj Y) (colim X) .colambda-ext x f)
+      where
+        eq : ≃-NatTrans (outer x (constFmor f ∘N prodCocone))
+                        (constFmor f ∘N PC.×B-cocone DX (realise .fobj Y) (colim X))
+        eq .transf-eq i =
+          ≈-trans (PC.B×-preserves-colimit _ DY (colim Y) .colambda-cong eq')
+            (PC.B×-preserves-colimit _ DY (colim Y) .colambda-ext x (f ∘ ℰP.prod-m (colim X .cocone .transf i) (id _)))
+          where
+            eq' : ≃-NatTrans (restr x (constFmor f ∘N prodCocone) i)
+                             (constFmor (f ∘ ℰP.prod-m (colim X .cocone .transf i) (id _)) ∘N PC.B×-cocone (X .fam .fm i) DY (colim Y))
+            eq' .transf-eq j =
+              begin
+                f ∘ ℰP.prod-m (colim X .cocone .transf i) (colim Y .cocone .transf j)
+              ≈⟨ ∘-cong ≈-refl (≈-trans (ℰP.prod-m-cong (≈-sym id-right) (≈-sym id-left)) (ℰP.prod-m-comp _ _ _ _)) ⟩
+                f ∘ (ℰP.prod-m (colim X .cocone .transf i) (id _) ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j))
+              ≈˘⟨ assoc _ _ _ ⟩
+                (f ∘ ℰP.prod-m (colim X .cocone .transf i) (id _)) ∘ ℰP.prod-m (id _) (colim Y .cocone .transf j)
+              ∎ where open ≈-Reasoning isEquiv
+
+    -- The two colimits of the total diagram are canonically isomorphic.
+    realise-products-iso : Category.Iso ℰ (realise .fobj (X ⊗ Y)) R×R
+    realise-products-iso .Category.Iso.fwd =
+      colim (X ⊗ Y) .isColimit .colambda _ prodCocone
+    realise-products-iso .Category.Iso.bwd =
+      realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone)
+    realise-products-iso .Category.Iso.fwd∘bwd≈id =
+      ≈-trans (≈-sym (realise-preserves-products .colambda-ext _ _))
+        (≈-trans (realise-preserves-products .colambda-cong eq)
+          (realise-preserves-products .colambda-ext _ (id _)))
+      where
+        eq : ≃-NatTrans
+               (constFmor (colim (X ⊗ Y) .isColimit .colambda _ prodCocone ∘ realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone)) ∘N prodCocone)
+               (constFmor (id _) ∘N prodCocone)
+        eq .transf-eq (i , j) =
+          begin
+            (colim (X ⊗ Y) .isColimit .colambda _ prodCocone ∘ realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone)) ∘ prodCocone .transf (i , j)
+          ≈⟨ assoc _ _ _ ⟩
+            colim (X ⊗ Y) .isColimit .colambda _ prodCocone ∘ (realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone) ∘ prodCocone .transf (i , j))
+          ≈⟨ ∘-cong ≈-refl (realise-preserves-products .colambda-coeval _ (colim (X ⊗ Y) .cocone) .transf-eq (i , j)) ⟩
+            colim (X ⊗ Y) .isColimit .colambda _ prodCocone ∘ colim (X ⊗ Y) .cocone .transf (i , j)
+          ≈⟨ colim (X ⊗ Y) .isColimit .colambda-coeval _ prodCocone .transf-eq (i , j) ⟩
+            prodCocone .transf (i , j)
+          ≈˘⟨ id-left ⟩
+            id _ ∘ prodCocone .transf (i , j)
+          ∎ where open ≈-Reasoning isEquiv
+    realise-products-iso .Category.Iso.bwd∘fwd≈id =
+      ≈-trans (≈-sym (colim (X ⊗ Y) .isColimit .colambda-ext _ _))
+        (≈-trans (colim (X ⊗ Y) .isColimit .colambda-cong eq)
+          (colim (X ⊗ Y) .isColimit .colambda-ext _ (id _)))
+      where
+        eq : ≃-NatTrans
+               (constFmor (realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone) ∘ colim (X ⊗ Y) .isColimit .colambda _ prodCocone) ∘N colim (X ⊗ Y) .cocone)
+               (constFmor (id _) ∘N colim (X ⊗ Y) .cocone)
+        eq .transf-eq (i , j) =
+          begin
+            (realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone) ∘ colim (X ⊗ Y) .isColimit .colambda _ prodCocone) ∘ colim (X ⊗ Y) .cocone .transf (i , j)
+          ≈⟨ assoc _ _ _ ⟩
+            realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone) ∘ (colim (X ⊗ Y) .isColimit .colambda _ prodCocone ∘ colim (X ⊗ Y) .cocone .transf (i , j))
+          ≈⟨ ∘-cong ≈-refl (colim (X ⊗ Y) .isColimit .colambda-coeval _ prodCocone .transf-eq (i , j)) ⟩
+            realise-preserves-products .colambda _ (colim (X ⊗ Y) .cocone) ∘ prodCocone .transf (i , j)
+          ≈⟨ realise-preserves-products .colambda-coeval _ (colim (X ⊗ Y) .cocone) .transf-eq (i , j) ⟩
+            colim (X ⊗ Y) .cocone .transf (i , j)
+          ≈˘⟨ id-left ⟩
+            id _ ∘ colim (X ⊗ Y) .cocone .transf (i , j)
+          ∎ where open ≈-Reasoning isEquiv
+
+    -- The comparison iso commutes with the product projections.
+    private
+      p₁F = famProducts .HasProducts.p₁ {X} {Y}
+      p₂F = famProducts .HasProducts.p₂ {X} {Y}
+
+    realise-products-p₁ : (ℰP.p₁ ∘ realise-products-iso .Category.Iso.fwd) ≈ realise .fmor p₁F
+    realise-products-p₁ =
+      ≈-trans (≈-sym (colim (X ⊗ Y) .isColimit .colambda-ext _ _))
+        (≈-trans (colim (X ⊗ Y) .isColimit .colambda-cong eq)
+          (colim (X ⊗ Y) .isColimit .colambda-ext _ (realise .fmor p₁F)))
+      where
+        eq : ≃-NatTrans (constFmor (ℰP.p₁ ∘ realise-products-iso .Category.Iso.fwd) ∘N colim (X ⊗ Y) .cocone)
+                        (constFmor (realise .fmor p₁F) ∘N colim (X ⊗ Y) .cocone)
+        eq .transf-eq (i , j) =
+          begin
+            (ℰP.p₁ ∘ realise-products-iso .Category.Iso.fwd) ∘ colim (X ⊗ Y) .cocone .transf (i , j)
+          ≈⟨ assoc _ _ _ ⟩
+            ℰP.p₁ ∘ (realise-products-iso .Category.Iso.fwd ∘ colim (X ⊗ Y) .cocone .transf (i , j))
+          ≈⟨ ∘-cong ≈-refl (colim (X ⊗ Y) .isColimit .colambda-coeval _ prodCocone .transf-eq (i , j)) ⟩
+            ℰP.p₁ ∘ ℰP.prod-m (colim X .cocone .transf i) (colim Y .cocone .transf j)
+          ≈⟨ ℰP.pair-p₁ _ _ ⟩
+            colim X .cocone .transf i ∘ ℰP.p₁
+          ≈˘⟨ colim (X ⊗ Y) .isColimit .colambda-coeval _ (push p₁F) .transf-eq (i , j) ⟩
+            realise .fmor p₁F ∘ colim (X ⊗ Y) .cocone .transf (i , j)
+          ∎ where open ≈-Reasoning isEquiv
+
+    realise-products-p₂ : (ℰP.p₂ ∘ realise-products-iso .Category.Iso.fwd) ≈ realise .fmor p₂F
+    realise-products-p₂ =
+      ≈-trans (≈-sym (colim (X ⊗ Y) .isColimit .colambda-ext _ _))
+        (≈-trans (colim (X ⊗ Y) .isColimit .colambda-cong eq)
+          (colim (X ⊗ Y) .isColimit .colambda-ext _ (realise .fmor p₂F)))
+      where
+        eq : ≃-NatTrans (constFmor (ℰP.p₂ ∘ realise-products-iso .Category.Iso.fwd) ∘N colim (X ⊗ Y) .cocone)
+                        (constFmor (realise .fmor p₂F) ∘N colim (X ⊗ Y) .cocone)
+        eq .transf-eq (i , j) =
+          begin
+            (ℰP.p₂ ∘ realise-products-iso .Category.Iso.fwd) ∘ colim (X ⊗ Y) .cocone .transf (i , j)
+          ≈⟨ assoc _ _ _ ⟩
+            ℰP.p₂ ∘ (realise-products-iso .Category.Iso.fwd ∘ colim (X ⊗ Y) .cocone .transf (i , j))
+          ≈⟨ ∘-cong ≈-refl (colim (X ⊗ Y) .isColimit .colambda-coeval _ prodCocone .transf-eq (i , j)) ⟩
+            ℰP.p₂ ∘ ℰP.prod-m (colim X .cocone .transf i) (colim Y .cocone .transf j)
+          ≈⟨ ℰP.pair-p₂ _ _ ⟩
+            colim Y .cocone .transf j ∘ ℰP.p₂
+          ≈˘⟨ colim (X ⊗ Y) .isColimit .colambda-coeval _ (push p₂F) .transf-eq (i , j) ⟩
+            realise .fmor p₂F ∘ colim (X ⊗ Y) .cocone .transf (i , j)
+          ∎ where open ≈-Reasoning isEquiv
+
+-- The singleton embedding, right adjoint to realisation.
+η : Functor ℰ cat
+η .fobj A = simple[ 𝟙 , A ]
+η .fmor f = simplef[ prop-setoid.idS _ , f ]
+η .fmor-cong f₁≈f₂ .idxf-eq = prop-setoid.≃m-isEquivalence .IsEquivalence.refl
+η .fmor-cong f₁≈f₂ .famf-eq .indexed-family._≃f_.transf-eq = ≈-trans id-left f₁≈f₂
+η .fmor-id .idxf-eq = prop-setoid.≃m-isEquivalence .IsEquivalence.refl
+η .fmor-id .famf-eq .indexed-family._≃f_.transf-eq = id-left
+η .fmor-comp f g .idxf-eq = prop-setoid.to-𝟙-unique _ _
+η .fmor-comp f g .famf-eq .indexed-family._≃f_.transf-eq = ≈-trans id-left (≈-sym id-left)
+
+-- The counit: realising a singleton family collapses to the object itself.
+module _ (A : Category.obj ℰ) where
+
+  private
+    ηA = η .fobj A
+
+    flatten : NatTrans (fam→functor (ηA .fam)) (constF (setoid→category 𝟙) A)
+    flatten .transf _ = id A
+    flatten .natural _ = ≈-refl
+
+  realise-η-iso : Category.Iso ℰ (realise .fobj ηA) A
+  realise-η-iso .Category.Iso.fwd = colim ηA .isColimit .colambda A flatten
+  realise-η-iso .Category.Iso.bwd = colim ηA .cocone .transf (lift tt)
+  realise-η-iso .Category.Iso.fwd∘bwd≈id =
+    ≈-trans (colim ηA .isColimit .colambda-coeval A flatten .transf-eq (lift tt)) ≈-refl
+  realise-η-iso .Category.Iso.bwd∘fwd≈id =
+    ≈-trans (≈-sym (colim ηA .isColimit .colambda-ext _ _))
+      (≈-trans (colim ηA .isColimit .colambda-cong eq)
+        (colim ηA .isColimit .colambda-ext _ (id _)))
+    where
+      eq : ≃-NatTrans
+             (constFmor (colim ηA .cocone .transf (lift tt) ∘ colim ηA .isColimit .colambda A flatten) ∘N colim ηA .cocone)
+             (constFmor (id _) ∘N colim ηA .cocone)
+      eq .transf-eq u =
+        begin
+          (colim ηA .cocone .transf (lift tt) ∘ colim ηA .isColimit .colambda A flatten) ∘ colim ηA .cocone .transf u
+        ≈⟨ assoc _ _ _ ⟩
+          colim ηA .cocone .transf (lift tt) ∘ (colim ηA .isColimit .colambda A flatten ∘ colim ηA .cocone .transf u)
+        ≈⟨ ∘-cong ≈-refl (colim ηA .isColimit .colambda-coeval A flatten .transf-eq u) ⟩
+          colim ηA .cocone .transf (lift tt) ∘ id A
+        ≈⟨ id-right ⟩
+          colim ηA .cocone .transf (lift tt)
+        ≈˘⟨ id-left ⟩
+          id _ ∘ colim ηA .cocone .transf u
+        ∎ where open ≈-Reasoning isEquiv
+
+-- The adjunction realise ⊣ η, in transposition form.
+module _ {W : Category.obj cat} {X : Category.obj ℰ} where
+
+  transpose : Category._⇒_ cat W (η .fobj X) → Category._⇒_ ℰ (realise .fobj W) X
+  transpose f = colim W .isColimit .colambda X cone
+    where
+      cone : NatTrans (fam→functor (W .fam)) (constF (setoid→category (W .idx)) X)
+      cone .transf i = f .famf .transf i
+      cone .natural {i₁} {i₂} ⟪ e ⟫ = ≈-sym (f .famf .natural e)
+
+  untranspose : Category._⇒_ ℰ (realise .fobj W) X → Category._⇒_ cat W (η .fobj X)
+  untranspose g .idxf = to-𝟙
+  untranspose g .famf .transf i = g ∘ colim W .cocone .transf i
+  untranspose g .famf .natural {i₁} {i₂} e =
+    begin
+      (g ∘ colim W .cocone .transf i₂) ∘ W .fam .subst e
+    ≈⟨ assoc _ _ _ ⟩
+      g ∘ (colim W .cocone .transf i₂ ∘ W .fam .subst e)
+    ≈⟨ ∘-cong ≈-refl (≈-trans (≈-sym (colim W .cocone .natural ⟪ e ⟫)) id-left) ⟩
+      g ∘ colim W .cocone .transf i₁
+    ≈˘⟨ id-left ⟩
+      id _ ∘ (g ∘ colim W .cocone .transf i₁)
+    ∎ where open ≈-Reasoning isEquiv
+
+  transpose-cong : ∀ {f₁ f₂ : Category._⇒_ cat W (η .fobj X)} →
+                   Category._≈_ cat f₁ f₂ → transpose f₁ ≈ transpose f₂
+  transpose-cong {f₁} {f₂} f₁≃f₂ = colim W .isColimit .colambda-cong eq
+    where
+      eq : ≃-NatTrans _ _
+      eq .transf-eq i =
+        ≈-trans (≈-sym id-left) (f₁≃f₂ .famf-eq .indexed-family._≃f_.transf-eq {i})
+
+  untranspose-cong : ∀ {g₁ g₂ : Category._⇒_ ℰ (realise .fobj W) X} →
+                     g₁ ≈ g₂ → Category._≈_ cat (untranspose g₁) (untranspose g₂)
+  untranspose-cong g₁≈g₂ .idxf-eq = prop-setoid.to-𝟙-unique _ _
+  untranspose-cong g₁≈g₂ .famf-eq .indexed-family._≃f_.transf-eq =
+    ≈-trans id-left (∘-cong g₁≈g₂ ≈-refl)
+
+  transpose-untranspose : ∀ (g : Category._⇒_ ℰ (realise .fobj W) X) →
+                          transpose (untranspose g) ≈ g
+  transpose-untranspose g =
+    ≈-trans (colim W .isColimit .colambda-cong eq) (colim W .isColimit .colambda-ext _ g)
+    where
+      eq : ≃-NatTrans _ (constFmor g ∘N colim W .cocone)
+      eq .transf-eq i = ≈-refl
+
+  untranspose-transpose : ∀ (f : Category._⇒_ cat W (η .fobj X)) →
+                          Category._≈_ cat (untranspose (transpose f)) f
+  untranspose-transpose f .idxf-eq = prop-setoid.to-𝟙-unique _ _
+  untranspose-transpose f .famf-eq .indexed-family._≃f_.transf-eq {i} =
+    ≈-trans id-left (colim W .isColimit .colambda-coeval _ _ .transf-eq i)
+
+  -- Transposition factors through realisation and the counit.
+  transpose-realise : ∀ (f : Category._⇒_ cat W (η .fobj X)) →
+                      transpose f ≈ (realise-η-iso X .Category.Iso.fwd ∘ realise .fmor f)
+  transpose-realise f =
+    ≈-sym (≈-trans (≈-sym (colim W .isColimit .colambda-ext _ _))
+      (colim W .isColimit .colambda-cong eq))
+    where
+      eq : ≃-NatTrans (constFmor (realise-η-iso X .Category.Iso.fwd ∘ realise .fmor f) ∘N colim W .cocone) _
+      eq .transf-eq i =
+        begin
+          (realise-η-iso X .Category.Iso.fwd ∘ realise .fmor f) ∘ colim W .cocone .transf i
+        ≈⟨ assoc _ _ _ ⟩
+          realise-η-iso X .Category.Iso.fwd ∘ (realise .fmor f ∘ colim W .cocone .transf i)
+        ≈⟨ ∘-cong ≈-refl (colim W .isColimit .colambda-coeval _ (push f) .transf-eq i) ⟩
+          realise-η-iso X .Category.Iso.fwd ∘ (colim (η .fobj X) .cocone .transf (f .idxf $s i) ∘ f .famf .transf i)
+        ≈˘⟨ assoc _ _ _ ⟩
+          (realise-η-iso X .Category.Iso.fwd ∘ colim (η .fobj X) .cocone .transf (f .idxf $s i)) ∘ f .famf .transf i
+        ≈⟨ ∘-cong (colim (η .fobj X) .isColimit .colambda-coeval _ _ .transf-eq (f .idxf $s i)) ≈-refl ⟩
+          id _ ∘ f .famf .transf i
+        ≈⟨ id-left ⟩
+          f .famf .transf i
+        ∎ where open ≈-Reasoning isEquiv
+
+-- Naturality of transposition in each argument.
+transpose-natural₁ : ∀ {W' W : Category.obj cat} {X : Category.obj ℰ}
+                     (f : Category._⇒_ cat W (η .fobj X)) (g : Category._⇒_ cat W' W) →
+                     transpose (Mor-∘ f g) ≈ (transpose f ∘ realise .fmor g)
+transpose-natural₁ {W'} {W} {X} f g =
+  ≈-sym (≈-trans (≈-sym (colim W' .isColimit .colambda-ext _ _))
+    (colim W' .isColimit .colambda-cong eq))
+  where
+    eq : ≃-NatTrans (constFmor (transpose f ∘ realise .fmor g) ∘N colim W' .cocone) _
+    eq .transf-eq i =
+      begin
+        (transpose f ∘ realise .fmor g) ∘ colim W' .cocone .transf i
+      ≈⟨ assoc _ _ _ ⟩
+        transpose f ∘ (realise .fmor g ∘ colim W' .cocone .transf i)
+      ≈⟨ ∘-cong ≈-refl (colim W' .isColimit .colambda-coeval _ (push g) .transf-eq i) ⟩
+        transpose f ∘ (colim W .cocone .transf (g .idxf $s i) ∘ g .famf .transf i)
+      ≈˘⟨ assoc _ _ _ ⟩
+        (transpose f ∘ colim W .cocone .transf (g .idxf $s i)) ∘ g .famf .transf i
+      ≈⟨ ∘-cong (colim W .isColimit .colambda-coeval _ _ .transf-eq (g .idxf $s i)) ≈-refl ⟩
+        f .famf .transf (g .idxf $s i) ∘ g .famf .transf i
+      ≈˘⟨ id-left ⟩
+        id _ ∘ (f .famf .transf (g .idxf $s i) ∘ g .famf .transf i)
+      ∎ where open ≈-Reasoning isEquiv
+
+transpose-natural₂ : ∀ {W : Category.obj cat} {X Y : Category.obj ℰ}
+                     (h : Category._⇒_ ℰ X Y) (f : Category._⇒_ cat W (η .fobj X)) →
+                     transpose (Mor-∘ (η .fmor h) f) ≈ (h ∘ transpose f)
+transpose-natural₂ {W} {X} {Y} h f =
+  ≈-sym (≈-trans (≈-sym (colim W .isColimit .colambda-ext _ _))
+    (colim W .isColimit .colambda-cong eq))
+  where
+    eq : ≃-NatTrans (constFmor (h ∘ transpose f) ∘N colim W .cocone) _
+    eq .transf-eq i =
+      begin
+        (h ∘ transpose f) ∘ colim W .cocone .transf i
+      ≈⟨ assoc _ _ _ ⟩
+        h ∘ (transpose f ∘ colim W .cocone .transf i)
+      ≈⟨ ∘-cong ≈-refl (colim W .isColimit .colambda-coeval _ _ .transf-eq i) ⟩
+        h ∘ f .famf .transf i
+      ≈˘⟨ id-left ⟩
+        id _ ∘ (h ∘ f .famf .transf i)
+      ∎ where open ≈-Reasoning isEquiv
+
+-- Realisation preserves binary coproducts.
+module _ (ℰCP : HasCoproducts ℰ) where
+
+  private
+    module ℰCP = HasCoproducts ℰCP
+    module FC = HasCoproducts coproducts
+
+  module _ (X Y : Category.obj cat) where
+
+    private
+      X⊕Y = FC.coprod X Y
+
+      sumCone : NatTrans (fam→functor (X⊕Y .fam)) (constF (setoid→category (X⊕Y .idx)) (ℰCP.coprod (realise .fobj X) (realise .fobj Y)))
+      sumCone .transf (inj₁ i) = ℰCP.in₁ ∘ colim X .cocone .transf i
+      sumCone .transf (inj₂ j) = ℰCP.in₂ ∘ colim Y .cocone .transf j
+      sumCone .natural {inj₁ i₁} {inj₁ i₂} ⟪ e ⟫ =
+        begin
+          id _ ∘ (ℰCP.in₁ ∘ colim X .cocone .transf i₁)
+        ≈⟨ id-left ⟩
+          ℰCP.in₁ ∘ colim X .cocone .transf i₁
+        ≈⟨ ∘-cong ≈-refl (≈-trans (≈-sym id-left) (colim X .cocone .natural ⟪ e ⟫)) ⟩
+          ℰCP.in₁ ∘ (colim X .cocone .transf i₂ ∘ X .fam .subst e)
+        ≈˘⟨ assoc _ _ _ ⟩
+          (ℰCP.in₁ ∘ colim X .cocone .transf i₂) ∘ X .fam .subst e
+        ∎ where open ≈-Reasoning isEquiv
+      sumCone .natural {inj₁ i₁} {inj₂ j₂} ⟪ () ⟫
+      sumCone .natural {inj₂ j₁} {inj₁ i₂} ⟪ () ⟫
+      sumCone .natural {inj₂ j₁} {inj₂ j₂} ⟪ e ⟫ =
+        begin
+          id _ ∘ (ℰCP.in₂ ∘ colim Y .cocone .transf j₁)
+        ≈⟨ id-left ⟩
+          ℰCP.in₂ ∘ colim Y .cocone .transf j₁
+        ≈⟨ ∘-cong ≈-refl (≈-trans (≈-sym id-left) (colim Y .cocone .natural ⟪ e ⟫)) ⟩
+          ℰCP.in₂ ∘ (colim Y .cocone .transf j₂ ∘ Y .fam .subst e)
+        ≈˘⟨ assoc _ _ _ ⟩
+          (ℰCP.in₂ ∘ colim Y .cocone .transf j₂) ∘ Y .fam .subst e
+        ∎ where open ≈-Reasoning isEquiv
+
+      fwd⊕ = colim X⊕Y .isColimit .colambda _ sumCone
+
+      fwd-in₁ : (fwd⊕ ∘ realise .fmor FC.in₁) ≈ ℰCP.in₁
+      fwd-in₁ =
+        ≈-trans (≈-sym (colim X .isColimit .colambda-ext _ _))
+          (≈-trans (colim X .isColimit .colambda-cong eq₁) (colim X .isColimit .colambda-ext _ ℰCP.in₁))
+        where
+          eq₁ : ≃-NatTrans _ _
+          eq₁ .transf-eq i =
+            begin
+              (fwd⊕ ∘ realise .fmor FC.in₁) ∘ colim X .cocone .transf i
+            ≈⟨ assoc _ _ _ ⟩
+              fwd⊕ ∘ (realise .fmor FC.in₁ ∘ colim X .cocone .transf i)
+            ≈⟨ ∘-cong ≈-refl (colim X .isColimit .colambda-coeval _ (push FC.in₁) .transf-eq i) ⟩
+              fwd⊕ ∘ (colim X⊕Y .cocone .transf (inj₁ i) ∘ id _)
+            ≈⟨ ∘-cong ≈-refl id-right ⟩
+              fwd⊕ ∘ colim X⊕Y .cocone .transf (inj₁ i)
+            ≈⟨ colim X⊕Y .isColimit .colambda-coeval _ sumCone .transf-eq (inj₁ i) ⟩
+              ℰCP.in₁ ∘ colim X .cocone .transf i
+            ∎ where open ≈-Reasoning isEquiv
+
+      fwd-in₂ : (fwd⊕ ∘ realise .fmor FC.in₂) ≈ ℰCP.in₂
+      fwd-in₂ =
+        ≈-trans (≈-sym (colim Y .isColimit .colambda-ext _ _))
+          (≈-trans (colim Y .isColimit .colambda-cong eq₂) (colim Y .isColimit .colambda-ext _ ℰCP.in₂))
+        where
+          eq₂ : ≃-NatTrans _ _
+          eq₂ .transf-eq j =
+            begin
+              (fwd⊕ ∘ realise .fmor FC.in₂) ∘ colim Y .cocone .transf j
+            ≈⟨ assoc _ _ _ ⟩
+              fwd⊕ ∘ (realise .fmor FC.in₂ ∘ colim Y .cocone .transf j)
+            ≈⟨ ∘-cong ≈-refl (colim Y .isColimit .colambda-coeval _ (push FC.in₂) .transf-eq j) ⟩
+              fwd⊕ ∘ (colim X⊕Y .cocone .transf (inj₂ j) ∘ id _)
+            ≈⟨ ∘-cong ≈-refl id-right ⟩
+              fwd⊕ ∘ colim X⊕Y .cocone .transf (inj₂ j)
+            ≈⟨ colim X⊕Y .isColimit .colambda-coeval _ sumCone .transf-eq (inj₂ j) ⟩
+              ℰCP.in₂ ∘ colim Y .cocone .transf j
+            ∎ where open ≈-Reasoning isEquiv
+
+    realise-coproducts-iso : Category.Iso ℰ (realise .fobj X⊕Y) (ℰCP.coprod (realise .fobj X) (realise .fobj Y))
+    realise-coproducts-iso .Category.Iso.fwd = fwd⊕
+    realise-coproducts-iso .Category.Iso.bwd =
+      ℰCP.copair (realise .fmor FC.in₁) (realise .fmor FC.in₂)
+    realise-coproducts-iso .Category.Iso.fwd∘bwd≈id =
+      begin
+        fwd⊕ ∘ ℰCP.copair (realise .fmor FC.in₁) (realise .fmor FC.in₂)
+      ≈⟨ ℰCP.copair-natural _ _ _ ⟩
+        ℰCP.copair (fwd⊕ ∘ realise .fmor FC.in₁) (fwd⊕ ∘ realise .fmor FC.in₂)
+      ≈⟨ ℰCP.copair-cong fwd-in₁ fwd-in₂ ⟩
+        ℰCP.copair ℰCP.in₁ ℰCP.in₂
+      ≈⟨ ≈-trans (ℰCP.copair-cong (≈-sym id-left) (≈-sym id-left)) (ℰCP.copair-ext (id _)) ⟩
+        id _
+      ∎ where open ≈-Reasoning isEquiv
+    realise-coproducts-iso .Category.Iso.bwd∘fwd≈id =
+      ≈-trans (≈-sym (colim X⊕Y .isColimit .colambda-ext _ _))
+        (≈-trans (colim X⊕Y .isColimit .colambda-cong eq)
+          (colim X⊕Y .isColimit .colambda-ext _ (id _)))
+      where
+        bwd⊕ = ℰCP.copair (realise .fmor FC.in₁) (realise .fmor FC.in₂)
+
+        eq : ≃-NatTrans _ _
+        eq .transf-eq (inj₁ i) =
+          begin
+            (bwd⊕ ∘ fwd⊕) ∘ colim X⊕Y .cocone .transf (inj₁ i)
+          ≈⟨ assoc _ _ _ ⟩
+            bwd⊕ ∘ (fwd⊕ ∘ colim X⊕Y .cocone .transf (inj₁ i))
+          ≈⟨ ∘-cong ≈-refl (colim X⊕Y .isColimit .colambda-coeval _ sumCone .transf-eq (inj₁ i)) ⟩
+            bwd⊕ ∘ (ℰCP.in₁ ∘ colim X .cocone .transf i)
+          ≈˘⟨ assoc _ _ _ ⟩
+            (bwd⊕ ∘ ℰCP.in₁) ∘ colim X .cocone .transf i
+          ≈⟨ ∘-cong (ℰCP.copair-in₁ _ _) ≈-refl ⟩
+            realise .fmor FC.in₁ ∘ colim X .cocone .transf i
+          ≈⟨ colim X .isColimit .colambda-coeval _ (push FC.in₁) .transf-eq i ⟩
+            colim X⊕Y .cocone .transf (inj₁ i) ∘ id _
+          ≈⟨ id-right ⟩
+            colim X⊕Y .cocone .transf (inj₁ i)
+          ≈˘⟨ id-left ⟩
+            id _ ∘ colim X⊕Y .cocone .transf (inj₁ i)
+          ∎ where open ≈-Reasoning isEquiv
+        eq .transf-eq (inj₂ j) =
+          begin
+            (bwd⊕ ∘ fwd⊕) ∘ colim X⊕Y .cocone .transf (inj₂ j)
+          ≈⟨ assoc _ _ _ ⟩
+            bwd⊕ ∘ (fwd⊕ ∘ colim X⊕Y .cocone .transf (inj₂ j))
+          ≈⟨ ∘-cong ≈-refl (colim X⊕Y .isColimit .colambda-coeval _ sumCone .transf-eq (inj₂ j)) ⟩
+            bwd⊕ ∘ (ℰCP.in₂ ∘ colim Y .cocone .transf j)
+          ≈˘⟨ assoc _ _ _ ⟩
+            (bwd⊕ ∘ ℰCP.in₂) ∘ colim Y .cocone .transf j
+          ≈⟨ ∘-cong (ℰCP.copair-in₂ _ _) ≈-refl ⟩
+            realise .fmor FC.in₂ ∘ colim Y .cocone .transf j
+          ≈⟨ colim Y .isColimit .colambda-coeval _ (push FC.in₂) .transf-eq j ⟩
+            colim X⊕Y .cocone .transf (inj₂ j) ∘ id _
+          ≈⟨ id-right ⟩
+            colim X⊕Y .cocone .transf (inj₂ j)
+          ≈˘⟨ id-left ⟩
+            id _ ∘ colim X⊕Y .cocone .transf (inj₂ j)
+          ∎ where open ≈-Reasoning isEquiv
diff --git a/agda/src/fam-stable-indexed.agda b/agda/src/fam-stable-indexed.agda
new file mode 100644
index 00000000..6563f730
--- /dev/null
+++ b/agda/src/fam-stable-indexed.agda
@@ -0,0 +1,206 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (_⊔_)
+open import Data.Product using (Σ; _,_; proj₁; proj₂)
+open import prop using (∃ₚ; ∃ₛ; Prf; ⟪_⟫; _,_; tt)
+open prop.∃ₚ using (fst; snd)
+open import prop-setoid using (Setoid; IsEquivalence; module ≈-Reasoning)
+open import categories using (Category; setoid→category)
+open import functor using (Functor; HasColimits; Colimit; NatTrans; constF)
+open import fam using (module CategoryOfFamilies)
+import stable-coproducts-indexed
+
+-- Fam categories have stable set-indexed coproducts: pulling a coproduct
+-- decomposition back along a morphism splits the source over the same index,
+-- one summand per index. Stated at diagonal setoid levels (index equality at
+-- the carrier level), which the intended instance (both levels 0ℓ) satisfies;
+-- a summand's index set collects the source indices landing in that summand,
+-- which requires the membership proof to sit at the carrier level.
+module fam-stable-indexed {o m e os} (𝒞 : Category o m e) where
+
+open CategoryOfFamilies os os 𝒞
+open Obj
+open Mor
+open _≃_
+open import prop-setoid using (_⇒_) renaming (module _⇒_ to _⇒s_; _≃m_ to _≈s_)
+open _⇒s_
+open _≈s_
+open import indexed-family using (_⇒f_; _≃f_)
+open _⇒f_
+open _≃f_
+open Setoid
+open Category 𝒞 using ()
+  renaming (_∘_ to _∘C_; id to idC; _≈_ to _≈C_;
+            id-left to id-leftC; id-right to id-rightC;
+            ≈-refl to ≈-reflC; ≈-sym to ≈-symC; ≈-trans to ≈-transC;
+            assoc to assocC; ∘-cong to ∘-congC; ∘-cong₁ to ∘-cong₁C; ∘-cong₂ to ∘-cong₂C)
+open Category cat using (Iso) renaming (_∘_ to _∘cat_; ≈-trans to ≃-transC; ≈-sym to ≃-symC)
+open Iso
+open Functor
+
+module SI = stable-coproducts-indexed {𝒞 = cat} bigCoproducts
+open SI using (IdxStable; IdxStableBits; ∐; inj)
+
+fam-stable-indexed : IdxStable
+fam-stable-indexed {S} {D} {x} {y} f g = record { E = E ; leg = leg ; h = h ; eq = eq }
+  where
+    -- Where each index of y lands in the coproduct ∐ S D.
+    p : y .idx ⇒ (∐ S D) .idx
+    p = Mor-∘ (f .bwd) g .idxf
+
+    sOf : y .idx .Carrier → S .Carrier
+    sOf i = proj₁ (p .func i)
+
+    dOf : (i : y .idx .Carrier) → D .fobj (sOf i) .idx .Carrier
+    dOf i = proj₂ (p .func i)
+
+    pfam = Mor-∘ (f .bwd) g .famf
+
+    -- The s-th summand of y: the indices of y landing in the s-th component.
+    E : Functor (setoid→category S) cat
+    E .fobj s .idx .Carrier = ∃ₛ (y .idx .Carrier) (λ i → S ._≈_ (sOf i) s)
+    E .fobj s .idx ._≈_ (i , _) (j , _) = y .idx ._≈_ i j
+    E .fobj s .idx .isEquivalence .IsEquivalence.refl = y .idx .isEquivalence .IsEquivalence.refl
+    E .fobj s .idx .isEquivalence .IsEquivalence.sym e = y .idx .isEquivalence .IsEquivalence.sym e
+    E .fobj s .idx .isEquivalence .IsEquivalence.trans e₁ e₂ = y .idx .isEquivalence .IsEquivalence.trans e₁ e₂
+    E .fobj s .fam .indexed-family.Fam.fm (i , _) = y .fam .indexed-family.Fam.fm i
+    E .fobj s .fam .indexed-family.Fam.subst {i , _} {j , _} e = y .fam .indexed-family.Fam.subst e
+    E .fobj s .fam .indexed-family.Fam.refl* {i , _} = y .fam .indexed-family.Fam.refl*
+    E .fobj s .fam .indexed-family.Fam.trans* {i , _} {j , _} {k , _} e₁ e₂ = y .fam .indexed-family.Fam.trans* e₁ e₂
+    E .fmor ⟪ s≈s' ⟫ .idxf .func (i , pf) = i , S .trans pf s≈s'
+    E .fmor ⟪ s≈s' ⟫ .idxf .func-resp-≈ {i , _} {j , _} i≈j = i≈j
+    E .fmor ⟪ s≈s' ⟫ .famf .transf (i , _) = idC (y .fam .indexed-family.Fam.fm i)
+    E .fmor ⟪ s≈s' ⟫ .famf .natural {i , _} {j , _} e = ≈-transC id-leftC (≈-symC id-rightC)
+    E .fmor-cong _ .idxf-eq .func-eq i≈j = i≈j
+    E .fmor-cong _ .famf-eq .transf-eq = ≈-transC id-rightC (y .fam .indexed-family.Fam.refl*)
+    E .fmor-id .idxf-eq .func-eq i≈j = i≈j
+    E .fmor-id .famf-eq .transf-eq = ≈-transC id-rightC (y .fam .indexed-family.Fam.refl*)
+    E .fmor-comp _ _ .idxf-eq .func-eq i≈j = i≈j
+    E .fmor-comp _ _ .famf-eq .transf-eq {i , _} = ≈-transC id-rightC (≈-transC (y .fam .indexed-family.Fam.refl*) (≈-symC (≈-transC id-leftC id-leftC)))
+
+    -- Each summand of y maps into the corresponding summand of x, transporting
+    -- the recorded landing to the target index s.
+    leg : ∀ s → Mor (E .fobj s) (D .fobj s)
+    leg s .idxf .func (i , pf) = D .fmor ⟪ pf ⟫ .idxf .func (dOf i)
+    leg s .idxf .func-resp-≈ {i , pf} {j , pf'} i≈j =
+      D .fobj s .idx .trans
+        (D .fmor-cong {f₁ = ⟪ pf ⟫} {f₂ = ⟪ S .trans (p .func-resp-≈ i≈j .fst) pf' ⟫} tt
+           .idxf-eq .func-eq (D .fobj (sOf i) .idx .refl))
+        (D .fobj s .idx .trans
+          (D .fmor-comp ⟪ pf' ⟫ ⟪ p .func-resp-≈ i≈j .fst ⟫ .idxf-eq .func-eq (D .fobj (sOf i) .idx .refl))
+          (D .fmor ⟪ pf' ⟫ .idxf .func-resp-≈ (p .func-resp-≈ i≈j .snd)))
+    leg s .famf .transf (i , pf) =
+      D .fmor ⟪ pf ⟫ .famf .transf (dOf i) ∘C pfam .transf i
+    leg s .famf .natural {i , pf} {j , pf'} i≈j =
+      ≈-transC (assocC _ _ _)
+        (≈-transC (∘-cong₂C (pfam .natural i≈j))
+          (≈-transC (≈-symC (assocC _ _ _))
+            (≈-transC (∘-cong₁C core)
+              (assocC _ _ _))))
+      where
+        e₀ : S ._≈_ (sOf i) (sOf j)
+        e₀ = p .func-resp-≈ i≈j .fst
+
+        e₁ : D .fobj (sOf j) .idx ._≈_ (D .fmor ⟪ e₀ ⟫ .idxf .func (dOf i)) (dOf j)
+        e₁ = p .func-resp-≈ i≈j .snd
+
+        legresp : D .fobj s .idx ._≈_ (D .fmor ⟪ pf ⟫ .idxf .func (dOf i)) (D .fmor ⟪ pf' ⟫ .idxf .func (dOf j))
+        legresp = leg s .idxf .func-resp-≈ {i , pf} {j , pf'} i≈j
+
+        -- ⟪_⟫ proofs are definitionally interchangeable, so fmor-comp relates
+        -- the transport at pf to the two-step transport through e₀ and pf'.
+        q₂ : D .fobj s .idx ._≈_ (D .fmor ⟪ pf' ⟫ .idxf .func (D .fmor ⟪ e₀ ⟫ .idxf .func (dOf i))) (D .fmor ⟪ pf ⟫ .idxf .func (dOf i))
+        q₂ = D .fobj s .idx .sym (D .fmor-comp ⟪ pf' ⟫ ⟪ e₀ ⟫ .idxf-eq .func-eq (D .fobj (sOf i) .idx .refl))
+
+        Dcomp : Category._≈_ cat (D .fmor ⟪ pf' ⟫ ∘cat D .fmor ⟪ e₀ ⟫) (D .fmor ⟪ pf ⟫)
+        Dcomp = ≃-symC (D .fmor-comp ⟪ pf' ⟫ ⟪ e₀ ⟫)
+
+        core : (D .fmor ⟪ pf' ⟫ .famf .transf (dOf j) ∘C (∐ S D) .fam .indexed-family.Fam.subst (p .func-resp-≈ i≈j))
+               ≈C (D .fobj s .fam .indexed-family.Fam.subst legresp ∘C D .fmor ⟪ pf ⟫ .famf .transf (dOf i))
+        core =
+          ≈-transC (≈-symC (assocC _ _ _))
+            (≈-transC (∘-cong₁C (D .fmor ⟪ pf' ⟫ .famf .natural e₁))
+              (≈-transC (assocC _ _ _)
+                (≈-transC (∘-cong₂C (≈-symC id-leftC))
+                  (≈-transC (∘-cong₁C (D .fobj s .fam .indexed-family.Fam.trans* legresp q₂))
+                    (≈-transC (assocC _ _ _)
+                      (∘-cong₂C (Dcomp .famf-eq .transf-eq {dOf i})))))))
+
+    -- y is the coproduct of its summands.
+    fwd-h : Mor (∐ S E) y
+    fwd-h .idxf .func (s , i , _) = i
+    fwd-h .idxf .func-resp-≈ {s₁ , i , _} {s₂ , j , _} (_ , i≈j) = i≈j
+    fwd-h .famf .transf (s , i , _) = idC (y .fam .indexed-family.Fam.fm i)
+    fwd-h .famf .natural e = id-leftC
+
+    bwd-h : Mor y (∐ S E)
+    bwd-h .idxf .func i = sOf i , i , S .refl
+    bwd-h .idxf .func-resp-≈ {i} {j} i≈j = p .func-resp-≈ i≈j .fst , i≈j
+    bwd-h .famf .transf i = idC (y .fam .indexed-family.Fam.fm i)
+    bwd-h .famf .natural e = ≈-transC id-leftC (≈-symC (≈-transC id-rightC id-rightC))
+
+    h : Iso (∐ S E) y
+    h .fwd = fwd-h
+    h .bwd = bwd-h
+    h .fwd∘bwd≈id .idxf-eq .func-eq i≈j = i≈j
+    h .fwd∘bwd≈id .famf-eq .transf-eq = ≈-transC (∘-congC (y .fam .indexed-family.Fam.refl*) (≈-transC (∘-cong₂C id-leftC) id-leftC)) id-leftC
+    h .bwd∘fwd≈id .idxf-eq .func-eq {s , i , pf} {s' , j , pf'} (w , i≈j) = S .trans pf w , i≈j
+    h .bwd∘fwd≈id .famf-eq .transf-eq = ≈-transC (∘-congC (≈-transC id-rightC (y .fam .indexed-family.Fam.refl*)) (≈-transC id-leftC id-leftC)) id-leftC
+
+    eq : ∀ s → Mor-∘ (f .fwd) (Mor-∘ (inj D s) (leg s)) ≃ Mor-∘ g (Mor-∘ (h .fwd) (inj E s))
+    eq s .idxf-eq .func-eq {i , pf} {i' , pf'} i≈i' =
+      x .idx .trans (f .fwd .idxf .func-resp-≈ apex-eq)
+        (x .idx .trans (f .fwd∘bwd≈id .idxf-eq .func-eq (x .idx .refl))
+                       (g .idxf .func-resp-≈ i≈i'))
+      where
+        apex-eq : (∐ S D) .idx ._≈_ (s , D .fmor ⟪ pf ⟫ .idxf .func (dOf i)) (p .func i)
+        apex-eq = S .sym pf ,
+          D .fobj (sOf i) .idx .trans
+            (D .fobj (sOf i) .idx .sym (D .fmor-comp ⟪ S .sym pf ⟫ ⟪ pf ⟫ .idxf-eq .func-eq (D .fobj (sOf i) .idx .refl)))
+            (D .fobj (sOf i) .idx .trans
+              (D .fmor-cong {f₁ = ⟪ S .trans pf (S .sym pf) ⟫} {f₂ = ⟪ S .refl ⟫} tt .idxf-eq .func-eq (D .fobj (sOf i) .idx .refl))
+              (D .fmor-id .idxf-eq .func-eq (D .fobj (sOf i) .idx .refl)))
+    eq s .famf-eq .transf-eq {i , pf} =
+      ≈-transC (∘-cong₂C (≈-transC id-leftC (∘-cong₂C (≈-transC id-leftC (≈-transC id-leftC (∘-cong₂C id-leftC))))))
+        (≈-transC (∘-cong₂C (∘-cong₂C (≈-symC (assocC _ _ _))))
+          (≈-transC (∘-cong₂C (≈-symC (assocC _ _ _)))
+            (≈-transC (≈-symC (assocC _ _ _))
+              (≈-transC (∘-cong₁C roundtrip)
+                (≈-transC id-leftC
+                  (≈-symC (≈-transC id-leftC (≈-transC (∘-cong₂C (≈-transC id-leftC id-leftC)) id-rightC))))))))
+      where
+        w : x .idx .Carrier
+        w = g .idxf .func i
+
+        ŝ : (∐ S D) .idx .Carrier
+        ŝ = s , D .fmor ⟪ pf ⟫ .idxf .func (dOf i)
+
+        symapex : (∐ S D) .idx ._≈_ (p .func i) ŝ
+        symapex = pf , D .fobj s .idx .refl
+
+        q₃ : x .idx ._≈_ (f .fwd .idxf .func (p .func i)) (f .fwd .idxf .func ŝ)
+        q₃ = f .fwd .idxf .func-resp-≈ symapex
+
+        EQ : x .idx ._≈_ (f .fwd .idxf .func ŝ) w
+        EQ = x .idx .trans (x .idx .sym q₃) (f .fwd∘bwd≈id .idxf-eq .func-eq (x .idx .refl {w}))
+
+        -- The leg's transport is the coproduct's subst along symapex, up to a
+        -- vanishing refl-subst.
+        insert : D .fmor ⟪ pf ⟫ .famf .transf (dOf i) ≈C (∐ S D) .fam .indexed-family.Fam.subst symapex
+        insert = ≈-symC (≈-transC (∘-cong₁C (D .fobj s .fam .indexed-family.Fam.refl*)) id-leftC)
+
+        -- Sending the summand back through the decomposition and out along the
+        -- iso is the identity, by naturality and the iso's roundtrip.
+        roundtrip : (x .fam .indexed-family.Fam.subst EQ
+                      ∘C (f .fwd .famf .transf ŝ
+                        ∘C (D .fmor ⟪ pf ⟫ .famf .transf (dOf i) ∘C f .bwd .famf .transf w)))
+                    ≈C idC (x .fam .indexed-family.Fam.fm w)
+        roundtrip =
+          ≈-transC (∘-cong₂C (∘-cong₂C (∘-cong₁C insert)))
+            (≈-transC (∘-cong₂C (≈-symC (assocC _ _ _)))
+              (≈-transC (∘-cong₂C (∘-cong₁C (f .fwd .famf .natural symapex)))
+                (≈-transC (∘-cong₂C (assocC _ _ _))
+                  (≈-transC (≈-symC (assocC _ _ _))
+                    (≈-transC (∘-cong₁C (≈-symC (x .fam .indexed-family.Fam.trans* EQ q₃)))
+                      (≈-transC (∘-cong₂C (≈-symC id-leftC))
+                        (f .fwd∘bwd≈id .famf-eq .transf-eq {w})))))))
diff --git a/agda/src/fam.agda b/agda/src/fam.agda
index 3092677d..07da2ab6 100644
--- a/agda/src/fam.agda
+++ b/agda/src/fam.agda
@@ -12,7 +12,7 @@ open import prop-setoid
   using (IsEquivalence; Setoid; 𝟙; +-setoid; ⊗-setoid; idS; _∘S_; module ≈-Reasoning)
   renaming (_⇒_ to _⇒s_; _≃m_ to _≈s_; ≃m-isEquivalence to ≈s-isEquivalence)
 open import categories
-  using (Category; HasTerminal; IsTerminal; HasCoproducts; HasProducts; HasStrongCoproducts; HasLists; setoid→category)
+  using (Category; HasTerminal; IsTerminal; HasInitial; IsInitial; HasCoproducts; HasProducts; HasStrongCoproducts; setoid→category)
 open import setoid-cat using (Setoid-products)
 open import indexed-family
   using (Fam; _⇒f_; idf; _∘f_; ∘f-cong; _≃f_; ≃f-isEquivalence; ≃f-id-left; ≃f-assoc;
@@ -226,6 +226,19 @@ module CategoryOfFamilies {o m e} os es (𝒞 : Category o m e) where
 
     -- FIXME: simple is a functor and preserves products
 
+  -- The category of families always has an initial object: the family over the empty index.
+  initial : HasInitial cat
+  initial .HasInitial.witness .idx = prop-setoid.𝟘
+  initial .HasInitial.witness .fam .fm (lift ())
+  initial .HasInitial.witness .fam .subst {lift ()}
+  initial .HasInitial.witness .fam .refl* {lift ()}
+  initial .HasInitial.witness .fam .trans* {lift ()}
+  initial .HasInitial.is-initial .IsInitial.from-initial .idxf = prop-setoid.from-𝟘
+  initial .HasInitial.is-initial .IsInitial.from-initial .famf ._⇒f_.transf (lift ())
+  initial .HasInitial.is-initial .IsInitial.from-initial .famf ._⇒f_.natural {lift ()}
+  initial .HasInitial.is-initial .IsInitial.from-initial-ext f .idxf-eq = prop-setoid.from-𝟘-unique _ _
+  initial .HasInitial.is-initial .IsInitial.from-initial-ext f .famf-eq ._≃f_.transf-eq {lift ()}
+
   -- If 𝒞 has a terminal object, then so does the category of families
   module _ (T : HasTerminal 𝒞) where
     open HasTerminal hiding (to-terminal-unique)
@@ -253,6 +266,8 @@ module CategoryOfFamilies {o m e} os es (𝒞 : Category o m e) where
     open _⇒f_
     open _≃f_
 
+    -- The two-element instance of the set-indexed coproducts below, kept as the
+    -- ⊎-indexed substrate for the (currently finite-only) HasStrongCoproducts.
     coproducts : HasCoproducts cat
     coproducts .coprod X Y .idx = +-setoid (X .idx) (Y .idx)
     coproducts .coprod X Y .fam .fm (inj₁ x) = X .fam .fm x
@@ -305,6 +320,43 @@ module CategoryOfFamilies {o m e} os es (𝒞 : Category o m e) where
     coproducts .copair-ext {X} {Y} {Z} f .famf-eq .transf-eq {inj₂ y} =
       isEquiv .trans (∘-cong (Z .fam .refl*) id-left) (isEquiv .trans id-left id-right)
 
+  -- Predicates: a setoid map into 𝟙 + 𝟙 lifts to a morphism into the Boolean object, with trivial
+  -- fibre maps.
+  module predicates (T : HasTerminal 𝒞) where
+
+    open Category 𝒞
+    open HasCoproducts
+    open HasTerminal
+    open _⇒f_
+
+    𝟚 : Obj
+    𝟚 = coproducts .coprod (simple[ 𝟙 , T .witness ]) (simple[ 𝟙 , T .witness ])
+
+    𝟚ₛ : Setoid os es
+    𝟚ₛ = +-setoid 𝟙 𝟙
+
+    private
+      predicate-transf : ∀ (X : Obj) x y → X .fam .Fam.fm x ⇒ 𝟚 .fam .Fam.fm y
+      predicate-transf X x (inj₁ _) = T .is-terminal .IsTerminal.to-terminal
+      predicate-transf X x (inj₂ _) = T .is-terminal .IsTerminal.to-terminal
+
+      predicate-natural : ∀ (X : Obj) {x₁} {x₂} {y₁} {y₂}
+        (x-eq : X .idx .Setoid._≈_ x₁ x₂)
+        (y-eq : 𝟚ₛ .Setoid._≈_ y₁ y₂) →
+        (predicate-transf X x₂ y₂ ∘ X .fam .Fam.subst x-eq) ≈
+          (𝟚 .fam .Fam.subst {y₁} {y₂} y-eq ∘ predicate-transf X x₁ y₁)
+      predicate-natural X {y₁ = inj₁ _} {inj₁ _} x-eq y-eq =
+        IsTerminal.to-terminal-unique (T .is-terminal) _ _
+      predicate-natural X {y₁ = inj₂ _} {inj₂ _} x-eq y-eq =
+        IsTerminal.to-terminal-unique (T .is-terminal) _ _
+
+    predicate : ∀ {X : Obj} → prop-setoid._⇒_ (X .idx) 𝟚ₛ → Mor X 𝟚
+    predicate f .idxf = f
+    predicate {X} f .famf .transf x = predicate-transf X x (f .prop-setoid._⇒_.func x)
+    predicate {X} f .famf .natural {x₁} {x₂} x₁≈x₂ =
+      predicate-natural X {y₁ = f .prop-setoid._⇒_.func x₁} x₁≈x₂
+        (f .prop-setoid._⇒_.func-resp-≈ x₁≈x₂)
+
   -- Fam(𝒞) has stable coproducts (is extensive): anything mapping into a coproduct A + B automatically splits
   -- into the part that lands in A and the part that lands in B.
   module _ where
@@ -548,7 +600,7 @@ module CategoryOfFamilies {o m e} os es (𝒞 : Category o m e) where
     open Mor
 
     bigCoproducts : ∀ (S : Setoid os es) → HasColimits (setoid→category S) cat
-    bigCoproducts S D .apex .idx .Carrier = Σ[ s ∈ S .Carrier ] D .fobj s .idx .Carrier
+    bigCoproducts S D .apex .idx .Setoid.Carrier = Σ[ s ∈ S .Carrier ] D .fobj s .idx .Setoid.Carrier
     bigCoproducts S D .apex .idx ._≈_ (s₁ , x₁) (s₂ , x₂) =
       ∃ₚ (S ._≈_ s₁ s₂) λ s₁≈s₂ → D .fobj s₂ .idx ._≈_ (D .fmor ⟪ s₁≈s₂ ⟫ .idxf .func x₁) x₂
     bigCoproducts S D .apex .idx .isEquivalence .refl {s , x} =
@@ -733,7 +785,7 @@ module CategoryOfFamilies {o m e} os es (𝒞 : Category o m e) where
         prod-m P (X .fam .subst _) (Y .fam .subst _)
       ≈⟨ prod-m-cong P (X .fam .trans* _ _) (Y .fam .trans* _ _) ⟩
         prod-m P (X .fam .subst _ ∘ X .fam .subst _) (Y .fam .subst _ ∘ Y .fam .subst _)
-      ≈⟨ pair-functorial P _ _ _ _ ⟩
+      ≈⟨ prod-m-comp P _ _ _ _ ⟩
         prod-m P (X .fam .subst _) (Y .fam .subst _) ∘ prod-m P (X .fam .subst _) (Y .fam .subst _)
       ∎ where open ≈-Reasoning isEquiv
 
@@ -836,6 +888,86 @@ module CategoryOfFamilies {o m e} os es (𝒞 : Category o m e) where
       f .famf .natural (w₁≈w₂ , e)
     strongCoproducts .copair f g .famf .natural {w₁ , inj₂ y} {w₂ , inj₂ y₁} (w₁≈w₂ , e) =
       g .famf .natural (w₁≈w₂ , e)
+    strongCoproducts .copair-cong f₁≈f₂ g₁≈g₂ .idxf-eq ._≈s_.func-eq {w₁ , inj₁ x₁} {w₂ , inj₁ x₂} (w₁≈w₂ , x₁≈x₂) =
+      f₁≈f₂ .idxf-eq ._≈s_.func-eq (w₁≈w₂ , x₁≈x₂)
+    strongCoproducts .copair-cong f₁≈f₂ g₁≈g₂ .idxf-eq ._≈s_.func-eq {w₁ , inj₂ y₁} {w₂ , inj₂ y₂} (w₁≈w₂ , y₁≈y₂) =
+      g₁≈g₂ .idxf-eq ._≈s_.func-eq (w₁≈w₂ , y₁≈y₂)
+    strongCoproducts .copair-cong f₁≈f₂ g₁≈g₂ .famf-eq ._≃f_.transf-eq {w , inj₁ x} =
+      f₁≈f₂ .famf-eq ._≃f_.transf-eq
+    strongCoproducts .copair-cong f₁≈f₂ g₁≈g₂ .famf-eq ._≃f_.transf-eq {w , inj₂ y} =
+      g₁≈g₂ .famf-eq ._≃f_.transf-eq
+    strongCoproducts .copair-in₁ f g .idxf-eq ._≈s_.func-eq (w₁≈w₂ , x₁≈x₂) =
+      f .idxf ._⇒s_.func-resp-≈ (w₁≈w₂ , x₁≈x₂)
+    strongCoproducts .copair-in₁ {W} {X} {Y} {Z} f g .famf-eq ._≃f_.transf-eq {w , x} =
+      begin
+        Z .fam .subst _ ∘ (id _ ∘ (f .famf .transf (w , x) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂))))
+      ≈⟨ ∘-cong ≈-refl id-left ⟩
+        Z .fam .subst _ ∘ (f .famf .transf (w , x) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂)))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong ≈-refl (≈-trans id-left id-left))) ⟩
+        Z .fam .subst _ ∘ (f .famf .transf (w , x) ∘ P .pair (P .p₁) (P .p₂))
+      ≈˘⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong id-right id-right)) ⟩
+        Z .fam .subst _ ∘ (f .famf .transf (w , x) ∘ P .pair (P .p₁ ∘ id _) (P .p₂ ∘ id _))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-ext (id _))) ⟩
+        Z .fam .subst _ ∘ (f .famf .transf (w , x) ∘ id _)
+      ≈⟨ ∘-cong (Z .fam .refl*) id-right ⟩
+        id _ ∘ f .famf .transf (w , x)
+      ≈⟨ id-left ⟩
+        f .famf .transf (w , x)
+      ∎ where open ≈-Reasoning isEquiv
+    strongCoproducts .copair-in₂ f g .idxf-eq ._≈s_.func-eq (w₁≈w₂ , y₁≈y₂) =
+      g .idxf ._⇒s_.func-resp-≈ (w₁≈w₂ , y₁≈y₂)
+    strongCoproducts .copair-in₂ {W} {X} {Y} {Z} f g .famf-eq ._≃f_.transf-eq {w , y} =
+      begin
+        Z .fam .subst _ ∘ (id _ ∘ (g .famf .transf (w , y) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂))))
+      ≈⟨ ∘-cong ≈-refl id-left ⟩
+        Z .fam .subst _ ∘ (g .famf .transf (w , y) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂)))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong ≈-refl (≈-trans id-left id-left))) ⟩
+        Z .fam .subst _ ∘ (g .famf .transf (w , y) ∘ P .pair (P .p₁) (P .p₂))
+      ≈˘⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong id-right id-right)) ⟩
+        Z .fam .subst _ ∘ (g .famf .transf (w , y) ∘ P .pair (P .p₁ ∘ id _) (P .p₂ ∘ id _))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-ext (id _))) ⟩
+        Z .fam .subst _ ∘ (g .famf .transf (w , y) ∘ id _)
+      ≈⟨ ∘-cong (Z .fam .refl*) id-right ⟩
+        id _ ∘ g .famf .transf (w , y)
+      ≈⟨ id-left ⟩
+        g .famf .transf (w , y)
+      ∎ where open ≈-Reasoning isEquiv
+    strongCoproducts .copair-ext h .idxf-eq ._≈s_.func-eq {w₁ , inj₁ x₁} {w₂ , inj₁ x₂} (w₁≈w₂ , x₁≈x₂) =
+      h .idxf ._⇒s_.func-resp-≈ (w₁≈w₂ , x₁≈x₂)
+    strongCoproducts .copair-ext h .idxf-eq ._≈s_.func-eq {w₁ , inj₂ y₁} {w₂ , inj₂ y₂} (w₁≈w₂ , y₁≈y₂) =
+      h .idxf ._⇒s_.func-resp-≈ (w₁≈w₂ , y₁≈y₂)
+    strongCoproducts .copair-ext {W} {X} {Y} {Z} h .famf-eq ._≃f_.transf-eq {w , inj₁ x} =
+      begin
+        Z .fam .subst _ ∘ (id _ ∘ (h .famf .transf (w , inj₁ x) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂))))
+      ≈⟨ ∘-cong ≈-refl id-left ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₁ x) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂)))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong ≈-refl (≈-trans id-left id-left))) ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₁ x) ∘ P .pair (P .p₁) (P .p₂))
+      ≈˘⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong id-right id-right)) ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₁ x) ∘ P .pair (P .p₁ ∘ id _) (P .p₂ ∘ id _))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-ext (id _))) ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₁ x) ∘ id _)
+      ≈⟨ ∘-cong (Z .fam .refl*) id-right ⟩
+        id _ ∘ h .famf .transf (w , inj₁ x)
+      ≈⟨ id-left ⟩
+        h .famf .transf (w , inj₁ x)
+      ∎ where open ≈-Reasoning isEquiv
+    strongCoproducts .copair-ext {W} {X} {Y} {Z} h .famf-eq ._≃f_.transf-eq {w , inj₂ y} =
+      begin
+        Z .fam .subst _ ∘ (id _ ∘ (h .famf .transf (w , inj₂ y) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂))))
+      ≈⟨ ∘-cong ≈-refl id-left ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₂ y) ∘ P .pair (P .p₁) (id _ ∘ (id _ ∘ P .p₂)))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong ≈-refl (≈-trans id-left id-left))) ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₂ y) ∘ P .pair (P .p₁) (P .p₂))
+      ≈˘⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-cong id-right id-right)) ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₂ y) ∘ P .pair (P .p₁ ∘ id _) (P .p₂ ∘ id _))
+      ≈⟨ ∘-cong ≈-refl (∘-cong ≈-refl (P .pair-ext (id _))) ⟩
+        Z .fam .subst _ ∘ (h .famf .transf (w , inj₂ y) ∘ id _)
+      ≈⟨ ∘-cong (Z .fam .refl*) id-right ⟩
+        id _ ∘ h .famf .transf (w , inj₂ y)
+      ≈⟨ id-left ⟩
+        h .famf .transf (w , inj₂ y)
+      ∎ where open ≈-Reasoning isEquiv
 
 -- FIXME: every functor 𝒞 ⇒ 𝒟 gives a functor Fam(𝒞) ⇒ Fam(𝒟), and
 -- this carries over to natural transformations. So we have functors:
diff --git a/agda/src/finite-coproducts-from-indexed.agda b/agda/src/finite-coproducts-from-indexed.agda
new file mode 100644
index 00000000..f0bb6f14
--- /dev/null
+++ b/agda/src/finite-coproducts-from-indexed.agda
@@ -0,0 +1,301 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (lift)
+open import Data.Unit using (tt)
+open import Data.Sum using (inj₁; inj₂)
+open import prop using (⟪_⟫; ∃ₛ)
+open import categories using (Category; setoid→category; HasCoproducts)
+open import prop-setoid using (Setoid; 𝟙; +-setoid; module ≈-Reasoning)
+open import functor using (Functor; HasColimits; Colimit; IsColimit; NatTrans; NatIso; ≃-NatTrans; constF; colambda-unique; _∘F_)
+open import finite-coproduct-functor using (preserve-chosen-coproducts)
+open import indexed-family using (Fam; fam→functor)
+import stable-coproducts
+import stable-coproducts-indexed
+
+module finite-coproducts-from-indexed where
+
+-- Finite coproducts as the two-element instance of set-indexed coproducts: the
+-- object and its universal property, its stability, and its functoriality.
+module derive
+  {o m e os es} {𝒞 : Category o m e}
+  (LC : ∀ (S : Setoid os es) → HasColimits (setoid→category S) 𝒞)
+  where
+
+  private module 𝒞 = Category 𝒞
+  open stable-coproducts-indexed LC
+  open 𝒞.Iso
+  open Colimit
+  open NatTrans
+  open Functor
+
+  -- The two-element index and the two-object diagram, exposed so that a functor
+  -- preserving set-indexed coproducts can be shown to preserve the derived ones.
+  Two : Setoid os es
+  Two = +-setoid 𝟙 𝟙
+
+  pairFam : 𝒞.obj → 𝒞.obj → Fam Two 𝒞
+  pairFam x y .Fam.fm (inj₁ _) = x
+  pairFam x y .Fam.fm (inj₂ _) = y
+  pairFam x y .Fam.subst {inj₁ _} {inj₁ _} _ = 𝒞.id _
+  pairFam x y .Fam.subst {inj₂ _} {inj₂ _} _ = 𝒞.id _
+  pairFam x y .Fam.refl* {inj₁ _} = 𝒞.≈-refl
+  pairFam x y .Fam.refl* {inj₂ _} = 𝒞.≈-refl
+  pairFam x y .Fam.trans* {inj₁ _} {inj₁ _} {inj₁ _} _ _ = 𝒞.≈-sym 𝒞.id-left
+  pairFam x y .Fam.trans* {inj₂ _} {inj₂ _} {inj₂ _} _ _ = 𝒞.≈-sym 𝒞.id-left
+
+  Dpair : 𝒞.obj → 𝒞.obj → Functor (setoid→category Two) 𝒞
+  Dpair x y = fam→functor (pairFam x y)
+
+  private
+    copairCocone : ∀ {x y z} (f : x 𝒞.⇒ z) (g : y 𝒞.⇒ z) →
+                   NatTrans (Dpair x y) (constF (setoid→category Two) z)
+    copairCocone f g .transf (inj₁ _) = f
+    copairCocone f g .transf (inj₂ _) = g
+    copairCocone f g .natural {inj₁ _} {inj₁ _} _ = 𝒞.≈-trans 𝒞.id-left (𝒞.≈-sym 𝒞.id-right)
+    copairCocone f g .natural {inj₂ _} {inj₂ _} _ = 𝒞.≈-trans 𝒞.id-left (𝒞.≈-sym 𝒞.id-right)
+
+    ⊕ : 𝒞.obj → 𝒞.obj → 𝒞.obj
+    ⊕ x y = ∐ Two (Dpair x y)
+
+    ι₁ : ∀ {x y} → x 𝒞.⇒ ⊕ x y
+    ι₁ {x} {y} = inj (Dpair x y) (inj₁ (lift tt))
+
+    ι₂ : ∀ {x y} → y 𝒞.⇒ ⊕ x y
+    ι₂ {x} {y} = inj (Dpair x y) (inj₂ (lift tt))
+
+    ⟨_∣_⟩ : ∀ {x y z} → x 𝒞.⇒ z → y 𝒞.⇒ z → ⊕ x y 𝒞.⇒ z
+    ⟨_∣_⟩ {x} {y} {z} f g = LC Two (Dpair x y) .colambda z (copairCocone f g)
+
+    pin₁ : ∀ {x y z} (f : x 𝒞.⇒ z) (g : y 𝒞.⇒ z) → (⟨ f ∣ g ⟩ 𝒞.∘ ι₁) 𝒞.≈ f
+    pin₁ {x} {y} {z} f g =
+      LC Two (Dpair x y) .colambda-coeval z (copairCocone f g) .≃-NatTrans.transf-eq (inj₁ (lift tt))
+
+    pin₂ : ∀ {x y z} (f : x 𝒞.⇒ z) (g : y 𝒞.⇒ z) → (⟨ f ∣ g ⟩ 𝒞.∘ ι₂) 𝒞.≈ g
+    pin₂ {x} {y} {z} f g =
+      LC Two (Dpair x y) .colambda-coeval z (copairCocone f g) .≃-NatTrans.transf-eq (inj₂ (lift tt))
+
+    pext : ∀ {x y z} (f : ⊕ x y 𝒞.⇒ z) → ⟨ f 𝒞.∘ ι₁ ∣ f 𝒞.∘ ι₂ ⟩ 𝒞.≈ f
+    pext {x} {y} {z} f = colambda-unique (LC Two (Dpair x y) .isColimit) uni
+      where
+        uni : ∀ s → (⟨ f 𝒞.∘ ι₁ ∣ f 𝒞.∘ ι₂ ⟩ 𝒞.∘ inj (Dpair x y) s) 𝒞.≈ (f 𝒞.∘ inj (Dpair x y) s)
+        uni (inj₁ _) = pin₁ (f 𝒞.∘ ι₁) (f 𝒞.∘ ι₂)
+        uni (inj₂ _) = pin₂ (f 𝒞.∘ ι₁) (f 𝒞.∘ ι₂)
+
+    pcong : ∀ {x y z} {f₁ f₂ : x 𝒞.⇒ z} {g₁ g₂ : y 𝒞.⇒ z} →
+            f₁ 𝒞.≈ f₂ → g₁ 𝒞.≈ g₂ → ⟨ f₁ ∣ g₁ ⟩ 𝒞.≈ ⟨ f₂ ∣ g₂ ⟩
+    pcong {x} {y} {z} f₁≈f₂ g₁≈g₂ = LC Two (Dpair x y) .colambda-cong coconeEq
+      where
+        coconeEq : ≃-NatTrans (copairCocone _ _) (copairCocone _ _)
+        coconeEq .≃-NatTrans.transf-eq (inj₁ _) = f₁≈f₂
+        coconeEq .≃-NatTrans.transf-eq (inj₂ _) = g₁≈g₂
+
+  -- Finite coproducts derived from the two-element set-indexed coproduct.
+  coproducts-from-indexed : HasCoproducts 𝒞
+  coproducts-from-indexed .HasCoproducts.coprod = ⊕
+  coproducts-from-indexed .HasCoproducts.in₁ = ι₁
+  coproducts-from-indexed .HasCoproducts.in₂ = ι₂
+  coproducts-from-indexed .HasCoproducts.copair = ⟨_∣_⟩
+  coproducts-from-indexed .HasCoproducts.copair-cong = pcong
+  coproducts-from-indexed .HasCoproducts.copair-in₁ = pin₁
+  coproducts-from-indexed .HasCoproducts.copair-in₂ = pin₂
+  coproducts-from-indexed .HasCoproducts.copair-ext = pext
+
+  ------------------------------------------------------------------------------
+  -- Functoriality of set-indexed coproducts: a map of diagrams induces a map of
+  -- coproducts, and a natural isomorphism an isomorphism.
+
+  map-cocone : ∀ {S} {D₁ D₂ : Functor (setoid→category S) 𝒞} (α : NatTrans D₁ D₂) →
+               NatTrans D₁ (constF (setoid→category S) (∐ S D₂))
+  map-cocone {S} {D₁} {D₂} α .transf s = inj D₂ s 𝒞.∘ α .transf s
+  map-cocone {S} {D₁} {D₂} α .natural {s} {s'} ⟪ e ⟫ = begin
+      𝒞.id _ 𝒞.∘ (inj D₂ s 𝒞.∘ α .transf s)
+    ≈⟨ 𝒞.id-left ⟩
+      inj D₂ s 𝒞.∘ α .transf s
+    ≈⟨ 𝒞.∘-cong (𝒞.≈-trans (𝒞.≈-sym 𝒞.id-left) (LC S D₂ .cocone .natural ⟪ e ⟫)) 𝒞.≈-refl ⟩
+      (inj D₂ s' 𝒞.∘ D₂ .fmor ⟪ e ⟫) 𝒞.∘ α .transf s
+    ≈⟨ 𝒞.assoc _ _ _ ⟩
+      inj D₂ s' 𝒞.∘ (D₂ .fmor ⟪ e ⟫ 𝒞.∘ α .transf s)
+    ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (α .natural ⟪ e ⟫) ⟩
+      inj D₂ s' 𝒞.∘ (α .transf s' 𝒞.∘ D₁ .fmor ⟪ e ⟫)
+    ≈⟨ 𝒞.≈-sym (𝒞.assoc _ _ _) ⟩
+      (inj D₂ s' 𝒞.∘ α .transf s') 𝒞.∘ D₁ .fmor ⟪ e ⟫
+    ∎
+    where open ≈-Reasoning 𝒞.isEquiv
+
+  ∐-map : ∀ {S} {D₁ D₂ : Functor (setoid→category S) 𝒞} → NatTrans D₁ D₂ → ∐ S D₁ 𝒞.⇒ ∐ S D₂
+  ∐-map {S} {D₁} {D₂} α = LC S D₁ .colambda (∐ S D₂) (map-cocone α)
+
+  ∐-map-coeval : ∀ {S} {D₁ D₂ : Functor (setoid→category S) 𝒞} (α : NatTrans D₁ D₂) (s : S .Setoid.Carrier) →
+                 (∐-map α 𝒞.∘ inj D₁ s) 𝒞.≈ (inj D₂ s 𝒞.∘ α .transf s)
+  ∐-map-coeval {S} {D₁} {D₂} α s = LC S D₁ .colambda-coeval (∐ S D₂) (map-cocone α) .≃-NatTrans.transf-eq s
+
+  ∐-iso : ∀ {S} {D₁ D₂ : Functor (setoid→category S) 𝒞} → NatIso D₁ D₂ → 𝒞.Iso (∐ S D₁) (∐ S D₂)
+  ∐-iso {S} {D₁} {D₂} α .fwd = ∐-map (α .NatIso.transform)
+  ∐-iso {S} {D₁} {D₂} α .bwd = ∐-map (NatIso.transform⁻¹ α)
+  ∐-iso {S} {D₁} {D₂} α .fwd∘bwd≈id = colambda-unique (LC S D₂ .isColimit) uni
+    where
+      T  = α .NatIso.transform
+      T⁻ = NatIso.transform⁻¹ α
+      uni : ∀ s → ((∐-map T 𝒞.∘ ∐-map T⁻) 𝒞.∘ inj D₂ s) 𝒞.≈ (𝒞.id _ 𝒞.∘ inj D₂ s)
+      uni s = begin
+          (∐-map T 𝒞.∘ ∐-map T⁻) 𝒞.∘ inj D₂ s
+        ≈⟨ 𝒞.assoc _ _ _ ⟩
+          ∐-map T 𝒞.∘ (∐-map T⁻ 𝒞.∘ inj D₂ s)
+        ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (∐-map-coeval T⁻ s) ⟩
+          ∐-map T 𝒞.∘ (inj D₁ s 𝒞.∘ T⁻ .transf s)
+        ≈⟨ 𝒞.≈-sym (𝒞.assoc _ _ _) ⟩
+          (∐-map T 𝒞.∘ inj D₁ s) 𝒞.∘ T⁻ .transf s
+        ≈⟨ 𝒞.∘-cong (∐-map-coeval T s) 𝒞.≈-refl ⟩
+          (inj D₂ s 𝒞.∘ T .transf s) 𝒞.∘ T⁻ .transf s
+        ≈⟨ 𝒞.assoc _ _ _ ⟩
+          inj D₂ s 𝒞.∘ (T .transf s 𝒞.∘ T⁻ .transf s)
+        ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (α .NatIso.transf-iso s .Category.IsIso.f∘inverse≈id) ⟩
+          inj D₂ s 𝒞.∘ 𝒞.id _
+        ≈⟨ 𝒞.≈-trans 𝒞.id-right (𝒞.≈-sym 𝒞.id-left) ⟩
+          𝒞.id _ 𝒞.∘ inj D₂ s
+        ∎
+        where open ≈-Reasoning 𝒞.isEquiv
+  ∐-iso {S} {D₁} {D₂} α .bwd∘fwd≈id = colambda-unique (LC S D₁ .isColimit) uni
+    where
+      T  = α .NatIso.transform
+      T⁻ = NatIso.transform⁻¹ α
+      uni : ∀ s → ((∐-map T⁻ 𝒞.∘ ∐-map T) 𝒞.∘ inj D₁ s) 𝒞.≈ (𝒞.id _ 𝒞.∘ inj D₁ s)
+      uni s = begin
+          (∐-map T⁻ 𝒞.∘ ∐-map T) 𝒞.∘ inj D₁ s
+        ≈⟨ 𝒞.assoc _ _ _ ⟩
+          ∐-map T⁻ 𝒞.∘ (∐-map T 𝒞.∘ inj D₁ s)
+        ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (∐-map-coeval T s) ⟩
+          ∐-map T⁻ 𝒞.∘ (inj D₂ s 𝒞.∘ T .transf s)
+        ≈⟨ 𝒞.≈-sym (𝒞.assoc _ _ _) ⟩
+          (∐-map T⁻ 𝒞.∘ inj D₂ s) 𝒞.∘ T .transf s
+        ≈⟨ 𝒞.∘-cong (∐-map-coeval T⁻ s) 𝒞.≈-refl ⟩
+          (inj D₁ s 𝒞.∘ T⁻ .transf s) 𝒞.∘ T .transf s
+        ≈⟨ 𝒞.assoc _ _ _ ⟩
+          inj D₁ s 𝒞.∘ (T⁻ .transf s 𝒞.∘ T .transf s)
+        ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (α .NatIso.transf-iso s .Category.IsIso.inverse∘f≈id) ⟩
+          inj D₁ s 𝒞.∘ 𝒞.id _
+        ≈⟨ 𝒞.≈-trans 𝒞.id-right (𝒞.≈-sym 𝒞.id-left) ⟩
+          𝒞.id _ 𝒞.∘ inj D₁ s
+        ∎
+        where open ≈-Reasoning 𝒞.isEquiv
+
+  ------------------------------------------------------------------------------
+  -- Set-indexed stability yields binary stability for the derived coproducts.
+
+  private
+    module SC = stable-coproducts coproducts-from-indexed
+
+  stable-from-indexed : IdxStable → SC.Stable
+  stable-from-indexed idxstable {x₁} {x₂} {x} {y} f g = sb
+    where
+      module IB = IdxStableBits (idxstable {Two} {Dpair x₁ x₂} f g)
+
+      yy₁ = IB.E .fobj (inj₁ (lift tt))
+      yy₂ = IB.E .fobj (inj₂ (lift tt))
+
+      -- E and the two-element diagram on its objects agree up to identity.
+      natiso : NatIso (Dpair yy₁ yy₂) IB.E
+      natiso .NatIso.transform .transf (inj₁ _) = 𝒞.id _
+      natiso .NatIso.transform .transf (inj₂ _) = 𝒞.id _
+      natiso .NatIso.transform .natural {inj₁ _} {inj₁ _} _ =
+        𝒞.≈-trans 𝒞.id-right (𝒞.≈-trans (IB.E .fmor-id) (𝒞.≈-sym 𝒞.id-left))
+      natiso .NatIso.transform .natural {inj₂ _} {inj₂ _} _ =
+        𝒞.≈-trans 𝒞.id-right (𝒞.≈-trans (IB.E .fmor-id) (𝒞.≈-sym 𝒞.id-left))
+      natiso .NatIso.transf-iso (inj₁ _) .Category.IsIso.inverse = 𝒞.id _
+      natiso .NatIso.transf-iso (inj₂ _) .Category.IsIso.inverse = 𝒞.id _
+      natiso .NatIso.transf-iso (inj₁ _) .Category.IsIso.f∘inverse≈id = 𝒞.id-left
+      natiso .NatIso.transf-iso (inj₂ _) .Category.IsIso.f∘inverse≈id = 𝒞.id-left
+      natiso .NatIso.transf-iso (inj₁ _) .Category.IsIso.inverse∘f≈id = 𝒞.id-left
+      natiso .NatIso.transf-iso (inj₂ _) .Category.IsIso.inverse∘f≈id = 𝒞.id-left
+
+      -- The comparison iso commutes with the injections, so the factorisation
+      -- equations transport from IB.E's coproduct to the derived one.
+      adj₁ = 𝒞.≈-sym (𝒞.≈-trans (𝒞.assoc _ _ _)
+               (𝒞.∘-cong 𝒞.≈-refl (𝒞.≈-trans (∐-map-coeval (natiso .NatIso.transform) (inj₁ (lift tt))) 𝒞.id-right)))
+      adj₂ = 𝒞.≈-sym (𝒞.≈-trans (𝒞.assoc _ _ _)
+               (𝒞.∘-cong 𝒞.≈-refl (𝒞.≈-trans (∐-map-coeval (natiso .NatIso.transform) (inj₂ (lift tt))) 𝒞.id-right)))
+
+      sb : SC.StableBits f g
+      sb .SC.StableBits.y₁  = yy₁
+      sb .SC.StableBits.y₂  = yy₂
+      sb .SC.StableBits.h₁  = IB.leg (inj₁ (lift tt))
+      sb .SC.StableBits.h₂  = IB.leg (inj₂ (lift tt))
+      sb .SC.StableBits.h   = 𝒞.Iso-trans (∐-iso natiso) IB.h
+      sb .SC.StableBits.eq₁ = 𝒞.≈-trans (IB.eq (inj₁ (lift tt))) (𝒞.∘-cong 𝒞.≈-refl adj₁)
+      sb .SC.StableBits.eq₂ = 𝒞.≈-trans (IB.eq (inj₂ (lift tt))) (𝒞.∘-cong 𝒞.≈-refl adj₂)
+
+-- A functor preserving set-indexed coproducts preserves the finite coproducts
+-- derived from them (the two-element instance).
+module preserve
+  {oA mA eA oB mB eB}
+  {𝒜 : Category oA mA eA} {ℬ : Category oB mB eB}
+  where
+
+  private
+    module 𝒜 = Category 𝒜
+    module ℬ = Category ℬ
+
+  open Functor
+  open NatTrans
+
+  module _
+    {os es}
+    (𝒜CL : ∀ (S : Setoid os es) → HasColimits (setoid→category S) 𝒜)
+    (ℬCL : ∀ (S : Setoid os es) → HasColimits (setoid→category S) ℬ)
+    (F : Functor 𝒜 ℬ)
+    (F-DC : ∀ (S : Setoid os es) (D : Functor (setoid→category S) 𝒜) →
+            ∃ₛ (ℬ.Iso (Colimit.apex (ℬCL S (F ∘F D))) (F .fobj (Colimit.apex (𝒜CL S D))))
+               (λ i → ∀ s → (ℬ.Iso.fwd i ℬ.∘ Colimit.cocone (ℬCL S (F ∘F D)) .transf s) ℬ.≈
+                            F .fmor (Colimit.cocone (𝒜CL S D) .transf s)))
+    where
+
+    private
+      module SA = derive 𝒜CL
+      module SB = derive ℬCL
+      module 𝒜CP = HasCoproducts SA.coproducts-from-indexed
+      module ℬCP = HasCoproducts SB.coproducts-from-indexed
+
+    open ℬ.Iso
+    open ℬ.IsIso
+
+    preserve-from-indexed : preserve-chosen-coproducts F SA.coproducts-from-indexed SB.coproducts-from-indexed
+    preserve-from-indexed {x} {y} =
+      ℬ.IsIso-cong
+        (ℬ.≈-trans (ℬ.≈-sym (ℬCP.copair-ext (theIso .fwd))) (ℬCP.copair-cong onIn₁ onIn₂))
+        fwd-iso
+      where
+        module FI = ∃ₛ (F-DC SA.Two (SA.Dpair x y))
+
+        -- SB.Dpair (F x) (F y) and F ∘F SA.Dpair x y agree up to identity.
+        ψ : NatIso (SB.Dpair (F .fobj x) (F .fobj y)) (F ∘F SA.Dpair x y)
+        ψ .NatIso.transform .transf (inj₁ _) = ℬ.id _
+        ψ .NatIso.transform .transf (inj₂ _) = ℬ.id _
+        ψ .NatIso.transform .natural {inj₁ _} {inj₁ _} _ =
+          ℬ.≈-trans ℬ.id-right (ℬ.≈-trans (F .fmor-id) (ℬ.≈-sym ℬ.id-left))
+        ψ .NatIso.transform .natural {inj₂ _} {inj₂ _} _ =
+          ℬ.≈-trans ℬ.id-right (ℬ.≈-trans (F .fmor-id) (ℬ.≈-sym ℬ.id-left))
+        ψ .NatIso.transf-iso (inj₁ _) .inverse = ℬ.id _
+        ψ .NatIso.transf-iso (inj₂ _) .inverse = ℬ.id _
+        ψ .NatIso.transf-iso (inj₁ _) .f∘inverse≈id = ℬ.id-left
+        ψ .NatIso.transf-iso (inj₂ _) .f∘inverse≈id = ℬ.id-left
+        ψ .NatIso.transf-iso (inj₁ _) .inverse∘f≈id = ℬ.id-left
+        ψ .NatIso.transf-iso (inj₂ _) .inverse∘f≈id = ℬ.id-left
+
+        theIso : ℬ.Iso (ℬCP.coprod (F .fobj x) (F .fobj y)) (F .fobj (𝒜CP.coprod x y))
+        theIso = ℬ.Iso-trans (SB.∐-iso ψ) FI.fst
+
+        fwd-iso : ℬ.IsIso (theIso .fwd)
+        fwd-iso .inverse = theIso .bwd
+        fwd-iso .f∘inverse≈id = theIso .fwd∘bwd≈id
+        fwd-iso .inverse∘f≈id = theIso .bwd∘fwd≈id
+
+        -- theIso.fwd sends each injection to F of the corresponding one.
+        onIn₁ = ℬ.≈-trans (ℬ.assoc _ _ _)
+                  (ℬ.≈-trans (ℬ.∘-cong ℬ.≈-refl
+                               (ℬ.≈-trans (SB.∐-map-coeval (ψ .NatIso.transform) (inj₁ (lift tt))) ℬ.id-right))
+                             (FI.snd (inj₁ (lift tt))))
+        onIn₂ = ℬ.≈-trans (ℬ.assoc _ _ _)
+                  (ℬ.≈-trans (ℬ.∘-cong ℬ.≈-refl
+                               (ℬ.≈-trans (SB.∐-map-coeval (ψ .NatIso.transform) (inj₂ (lift tt))) ℬ.id-right))
+                             (FI.snd (inj₂ (lift tt))))
+
diff --git a/agda/src/functor-cat-products.agda b/agda/src/functor-cat-products.agda
index e9e67929..7c857694 100644
--- a/agda/src/functor-cat-products.agda
+++ b/agda/src/functor-cat-products.agda
@@ -47,7 +47,7 @@ _×_ : Functor 𝒞 𝒟 → Functor 𝒞 𝒟 → Functor 𝒞 𝒟
     P.prod-m (F .fmor (f 𝒞.∘ g)) (G .fmor (f 𝒞.∘ g))
   ≈⟨ P.prod-m-cong (F .fmor-comp _ _) (G .fmor-comp _ _) ⟩
     P.prod-m (F .fmor f 𝒟.∘ F .fmor g) (G .fmor f 𝒟.∘ G .fmor g)
-  ≈⟨ P.pair-functorial _ _ _ _ ⟩
+  ≈⟨ P.prod-m-comp _ _ _ _ ⟩
     P.prod-m (F .fmor f) (G .fmor f) 𝒟.∘ P.prod-m (F .fmor g) (G .fmor g)
   ∎ where open ≈-Reasoning 𝒟.isEquiv
 
diff --git a/agda/src/functor.agda b/agda/src/functor.agda
index c687e079..797ffdfc 100644
--- a/agda/src/functor.agda
+++ b/agda/src/functor.agda
@@ -4,7 +4,7 @@ module functor where
 
 open import Level using (_⊔_)
 open import prop using (tt; ⟪_⟫; ∃ₛ)
-open import categories using (Category; setoid→category)
+open import categories using (Category; setoid→category; HasProducts)
 open import prop-setoid using (Setoid; IsEquivalence; module ≈-Reasoning)
   renaming (_⇒_ to _⇒s_)
 
@@ -239,6 +239,47 @@ module _ {o₁ m₁ e₁}
   Id .fmor-id = 𝒞.≈-refl
   Id .fmor-comp f g = 𝒞.≈-refl
 
+  record StrongFunctor (P : HasProducts 𝒞) : Set (o₁ ⊔ m₁ ⊔ e₁) where
+    open Category 𝒞
+    open HasProducts P
+    field
+      F              : Functor 𝒞 𝒞
+      strengthᵣ : ∀ {x y} → prod x (F .fobj y) ⇒ F .fobj (prod x y)
+      strengthᵣ-natural : ∀ {x₁ x₂ y₁ y₂} (f : x₁ ⇒ x₂) (g : y₁ ⇒ y₂) →
+                               (F .Functor.fmor (prod-m f g) 𝒞.∘ strengthᵣ) 𝒞.≈
+                               (strengthᵣ 𝒞.∘ prod-m f (F .Functor.fmor g))
+      strengthᵣ-p₂ : ∀ {x y} → (F .Functor.fmor p₂ 𝒞.∘ strengthᵣ {x} {y}) 𝒞.≈ p₂
+      -- Associativity coherence: strengthᵣ commutes with the diagonal pair p₁ (id _),
+      -- the comultiplication of the prod x - comonad.
+      strengthᵣ-assoc : ∀ {x y} →
+        (strengthᵣ {x} {prod x y} 𝒞.∘ pair p₁ (strengthᵣ {x} {y}))
+        𝒞.≈ (F .Functor.fmor (pair p₁ (𝒞.id _)) 𝒞.∘ strengthᵣ {x} {y})
+    open Functor F public
+
+    -- strengthₗ (left strength) derived by swapping inputs/outputs around strengthᵣ.
+    strengthₗ : ∀ {x y} → prod (F .fobj x) y ⇒ F .fobj (prod x y)
+    strengthₗ = F .Functor.fmor (pair p₂ p₁) 𝒞.∘ strengthᵣ 𝒞.∘ pair p₂ p₁
+
+  -- Strong endofunctor with a unit.
+  record StrongPointedFunctor (P : HasProducts 𝒞) : Set (o₁ ⊔ m₁ ⊔ e₁) where
+    field
+      strongFunctor : StrongFunctor P
+      unit          : ∀ {x} → Category._⇒_ 𝒞 x (StrongFunctor.F strongFunctor .Functor.fobj x)
+    open StrongFunctor strongFunctor public
+
+  StrongFunctor-Id : ∀ (P : HasProducts 𝒞) → StrongFunctor P
+  StrongFunctor-Id P .StrongFunctor.F              = Id
+  StrongFunctor-Id P .StrongFunctor.strengthᵣ = 𝒞.id _
+  StrongFunctor-Id P .StrongFunctor.strengthᵣ-natural f g =
+    𝒞.isEquiv .IsEquivalence.trans 𝒞.id-right (𝒞.isEquiv .IsEquivalence.sym 𝒞.id-left)
+  StrongFunctor-Id P .StrongFunctor.strengthᵣ-p₂ = 𝒞.id-right
+  StrongFunctor-Id P .StrongFunctor.strengthᵣ-assoc =
+    𝒞.isEquiv .IsEquivalence.trans 𝒞.id-left (𝒞.isEquiv .IsEquivalence.sym 𝒞.id-right)
+
+  StrongPointedFunctor-Id : ∀ (P : HasProducts 𝒞) → StrongPointedFunctor P
+  StrongPointedFunctor-Id P .StrongPointedFunctor.strongFunctor = StrongFunctor-Id P
+  StrongPointedFunctor-Id P .StrongPointedFunctor.unit {x}      = 𝒞.id x
+
 module _ {o₁ m₁ e₁ o₂ m₂ e₂ o₃ m₃ e₃}
          {𝒞 : Category o₁ m₁ e₁}
          {𝒟 : Category o₂ m₂ e₂}
@@ -452,6 +493,30 @@ module _ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒮 : Category o₁ m₁ e₁} {𝒞
       isColimit : IsColimit D apex cocone
     open IsColimit isColimit public
 
+  -- Transport a colimit along an equivalent cocone.
+  IsColimit-cong : ∀ {D : Functor 𝒮 𝒞} {apex} {cocone₁ cocone₂ : NatTrans D (constF 𝒮 apex)} →
+                   ≃-NatTrans cocone₁ cocone₂ → IsColimit D apex cocone₁ → IsColimit D apex cocone₂
+  IsColimit-cong eq isColim .IsColimit.colambda = isColim .IsColimit.colambda
+  IsColimit-cong eq isColim .IsColimit.colambda-cong = isColim .IsColimit.colambda-cong
+  IsColimit-cong eq isColim .IsColimit.colambda-coeval x α .transf-eq s =
+    𝒞.≈-trans (𝒞.∘-cong 𝒞.≈-refl (𝒞.≈-sym (eq .transf-eq s)))
+              (isColim .IsColimit.colambda-coeval x α .transf-eq s)
+  IsColimit-cong eq isColim .IsColimit.colambda-ext x f =
+    𝒞.≈-trans (isColim .IsColimit.colambda-cong
+                 (∘NT-cong (≃-isEquivalence .refl) (≃-isEquivalence .sym eq)))
+              (isColim .IsColimit.colambda-ext x f)
+
+  -- Mediating morphisms out of a colimit are unique: morphisms agreeing on the cocone agree.
+  colambda-unique : ∀ {D : Functor 𝒮 𝒞} {apex} {cocone : NatTrans D (constF 𝒮 apex)} →
+                    IsColimit D apex cocone →
+                    ∀ {x} {f g : apex 𝒞.⇒ x} →
+                    (∀ s → (f 𝒞.∘ cocone .NatTrans.transf s) 𝒞.≈ (g 𝒞.∘ cocone .NatTrans.transf s)) →
+                    f 𝒞.≈ g
+  colambda-unique isColim {x} {f} {g} eq =
+    𝒞.≈-trans (𝒞.≈-sym (isColim .IsColimit.colambda-ext x f))
+    (𝒞.≈-trans (isColim .IsColimit.colambda-cong (record { transf-eq = eq }))
+               (isColim .IsColimit.colambda-ext x g))
+
   record IsLimit (D : Functor 𝒮 𝒞)
                  (apex : 𝒞.obj) (cone : NatTrans (constF 𝒮 apex) D)
            : Set (o₁ ⊔ m₁ ⊔ e₁ ⊔ o₂ ⊔ m₂ ⊔ e₂) where
@@ -735,6 +800,44 @@ module _ {o₁ m₁ e₁ o₂ m₂ e₂}
     ∎
     where open ≈-Reasoning 𝒞.isEquiv
 
+  private
+    coswitch : ∀ (D : Functor 𝒮 𝒞.opposite) {x} → NatTrans (constF 𝒮.opposite x) (opF' D) → NatTrans D (constF 𝒮 x)
+    coswitch D α .transf = α .transf
+    coswitch D α .natural f = 𝒞.≈-sym (α .natural f)
+
+    coswitch⁻¹ : ∀ (D : Functor 𝒮 𝒞.opposite) {x} → NatTrans D (constF 𝒮 x) → NatTrans (constF 𝒮.opposite x) (opF' D)
+    coswitch⁻¹ D α .transf = α .transf
+    coswitch⁻¹ D α .natural f = 𝒞.≈-sym (α .natural f)
+
+    coswitch⁻¹-cong : ∀ (D : Functor 𝒮 𝒞.opposite) {x} {α β} → ≃-NatTrans α β → ≃-NatTrans (coswitch⁻¹ D {x} α) (coswitch⁻¹ D {x} β)
+    coswitch⁻¹-cong D α≃β .transf-eq = α≃β .transf-eq
+
+    coswitch⁻¹-comp : ∀ D {x y α} {f : x 𝒞.⇒ y} → ≃-NatTrans (coswitch⁻¹ D {x} (constFmor f ∘ α)) (coswitch⁻¹ D α ∘ constFmor f)
+    coswitch⁻¹-comp D .transf-eq s = 𝒞.≈-refl
+
+    coswitch⁻¹-coswitch : ∀ D {x α} → ≃-NatTrans (coswitch⁻¹ D {x} (coswitch D α)) α
+    coswitch⁻¹-coswitch D .transf-eq s = 𝒞.≈-refl
+
+  op-limit : (D : Functor 𝒮 𝒞.opposite) → Limit (opF' D) → Colimit D
+  op-limit D limitOpD .Colimit.apex = limitOpD .Limit.apex
+  op-limit D limitOpD .Colimit.cocone = coswitch D (limitOpD .Limit.cone)
+  op-limit D limitOpD .Colimit.isColimit .IsColimit.colambda x α =
+    limitOpD .Limit.lambda x (coswitch⁻¹ D α)
+  op-limit D limitOpD .Colimit.isColimit .IsColimit.colambda-cong α≃β =
+    limitOpD .Limit.lambda-cong (coswitch⁻¹-cong D α≃β)
+  op-limit D limitOpD .Colimit.isColimit .IsColimit.colambda-coeval x α .transf-eq s =
+    limitOpD .Limit.lambda-eval _ .transf-eq s
+  op-limit D limitOpD .Colimit.isColimit .IsColimit.colambda-ext x f = begin
+      limitOpD .Limit.lambda x (coswitch⁻¹ D (constFmor f ∘ coswitch D (limitOpD .Limit.cone)))
+    ≈⟨ limitOpD .Limit.lambda-cong (coswitch⁻¹-comp D) ⟩
+      limitOpD .Limit.lambda x (coswitch⁻¹ D (coswitch D (limitOpD .Limit.cone)) ∘ constFmor f)
+    ≈⟨ limitOpD .Limit.lambda-cong (∘NT-cong (coswitch⁻¹-coswitch D) (≃-isEquivalence .refl)) ⟩
+      limitOpD .Limit.lambda x (limitOpD .Limit.cone ∘ constFmor f)
+    ≈⟨ limitOpD .Limit.lambda-ext f ⟩
+      f
+    ∎
+    where open ≈-Reasoning 𝒞.isEquiv
+
 
 ------------------------------------------------------------------------------
 -- Definition of limit preservation
diff --git a/agda/src/galois.agda b/agda/src/galois.agda
index 357fd3b5..3f790477 100644
--- a/agda/src/galois.agda
+++ b/agda/src/galois.agda
@@ -266,57 +266,6 @@ module _ where
   products .pair-p₂ f g .right-eq = meet-semilattice.pair-p₂ (right-∧ f) (right-∧ g) ._≃M_.eqfunc
   products .pair-ext f .right-eq = meet-semilattice.pair-ext (right-∧ f) ._≃M_.eqfunc
 
--- This category has a lifting monad
-module _ where
-
-  𝕃 : Obj → Obj
-  𝕃 X .carrier = L (X .carrier)
-  𝕃 X .meets = meet-semilattice.L (X .meets)
-  𝕃 X .joins = join-semilattice.L (X .joins)
-
-  𝕃-map : ∀ {X Y} → X ⇒g Y → 𝕃 X ⇒g 𝕃 Y
-  𝕃-map f .right = meet-semilattice.L-map (right-∧ f) ._=>M_.func
-  𝕃-map f .left = join-semilattice.L-map (left-∨ f) ._=>J_.func
-  𝕃-map f .left⊣right {bottom} {bottom} .proj₁ y≤Lfx = tt
-  𝕃-map f .left⊣right {< x >} {bottom} .proj₁ y≤Lfx = tt
-  𝕃-map f .left⊣right {< x >} {< y >} .proj₁ y≤Lfx = f .left⊣right .proj₁ y≤Lfx
-  𝕃-map f .left⊣right {bottom} {bottom} .proj₂ Lfy≤x = tt
-  𝕃-map f .left⊣right {< x >} {bottom} .proj₂ Lfy≤x = tt
-  𝕃-map f .left⊣right {< x >} {< y >} .proj₂ Lfy≤x = f .left⊣right .proj₂ Lfy≤x
-
-  𝕃-unit : ∀ {X} → X ⇒g 𝕃 X
-  𝕃-unit {X} .right = meet-semilattice.L-unit {X = X .meets} ._=>M_.func
-  𝕃-unit {X} .left = join-semilattice.L-counit {X = X .joins} ._=>J_.func
-  𝕃-unit {X} .left⊣right {x} {bottom} .proj₁ tt =
-    X .joins .JoinSemilattice.⊥-isBottom .IsBottom.≤-bottom
-  𝕃-unit .left⊣right {x} {< x₁ >} .proj₁ x₁≤x = x₁≤x
-  𝕃-unit .left⊣right {x} {bottom} .proj₂ x₁ = tt
-  𝕃-unit .left⊣right {x} {< x₁ >} .proj₂ x₁≤x = x₁≤x
-
-  𝕃-join : ∀ {X} → 𝕃 (𝕃 X) ⇒g 𝕃 X
-  𝕃-join {X} .right = meet-semilattice.L-join {X = X .meets} ._=>M_.func
-  𝕃-join {X} .left = join-semilattice.L-dup {X = X .joins} ._=>J_.func
-  𝕃-join .left⊣right {bottom} {bottom} .proj₁ e = tt
-  𝕃-join .left⊣right {< bottom >} {bottom} .proj₁ e = tt
-  𝕃-join .left⊣right {< < x > >} {bottom} .proj₁ e = tt
-  𝕃-join .left⊣right {< < x > >} {< x₁ >} .proj₁ e = e
-  𝕃-join .left⊣right {bottom} {bottom} .proj₂ e = tt
-  𝕃-join .left⊣right {< bottom >} {bottom} .proj₂ e = tt
-  𝕃-join .left⊣right {< < x > >} {bottom} .proj₂ e = tt
-  𝕃-join .left⊣right {< < x > >} {< x₁ >} .proj₂ e = e
-
-  𝕃-strength : ∀ {X Y} → (X ⊕ 𝕃 Y) ⇒g 𝕃 (X ⊕ Y)
-  𝕃-strength {X} {Y} .right = meet-semilattice.L-strength {X = X .meets} {Y .meets} ._=>M_.func
-  𝕃-strength {X} {Y} .left = join-semilattice.L-costrength {X = X .joins} {Y .joins} ._=>J_.func
-  𝕃-strength {X} .left⊣right {x , bottom} {bottom} .proj₁ e =
-    X .joins .JoinSemilattice.⊥-isBottom .IsBottom.≤-bottom , tt
-  𝕃-strength {X} .left⊣right {x , < x₁ >} {bottom} .proj₁ e =
-    X .joins .JoinSemilattice.⊥-isBottom .IsBottom.≤-bottom , tt
-  𝕃-strength .left⊣right {x , < x₂ >} {< x₁ >} .proj₁ e = e
-  𝕃-strength .left⊣right {x , bottom} {bottom} .proj₂ e = tt
-  𝕃-strength .left⊣right {x , < x₁ >} {bottom} .proj₂ e = tt
-  𝕃-strength .left⊣right {x , < x₁ >} {< x₂ >} .proj₂ e = e
-
 module _ where
 
   open import two using (Two; I; O; _⊓_; _⊔_)
diff --git a/agda/src/gf-preserves-mu-instance.agda b/agda/src/gf-preserves-mu-instance.agda
new file mode 100644
index 00000000..e9cce16a
--- /dev/null
+++ b/agda/src/gf-preserves-mu-instance.agda
@@ -0,0 +1,52 @@
+{-# OPTIONS --postfix-projections --prop --safe #-}
+
+-- Apply gf-preserves-mu at the interpretation instance: build the higher-order
+-- interpretation once, feed its glueing data to the proof, and discharge the
+-- recursive-types definability theorem.
+
+open import Level using (Level; 0ℓ; suc)
+open import categories using (Category; HasProducts; HasTerminal)
+open import cmon-enriched using (CMonEnriched; Biproduct; biproducts→products)
+open import functor using (Functor; HasLimits)
+open import prop using (∃; ∃ₛ; Prf)
+open import finite-product-functor using (preserve-chosen-products; preserve-chosen-terminal)
+open import signature using (Signature)
+import gf-preserves-mu
+import ho-model
+
+open Functor
+
+module gf-preserves-mu-instance
+  {o : Level}
+  (𝒞 : Category o 0ℓ 0ℓ)
+  (𝒞-terminal : HasTerminal 𝒞)
+  (𝒞-products : HasProducts 𝒞)
+  (𝒟 : Category (suc 0ℓ) 0ℓ 0ℓ)
+  (𝒟-cmon : CMonEnriched 𝒟)
+  (𝒟-limits : ∀ (𝒮 : Category 0ℓ 0ℓ 0ℓ) → HasLimits 𝒮 𝒟)
+  (𝒟-terminal : HasTerminal 𝒟)
+  (𝒟-biproducts : ∀ x y → Biproduct 𝒟-cmon x y)
+  (F : Functor 𝒞 𝒟)
+  (F-preserve-terminal : preserve-chosen-terminal F 𝒞-terminal 𝒟-terminal)
+  (F-preserve-products : preserve-chosen-products F 𝒞-products (biproducts→products _ 𝒟-biproducts))
+  (F-faithful : ∀ {a b} {g₁ g₂ : Category._⇒_ 𝒞 a b} → Category._≈_ 𝒟 (F .fmor g₁) (F .fmor g₂) → Category._≈_ 𝒞 g₁ g₂)
+  (F-def : ∀ {a b} (h : Category._⇒_ 𝒟 (F .fobj a) (F .fobj b)) →
+           Prf (∃ (Category._⇒_ 𝒞 a b) λ g → Category._≈_ 𝒟 (F .fmor g) h) →
+           ∃ₛ (Category._⇒_ 𝒞 a b) λ g → Category._≈_ 𝒟 (F .fmor g) h)
+  where
+
+  module I = ho-model.Interpretation 𝒞 𝒞-terminal 𝒞-products 𝒟 𝒟-cmon 𝒟-limits
+               𝒟-terminal 𝒟-biproducts F F-preserve-terminal F-preserve-products F-faithful F-def
+  open I.Conservativity
+
+  module GFM = gf-preserves-mu 𝒞 𝒞-terminal 𝒞-products
+                 Gl.cat GlPE.terminal GlPE.products GlPE.exponentials GlSC GDC
+                 GF GF-preserve-products GF-preserve-coproducts-indexed Gl-Mu Gl-Mu-obj
+
+  open GFM public using (GFμ)
+
+  -- Syntactic definability for the recursive-types language: higher-order terms
+  -- at first-order types collapse to Fam(𝒞) morphisms, for any signature and
+  -- model of it in Fam(𝒞).
+  module syntactic-μ {ℓ} (Sig : Signature ℓ) =
+    syntactic Sig Fam⟨𝒞⟩-strongCoproducts Fam⟨𝒞⟩-hasMu GF-preserve-strong-coproducts GFμ
diff --git a/agda/src/gf-preserves-mu.agda b/agda/src/gf-preserves-mu.agda
new file mode 100644
index 00000000..bc7b2fdc
--- /dev/null
+++ b/agda/src/gf-preserves-mu.agda
@@ -0,0 +1,194 @@
+{-# OPTIONS --postfix-projections --prop --safe #-}
+
+-- The glueing embedding preserves μ-types. Discharges the GFμ hypothesis of
+-- the conservativity theorem at the Fam instance: the source μ-object is the
+-- Fam(𝒞) W-tree, compared under GF against the realised Fam(Gl) W-tree.
+--
+-- Parameterised over the glued category and the embedding rather than the
+-- data they are built from, so checking this file does not rebuild the
+-- interpretation; gf-preserves-mu-instance supplies the pieces.
+
+open import Level using (Level; 0ℓ)
+open import Data.Nat using () renaming (suc to sucℕ; _+_ to _+ℕ_)
+open import Data.Fin using (Fin)
+open import categories
+  using (Category; HasProducts; HasTerminal; HasExponentials; HasStrongCoproducts;
+         setoid→category)
+open import prop-setoid using (Setoid)
+open import functor using (Functor; HasColimits; functor-preserve-iso; _∘F_; Colimit; NatIso)
+open import indexed-family using (Fam; fam→functor; functor→fam; fam→functor-eta)
+import fam
+import finite-coproducts-from-indexed
+open import finite-product-functor using (preserve-chosen-products)
+open import polynomial-functor
+  using (Preserves-μ; Poly; Poly-map; constant-free; constant-free-go; Poly-map-constant-free-go;
+         constant-free-go-Poly-map; #c; #c-Poly-map; consts; consts-Poly-map; _++e_; ++e-map)
+open import Relation.Binary.PropositionalEquality
+  using (_≡_; cong)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; subst to ≡-subst)
+import fam-mu-types
+import fam-mu-types.constant-free
+import fam-mu-realisation
+import fam-presentation
+import fam-mu-checked
+
+open Functor
+open Colimit
+
+module gf-preserves-mu
+  {o o' m' e' : Level}
+  (𝒞 : Category o 0ℓ 0ℓ)
+  (𝒞-terminal : HasTerminal 𝒞)
+  (𝒞-products : HasProducts 𝒞)
+  (Gl : Category o' m' e')
+  (GlT : HasTerminal Gl)
+  (GlP : HasProducts Gl)
+  (GlE : HasExponentials Gl GlP)
+  (GlSC : HasStrongCoproducts Gl GlP)
+  (GDC : ∀ (A : Setoid 0ℓ 0ℓ) → HasColimits (setoid→category A) Gl)
+  (GF : Functor (fam.CategoryOfFamilies.cat 0ℓ 0ℓ 𝒞) Gl)
+  (GF-preserve-products :
+     preserve-chosen-products GF (fam.CategoryOfFamilies.products.products 0ℓ 0ℓ 𝒞 𝒞-products) GlP)
+  (GF-preserve-coproducts-indexed :
+     ∀ (S : Setoid 0ℓ 0ℓ) (D : Functor (setoid→category S) (fam.CategoryOfFamilies.cat 0ℓ 0ℓ 𝒞)) →
+     Category.Iso Gl (GDC S (GF ∘F D) .apex)
+                     (GF .fobj (fam.CategoryOfFamilies.bigCoproducts 0ℓ 0ℓ 𝒞 S D .apex)))
+  (Gl-Mu : polynomial-functor.Interp.HasMu GlT GlP GlSC)
+  (Gl-Mu-obj : ∀ {n} (Q : Poly Gl (sucℕ n)) (δ : Fin n → Category.obj Gl) →
+     polynomial-functor.Interp.HasMu.μ-obj Gl-Mu Q δ ≡
+     fam-mu-realisation.μ-objℰ 0ℓ 0ℓ GDC GlT GlP GlE GlSC Q δ)
+  where
+
+  private
+    module Glued = Category Gl
+    module Sk  = fam-mu-types.constant-free 0ℓ 0ℓ 𝒞-terminal 𝒞-products
+    module SkGl = fam-mu-types.constant-free 0ℓ 0ℓ GlT GlP
+    module FMc = fam-mu-types 0ℓ 0ℓ 𝒞-terminal 𝒞-products
+    module RGl = fam-mu-realisation 0ℓ 0ℓ GDC GlT GlP GlE GlSC
+    module FMg = RGl.FM
+    module Pres = fam-presentation 0ℓ 0ℓ {𝒞}
+    module Gld = finite-coproducts-from-indexed.derive GDC
+    module FamGl = FMg.Fam𝒞
+    module Chk = fam-mu-checked 0ℓ 0ℓ 𝒞-terminal 𝒞-products GlT GlP GF GF-preserve-products
+  open RGl using (realise; η)
+
+  module Fam⟨𝒞⟩ = fam.CategoryOfFamilies 0ℓ 0ℓ 𝒞
+
+  Fam⟨𝒞⟩-terminal : HasTerminal Fam⟨𝒞⟩.cat
+  Fam⟨𝒞⟩-terminal = Fam⟨𝒞⟩.terminal 𝒞-terminal
+
+  Fam⟨𝒞⟩-products : HasProducts Fam⟨𝒞⟩.cat
+  Fam⟨𝒞⟩-products = Fam⟨𝒞⟩.products.products 𝒞-products
+
+  Fam⟨𝒞⟩-strongCoproducts : HasStrongCoproducts Fam⟨𝒞⟩.cat Fam⟨𝒞⟩-products
+  Fam⟨𝒞⟩-strongCoproducts = Fam⟨𝒞⟩.products.strongCoproducts 𝒞-products
+
+  Fam⟨𝒞⟩-hasMu : polynomial-functor.Interp.HasMu Fam⟨𝒞⟩-terminal Fam⟨𝒞⟩-products Fam⟨𝒞⟩-strongCoproducts
+  Fam⟨𝒞⟩-hasMu = fam-mu-types.hasMu 0ℓ 0ℓ 𝒞-terminal 𝒞-products
+
+  -- Source side of the carrier comparison: GF of a Fam W-tree is the Gl
+  -- set-indexed coproduct of the GF-images of its singleton fibres, via the
+  -- canonical presentation and GF's preservation of set-indexed coproducts.
+  source-iso : (M : Fam⟨𝒞⟩.Obj) →
+    Glued.Iso (GF .fobj M) (GDC (M .Fam⟨𝒞⟩.Obj.idx) (GF ∘F Pres.singletons M) .apex)
+  source-iso M =
+    Glued.Iso-trans
+      (Glued.Iso-sym (functor-preserve-iso GF (Pres.present M)))
+      (Glued.Iso-sym (GF-preserve-coproducts-indexed (M .Fam⟨𝒞⟩.Obj.idx) (Pres.singletons M)))
+
+  -- The checked presentation of a Fam(𝒞)-object: the Fam(Gl)-family over the
+  -- same index setoid, obtained by applying GF to the singleton fibres.
+  check : Fam⟨𝒞⟩.Obj → FMg.Obj
+  check = Chk.check
+
+  -- Compare GF of a family against the realisation of a Gl-family over the same
+  -- index setoid, given a pointwise isomorphism of the fibre diagrams.
+  presented-iso : (M : Fam⟨𝒞⟩.Obj) (Nf : Fam (M .Fam⟨𝒞⟩.Obj.idx) Gl) →
+                  NatIso (GF ∘F Pres.singletons M) (fam→functor Nf) →
+                  Glued.Iso (GF .fobj M) (realise .fobj (record { idx = M .Fam⟨𝒞⟩.Obj.idx ; fam = Nf }))
+  presented-iso M Nf α = Glued.Iso-trans (source-iso M) (Gld.∐-iso α)
+
+  -- GF of a family is the realisation of its checked presentation.
+  check-iso : (M : Fam⟨𝒞⟩.Obj) → Glued.Iso (GF .fobj M) (realise .fobj (check M))
+  check-iso M =
+    presented-iso M (functor→fam (GF ∘F Pres.singletons M)) (fam→functor-eta (GF ∘F Pres.singletons M))
+
+  -- check commutes with μ at the constant-free form, as an iso in Fam(Gl):
+  -- the shared shapes make the index setoids agree, and the fibres are products
+  -- of GF-images compared by tree recursion.
+  check-μ : ∀ {n} (P : Poly Fam⟨𝒞⟩.cat (sucℕ n)) (ε : Fin (n +ℕ #c P) → Fam⟨𝒞⟩.Obj) →
+            FamGl.Iso (check (FMc.μObj (constant-free P) ε)) (FMg.μObj (constant-free P) (λ i → check (ε i)))
+  check-μ P ε = Chk.ChkMu.check-μ-iso P ε
+
+  -- Realised μ-objects along an equality of polynomials.
+  μObj-≡-iso : ∀ {k} {Q₁ Q₂ : Poly FMg.cat (sucℕ k)} (e : Q₁ ≡ Q₂) (δ̂ : Fin k → FMg.Obj) →
+               Glued.Iso (realise .fobj (FMg.μObj Q₁ δ̂)) (realise .fobj (FMg.μObj Q₂ δ̂))
+  μObj-≡-iso ≡-refl δ̂ = Glued.Iso-refl
+
+  obj-≡-iso : ∀ {X Y : Glued.obj} → X ≡ Y → Glued.Iso X Y
+  obj-≡-iso ≡-refl = Glued.Iso-refl
+
+  -- GF preserves μ-types: constant-free in Fam(𝒞), carrier comparison, invariance at
+  -- the checked-versus-embedded environments, and the realised constant-free in
+  -- Fam(Gl), backwards.
+  GFμ : Preserves-μ Fam⟨𝒞⟩-terminal Fam⟨𝒞⟩-products Fam⟨𝒞⟩-strongCoproducts
+          GlT GlP GlSC Fam⟨𝒞⟩-hasMu Gl-Mu GF
+  GFμ {n} P δ =
+    Glued.Iso-trans (functor-preserve-iso GF (Sk.constant-free-μ-iso P δ))
+    (Glued.Iso-trans (check-iso (FMc.μObj (constant-free P) ε))
+    (Glued.Iso-trans (functor-preserve-iso realise (check-μ P ε))
+    (Glued.Iso-trans (μObj-≡-iso (≡-sym (Poly-map-constant-free-go η P (λ c → c))) (λ i → check (ε i)))
+    (Glued.Iso-trans (RGl.MuInvariance.mu-invariance SKg (RGl.invarianceAt SKg)
+                       (λ i → check (ε i)) (λ i → η .fobj (GF .fobj (ε i))) isos)
+    (Glued.Iso-trans realised-constant-free
+      (obj-≡-iso (≡-sym (Gl-Mu-obj (Poly-map GF P) (λ i → GF .fobj (δ i))))))))))
+    where
+      ε : Fin (n +ℕ #c P) → Fam⟨𝒞⟩.Obj
+      ε = δ ++e consts P
+
+      SKg : Poly Gl (sucℕ (n +ℕ #c P))
+      SKg = constant-free P
+
+      isos : ∀ i → Glued.Iso (realise .fobj (check (ε i)))
+                             (realise .fobj (η .fobj (GF .fobj (ε i))))
+      isos i = Glued.Iso-trans (Glued.Iso-sym (check-iso (ε i)))
+                 (Glued.Iso-sym (RGl.realise-η-iso (GF .fobj (ε i))))
+
+      -- The realised constant-free in Fam(Gl), backwards: invariance the embedded
+      -- environment onto the extended one, share the constant-free form between P and its
+      -- GF-image, and apply the Fam(Gl) constant-free lemma at the image polynomial.
+      realised-constant-free : Glued.Iso (RGl.Creal SKg (λ i → η .fobj (GF .fobj (ε i))))
+                                    (RGl.μ-objℰ (Poly-map GF P) (λ i → GF .fobj (δ i)))
+      realised-constant-free =
+        Glued.Iso-trans
+          (RGl.MuInvariance.mu-invariance SKg (RGl.invarianceAt SKg)
+            (λ i → η .fobj (GF .fobj (ε i))) (δ̂ ++e cs̄)
+            (λ i → obj-≡-iso (cong (realise .fobj)
+                     (++e-map (λ X → η .fobj (GF .fobj X)) δ (consts P) i))))
+        (Glued.Iso-trans (Glued.Iso-sym (μObj-≡-iso constant-free-forms-agree (δ̂ ++e cs̄)))
+          (Glued.Iso-sym (functor-preserve-iso realise SkI.constant-free-inst-iso)))
+        where
+          δ̂ : Fin n → FMg.Obj
+          δ̂ i = η .fobj (GF .fobj (δ i))
+
+          cs̄ : Fin (#c P) → FMg.Obj
+          cs̄ c = η .fobj (GF .fobj (consts P c))
+
+          P̂ : Poly FMg.cat (sucℕ n)
+          P̂ = Poly-map η (Poly-map GF P)
+
+          ι̂ : Fin (#c P̂) → Fin (#c P)
+          ι̂ c = ≡-subst Fin (#c-Poly-map GF P) (≡-subst Fin (#c-Poly-map η (Poly-map GF P)) c)
+
+          csok : ∀ c → cs̄ (ι̂ c) ≡ consts P̂ c
+          csok c =
+            ≡-sym (≡-trans (consts-Poly-map η (Poly-map GF P) c)
+              (cong (η .fobj) (consts-Poly-map GF P (≡-subst Fin (#c-Poly-map η (Poly-map GF P)) c))))
+
+          module SkI = SkGl.ConstantFree.Inst δ̂ cs̄ P̂ ι̂ csok
+
+          constant-free-forms-agree : constant-free-go P̂ ι̂ ≡ Poly-map η SKg
+          constant-free-forms-agree =
+            ≡-trans (constant-free-go-Poly-map η (Poly-map GF P) (λ c → ≡-subst Fin (#c-Poly-map GF P) c))
+              (≡-trans (constant-free-go-Poly-map GF P (λ c → c))
+                (≡-sym (Poly-map-constant-free-go η P (λ c → c))))
diff --git a/agda/src/hide-algebra.agda b/agda/src/hide-algebra.agda
new file mode 100644
index 00000000..a86b490c
--- /dev/null
+++ b/agda/src/hide-algebra.agda
@@ -0,0 +1,170 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Data.Fin as Fin using (Fin)
+open import Data.List using (List; []; _∷_; foldl)
+open import Data.List.Relation.Unary.All using (All; []; _∷_) renaming (map to All-map)
+open import Data.Nat using (ℕ; zero; suc)
+open import Data.Product using (_×_; _,_; proj₁; proj₂)
+open import Relation.Binary.PropositionalEquality using (_≡_)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; cong to ≡-cong; cong₂ to ≡-cong₂)
+import matrix
+import two
+
+-- Hiding as join algebra, generic in the vertex set: entrywise laws for hide-all on graphs that
+-- agree on the hidden rows and columns. No rank or forwardness is assumed.
+module hide-algebra where
+
+private
+  module M = matrix.Mat two.semiring
+
+open two using (Two; O; I; _⊔_; ⊔-idem; ⊔-comm; ⊔-runit; ⊔-assoc)
+
+module Hide {ℓ} (V : Set ℓ) (w : V → ℕ) where
+  Gr : Set ℓ
+  Gr = (x y : V) → M.Matrix (w y) (w x)
+
+  h : Gr → V → Gr
+  h G r x y = G x y M.+ₘ (G r y M.∘ G x r)
+
+  _≈g_ : Gr → Gr → Set ℓ
+  G ≈g G' = ∀ x y (i : Fin (w y)) (j : Fin (w x)) → G x y i j ≡ G' x y i j
+
+  private
+    ⊔-absorbˡ : ∀ a b → (a ⊔ (a ⊔ b)) ≡ (a ⊔ b)
+    ⊔-absorbˡ O b = ≡-refl
+    ⊔-absorbˡ I b = ≡-refl
+
+    ⊔-absorbʳ : ∀ a b → (a ⊔ (b ⊔ a)) ≡ (b ⊔ a)
+    ⊔-absorbʳ O b = ≡-refl
+    ⊔-absorbʳ I O = ≡-refl
+    ⊔-absorbʳ I I = ≡-refl
+
+    absorb-mono : ∀ x y z → x ≡ (y ⊔ x) → (z ⊔ y) ≡ y → x ≡ (z ⊔ x)
+    absorb-mono x y O p q = ≡-refl
+    absorb-mono x O I p ()
+    absorb-mono x I I p ≡-refl = p
+
+    ⊔-shift : ∀ a s c → ((a ⊔ s) ⊔ c) ≡ ((a ⊔ c) ⊔ s)
+    ⊔-shift O s c = ⊔-comm s c
+    ⊔-shift I s c = ≡-refl
+
+    ⊔-insert : ∀ a b c → (a ⊔ b) ≡ b → (b ⊔ c) ≡ (b ⊔ (a ⊔ c))
+    ⊔-insert O b c q = ≡-refl
+    ⊔-insert I O c ()
+    ⊔-insert I I c ≡-refl = ≡-refl
+
+  private
+    Σ-O : ∀ {n} (f : Fin n → Two) → (∀ k → f k ≡ O) → M.Σ f ≡ O
+    Σ-O {zero}  f z = ≡-refl
+    Σ-O {suc n} f z =
+      ≡-cong₂ _⊔_ (z Fin.zero) (Σ-O (λ k → f (Fin.suc k)) (λ k → z (Fin.suc k)))
+
+    ⊓-O : ∀ x → (x two.⊓ O) ≡ O
+    ⊓-O O = ≡-refl
+    ⊓-O I = ≡-refl
+
+  -- Zero rows and columns persist under hiding: every new entry into the row or column of r₀
+  -- factors through an entry of that row or column.
+  zero-fold : ∀ {G : Gr} rs r₀ →
+              (((z : V) (i : Fin (w z)) (j : Fin (w r₀)) → G r₀ z i j ≡ O) ×
+               ((z : V) (i : Fin (w r₀)) (j : Fin (w z)) → G z r₀ i j ≡ O)) →
+              (((z : V) (i : Fin (w z)) (j : Fin (w r₀)) → foldl h G rs r₀ z i j ≡ O) ×
+               ((z : V) (i : Fin (w r₀)) (j : Fin (w z)) → foldl h G rs z r₀ i j ≡ O))
+  zero-fold []           r₀ zz        = zz
+  zero-fold {G} (r ∷ rs) r₀ (zr , zc) = zero-fold {h G r} rs r₀ (zr' , zc')
+    where
+    zr' : (z : V) (i : Fin (w z)) (j : Fin (w r₀)) → h G r r₀ z i j ≡ O
+    zr' z i j =
+      ≡-cong₂ _⊔_ (zr z i j)
+        (Σ-O (λ k → G r z i k two.⊓ G r₀ r k j)
+             (λ k → ≡-trans (≡-cong (G r z i k two.⊓_) (zr r k j)) (⊓-O (G r z i k))))
+
+    zc' : (z : V) (i : Fin (w r₀)) (j : Fin (w z)) → h G r z r₀ i j ≡ O
+    zc' z i j =
+      ≡-cong₂ _⊔_ (zc z i j)
+        (Σ-O (λ k → G r r₀ i k two.⊓ G z r k j)
+             (λ k → ≡-cong (two._⊓ G z r k j) (zc r i k)))
+
+  -- Hiding only adds entries.
+  increasing : ∀ {G : Gr} rs x y (i : Fin (w y)) (j : Fin (w x)) →
+               foldl h G rs x y i j ≡ (G x y i j ⊔ foldl h G rs x y i j)
+  increasing []           x y i j = ≡-sym ⊔-idem
+  increasing {G} (r ∷ rs) x y i j =
+    absorb-mono (foldl h (h G r) rs x y i j) (h G r x y i j) (G x y i j)
+                (increasing rs x y i j)
+                (⊔-absorbˡ (G x y i j) ((G r y M.∘ G x r) i j))
+
+  h-cong : ∀ {G G'} r → G ≈g G' → h G r ≈g h G' r
+  h-cong r p x y i j =
+    ≡-cong₂ _⊔_ (p x y i j) (M.Σ-cong-≡ (λ k → ≡-cong₂ two._⊓_ (p r y i k) (p x r k j)))
+
+  fold-cong : ∀ {G G'} rs → G ≈g G' → foldl h G rs ≈g foldl h G' rs
+  fold-cong []       p = p
+  fold-cong (r ∷ rs) p = fold-cong rs (h-cong r p)
+
+  -- A summand with no entries at the hidden vertices passes through hiding them: every new
+  -- composite routes through a hidden row and column, which the summand lacks.
+  add-inert : ∀ {G S : Gr} rs →
+              All (λ r → ((z : V) (i : Fin (w z)) (j : Fin (w r)) → S r z i j ≡ O)
+                       × ((z : V) (i : Fin (w r)) (j : Fin (w z)) → S z r i j ≡ O)) rs →
+              ∀ x y (i : Fin (w y)) (j : Fin (w x)) →
+              foldl h (λ x' y' → G x' y' M.+ₘ S x' y') rs x y i j ≡
+              (foldl h G rs x y i j ⊔ S x y i j)
+  add-inert []               []               x y i j = ≡-refl
+  add-inert {G} {S} (r ∷ rs) ((zr , zc) ∷ zs) x y i j =
+    ≡-trans (fold-cong rs step x y i j) (add-inert {h G r} {S} rs zs x y i j)
+    where
+    step : h (λ x' y' → G x' y' M.+ₘ S x' y') r ≈g (λ x' y' → h G r x' y' M.+ₘ S x' y')
+    step x' y' i' j' =
+      ≡-trans
+        (≡-cong ((G x' y' i' j' ⊔ S x' y' i' j') ⊔_)
+          (M.Σ-cong-≡ (λ k → ≡-cong₂ two._⊓_
+            (≡-trans (≡-cong (G r y' i' k ⊔_) (zr y' i' k)) (⊔-runit {G r y' i' k}))
+            (≡-trans (≡-cong (G x' r k j' ⊔_) (zc x' k j')) (⊔-runit {G x' r k j'})))))
+        (⊔-shift (G x' y' i' j') (S x' y' i' j') ((G r y' M.∘ G x' r) i' j'))
+
+  -- Hiding vertices at which a larger graph agrees with a smaller one adds only its extra
+  -- entries: every new composite routes through agreed rows and columns, so already arises in
+  -- the smaller graph.
+  agree-add : ∀ {G G' : Gr} rs →
+              (∀ x y (i : Fin (w y)) (j : Fin (w x)) → (G x y i j ⊔ G' x y i j) ≡ G' x y i j) →
+              All (λ r → ((z : V) (i : Fin (w z)) (j : Fin (w r)) → G' r z i j ≡ G r z i j)
+                       × ((z : V) (i : Fin (w r)) (j : Fin (w z)) → G' z r i j ≡ G z r i j)) rs →
+              ∀ x y (i : Fin (w y)) (j : Fin (w x)) →
+              foldl h G' rs x y i j ≡ (G' x y i j ⊔ foldl h G rs x y i j)
+  agree-add {G} {G'} []       sub _              x y i j =
+    ≡-sym (≡-trans (⊔-comm (G' x y i j) (G x y i j)) (sub x y i j))
+  agree-add {G} {G'} (r ∷ rs) sub ((ar , ac) ∷ as) x y i j =
+    ≡-trans (agree-add {h G r} {h G' r} rs sub' all' x y i j)
+    (≡-trans (≡-cong (_⊔ foldl h (h G r) rs x y i j) (step x y i j))
+    (≡-trans (⊔-assoc (G' x y i j) (h G r x y i j) (foldl h (h G r) rs x y i j))
+             (≡-cong (G' x y i j ⊔_) (≡-sym (increasing rs x y i j)))))
+    where
+    step : ∀ x' y' (i' : Fin (w y')) (j' : Fin (w x')) →
+           h G' r x' y' i' j' ≡ (G' x' y' i' j' ⊔ h G r x' y' i' j')
+    step x' y' i' j' =
+      ≡-trans
+        (≡-cong (G' x' y' i' j' ⊔_)
+          (M.Σ-cong-≡ (λ k → ≡-cong₂ two._⊓_ (ar y' i' k) (ac x' k j'))))
+        (⊔-insert (G x' y' i' j') (G' x' y' i' j') ((G r y' M.∘ G x' r) i' j')
+                  (sub x' y' i' j'))
+
+    sub' : ∀ x' y' (i' : Fin (w y')) (j' : Fin (w x')) →
+           (h G r x' y' i' j' ⊔ h G' r x' y' i' j') ≡ h G' r x' y' i' j'
+    sub' x' y' i' j' =
+      ≡-trans (≡-cong (h G r x' y' i' j' ⊔_) (step x' y' i' j'))
+      (≡-trans (⊔-absorbʳ (h G r x' y' i' j') (G' x' y' i' j')) (≡-sym (step x' y' i' j')))
+
+    all' : All (λ r' → ((z : V) (i' : Fin (w z)) (j' : Fin (w r')) →
+                        h G' r r' z i' j' ≡ h G r r' z i' j')
+                     × ((z : V) (i' : Fin (w r')) (j' : Fin (w z)) →
+                        h G' r z r' i' j' ≡ h G r z r' i' j')) rs
+    all' = All-map
+      (λ {r'} (ar' , ac') →
+        (λ z i' j' → ≡-trans (step r' z i' j')
+                     (≡-trans (≡-cong (_⊔ h G r r' z i' j') (ar' z i' j'))
+                              (⊔-absorbˡ (G r' z i' j') ((G r z M.∘ G r' r) i' j')))) ,
+        (λ z i' j' → ≡-trans (step z r' i' j')
+                     (≡-trans (≡-cong (_⊔ h G r z r' i' j') (ac' z i' j'))
+                              (⊔-absorbˡ (G z r' i' j') ((G r r' M.∘ G z r) i' j')))))
+      as
diff --git a/agda/src/ho-model-sd-semimod.agda b/agda/src/ho-model-sd-semimod.agda
index 065060cb..8d693380 100644
--- a/agda/src/ho-model-sd-semimod.agda
+++ b/agda/src/ho-model-sd-semimod.agda
@@ -3,17 +3,24 @@
 -- The higher-order model with SDSemiMod as the first-order model: families over self-dual
 -- semimodules, interpreted in Fam(SemiMod S) via the forgetful functor U.
 open import Level using (0ℓ)
-open import prop-setoid using (Setoid)
+open import Data.List using (List; []; _∷_)
+open import Data.Product using (_,_)
+open import Data.Unit.Polymorphic using (tt)
+open import prop-setoid using (Setoid; idS; _∘S_)
 open import commutative-semiring using (CommutativeSemiring)
-open import signature using (Signature; Model; PFPC[_,_,_,_])
-open import Data.Product using (_,_; Σ-syntax)
-open import Data.Nat using (ℕ; _+_)
-open import Data.Sum using (inj₁; inj₂)
-import nat
-import lists
+open import signature using (Signature; Model; PointedFPCat; PFPC[_,_,_,_])
+open import categories using (Category; HasProducts)
+open import functor using (Functor)
+open import Relation.Binary.PropositionalEquality using (refl)
+import prop
+open prop using (_,_)
+open import primitives using (Primitives; sort-vals-setoid)
 import language-syntax
+import indexed-family
 import semimodule
 import sd-semimodule
+import matrix
+import matrix-embedding-semimod
 import ho-model
 
 module ho-model-sd-semimod {A : Setoid 0ℓ 0ℓ} (S : CommutativeSemiring A) where
@@ -25,67 +32,94 @@ open ho-model.Interpretation
   SDSemiMod.cat SDSemiMod.terminal SDSemiMod.products
   SemiMod.cat SemiMod.cmon-enriched SemiMod.limits SemiMod.terminal SemiMod.biproduct
   SDSemiMod.U SDSemiMod.U-preserve-terminal (λ {X} {Y} → SDSemiMod.U-preserve-products {X} {Y})
+  (λ e → e) (λ h _ → h , Category.≈-refl SemiMod.cat)
   public
 
--- Self-dualities on first-order-data types.
+
+-- The interpretation of the primitives: a sort's fibre is the free object of its width, and an
+-- operation's fibre map at a tuple of constants is its dependency relation there, read as a morphism
+-- through the matrix embedding.
+module interp-primitives (Sig : Signature 0ℓ) (𝒫 : Primitives S Sig) where
+
+  open Signature Sig
+  open Primitives 𝒫
+  open prop-setoid._⇒_ using (func; func-resp-≈)
+
+  private
+    module SM = Category SemiMod.cat
+    module M = matrix.Mat S
+    module MES = matrix-embedding-semimod S
+    module FC = Category Fam⟨𝒞⟩.cat
+    module FP = HasProducts Fam⟨𝒞⟩-products
+    open Category.Iso
+
+  open Fam⟨𝒞⟩ using (simple[_,_]; simplef[_,_]; Obj; Mor)
+  open Fam⟨𝒞⟩.products SDSemiMod.products using (simple-monoidal)
+  open Fam⟨𝒞⟩.predicates SDSemiMod.terminal using (predicate)
+  open indexed-family._⇒f_
+  open Fam⟨𝒞⟩.Mor using (idxf; famf)
+
+  private
+    PF : PointedFPCat _ _ _
+    PF = PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ]
+
+  ⟦sort⟧′ : sort → Obj
+  ⟦sort⟧′ s = simple[ sort-index s , SDSemiMod.S^ (sort-width s) ]
+
+  args : List sort → Obj
+  args = PointedFPCat.list→product PF ⟦sort⟧′
+
+  -- Reassociate the index of the argument product into a tuple of constants.
+  untuple : ∀ is → prop-setoid._⇒_ (Fam⟨𝒞⟩.Obj.idx (args is)) (sort-vals-setoid sort-index is)
+  untuple []       .func _ = tt
+  untuple (i ∷ is) .func (v , p) = v , untuple is .func p
+  untuple []       .func-resp-≈ _ = prop.tt
+  untuple (i ∷ is) .func-resp-≈ e = prop.proj₁ e prop., untuple is .func-resp-≈ (prop.proj₂ e)
+
+  -- Collapse the argument product onto the free object of the summed widths.
+  collect : ∀ is → Mor (args is) simple[ sort-vals-setoid sort-index is , SDSemiMod.S^ (bases-width is) ]
+  collect []       = simplef[ untuple [] , Category.id SDSemiMod.cat (SDSemiMod.S^ 0) ]
+  collect (i ∷ is) =
+    simplef[ idS _ , SDSemiMod.S^-+ (sort-width i) (bases-width is) .SDSemiMod._≅sd_.iso .fwd ]
+      FC.∘ simple-monoidal
+      FC.∘ FP.prod-m (FC.id (⟦sort⟧′ i)) (collect is)
+
+  -- A dependency relation as a morphism between free objects.
+  matrix-mor : ∀ {m n} → Category._⇒_ M.cat m n →
+               SM._⇒_ (SDSemiMod.SelfDual.obj (SDSemiMod.S^ m)) (SDSemiMod.SelfDual.obj (SDSemiMod.S^ n))
+  matrix-mor {m} {n} R =
+    MES.X^≅S^ n .fwd SM.∘ (Functor.fmor MES.mat→mor R SM.∘ MES.X^≅S^ m .bwd)
+
+  matrix-mor-cong : ∀ {m n} {R R' : Category._⇒_ M.cat m n} →
+                    Category._≈_ M.cat R R' → SM._≈_ (matrix-mor R) (matrix-mor R')
+  matrix-mor-cong {m} {n} e =
+    SM.∘-cong (SM.≈-refl {f = MES.X^≅S^ n .fwd})
+      (SM.∘-cong (Functor.fmor-cong MES.mat→mor e) (SM.≈-refl {f = MES.X^≅S^ m .bwd}))
+
+  model : Model PF Sig
+  model .Model.⟦sort⟧ = ⟦sort⟧′
+  model .Model.⟦op⟧ {is} {o} ω = opω FC.∘ collect is
+    where
+    opω : Mor simple[ sort-vals-setoid sort-index is , SDSemiMod.S^ (bases-width is) ] (⟦sort⟧′ o)
+    opω .idxf = op-fun ω
+    opω .famf .transf c = matrix-mor (op-deps ω .func c)
+    opω .famf .natural {c} {c'} e =
+      SM.≈-trans SM.id-right
+        (SM.≈-trans (matrix-mor-cong (Category.≈-sym M.cat (op-deps ω .func-resp-≈ e)))
+                    (SM.≈-sym SM.id-left))
+  model .Model.⟦rel⟧ {is} ψ = predicate (rel-pred ψ ∘S untuple is)
+
+-- Self-dualities on the first-order types of the language with general
+-- recursive types: instantiate the generic fibre-object machinery at the
+-- self-dual semimodules.
 module interp-sd (Sig : Signature 0ℓ)
-                 (Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig)
+                   (Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig)
    where
 
   open interp Sig Impl public
-  open language-syntax Sig using (_⊢_; first-order-data; unit; bool; base; _[×]_; _[+]_; list)
-  open SDSemiMod using (SelfDual; 𝟘; _⊕_; _≅sd_; ≅sd-refl; ≅sd-trans; ⊕-≅sd; S^_; S^-+) public
+  open language-syntax Sig using (_⊢_)
+  open SDSemiMod using (SelfDual; 𝟘; _⊕_) public
   open Setoid using (Carrier)
-  open Fam⟨𝒞⟩ using (fm)
-  open Fam⟨𝒞⟩.Obj using (fam)
-  open Model Impl using (⟦sort⟧)
-  open lists Fam⟨𝒟⟩.cat Fam⟨𝒟⟩-terminal Fam⟨𝒟⟩-products Fam⟨𝒟⟩-exponentials Fam⟨𝒟⟩.bigCoproducts
-    using (_^_)
-
-  -- Fam(U) is the functor H in the paper.
-  open FirstOrderConservativity
-    (λ {X} {Y} → SDSemiMod.U-full {X} {Y})
-    (λ {X} {Y} {f} {g} → SDSemiMod.U-faithful {X} {Y} {f} {g})
-    Sig Impl public
-
-  ty  : ∀ {τ} → first-order-data τ → (i : ⟦ τ ⟧ty .idx .Carrier) → SelfDual
-  pow : ∀ {τ} → first-order-data τ → (n : nat.ℕ) → (i : (⟦ τ ⟧ty ^ n) .idx .Carrier) → SelfDual
-
-  ty unit       _        = 𝟘
-  ty bool       _        = 𝟘
-  ty (base s)   i        = ⟦sort⟧ s .fam .fm i
-  ty (a [×] b)  (i , j)  = ty a i ⊕ ty b j
-  ty (a [+] b)  (inj₁ i) = ty a i
-  ty (a [+] b)  (inj₂ j) = ty b j
-  ty (list a)   (n , i)  = pow a n i
-
-  pow a nat.zero     _        = 𝟘
-  pow a (nat.succ n) (i , is) = ty a i ⊕ pow a n is
-
-  -- Given tower isomorphisms for the base sorts, every first-order fibre is isomorphic,
-  -- compatibly with the self-dualities, to a free semimodule S^n.
-  module FreeFibres
-    (base-free : ∀ s (i : ⟦ base s ⟧ty .idx .Carrier) →
-                 Σ[ n ∈ ℕ ] (ty (base s) i ≅sd (S^ n)))
-    where
-
-    ty-free : ∀ {τ} (a : first-order-data τ) (i : ⟦ τ ⟧ty .idx .Carrier) →
-              Σ[ n ∈ ℕ ] (ty a i ≅sd (S^ n))
-    pow-free : ∀ {τ} (a : first-order-data τ) (n : nat.ℕ) (i : (⟦ τ ⟧ty ^ n) .idx .Carrier) →
-               Σ[ m ∈ ℕ ] (pow a n i ≅sd (S^ m))
-
-    ty-free unit _ = 0 , ≅sd-refl
-    ty-free bool _ = 0 , ≅sd-refl
-    ty-free (base s) i = base-free s i
-    ty-free (a [×] b) (i , j) with ty-free a i | ty-free b j
-    ... | m , em | n , en = m + n , ≅sd-trans (⊕-≅sd em en) (S^-+ m n)
-    ty-free (a [+] b) (inj₁ i) = ty-free a i
-    ty-free (a [+] b) (inj₂ j) = ty-free b j
-    ty-free (list a) (n , i) = pow-free a n i
-
-    pow-free a nat.zero _ = 0 , ≅sd-refl
-    pow-free a (nat.succ n) (i , is) with ty-free a i | pow-free a n is
-    ... | m , em | k , ek = m + k , ≅sd-trans (⊕-≅sd em ek) (S^-+ m k)
 
   open SemiMod._⇒_ using (func)
 
diff --git a/agda/src/ho-model.agda b/agda/src/ho-model.agda
index ca2d3a54..ba089175 100644
--- a/agda/src/ho-model.agda
+++ b/agda/src/ho-model.agda
@@ -2,20 +2,37 @@
 
 module ho-model where
 
-open import Level using (Level; 0ℓ; suc)
-open import categories using (Category; HasProducts; HasTerminal; HasInitial; IsTerminal; IsInitial; op-coproducts→products; op-initial→terminal; HasCoproducts)
+open import Level using (Level; 0ℓ; suc; Lift; lift)
+open import categories
+  using (Category; HasProducts; HasTerminal; HasInitial; IsTerminal; IsInitial;
+         op-coproducts→products; op-initial→terminal; HasCoproducts;
+         HasStrongCoproducts; strong-coproducts→coproducts; ccc→strong-coproducts;
+         coproducts-canonical-iso)
+import polynomial-functor
 open import cmon-enriched
   using (CMonEnriched; product-cmon-enriched; op-cmon-enriched; Biproduct; biproducts→products)
-open import functor using (HasLimits; op-colimit; limits→limits')
+open import functor using (HasLimits; op-colimit; limits→limits'; Colimit; _∘F_; NatTrans; colambda-unique; constF; functor-preserve-iso)
+open import categories using (setoid→category)
 import fam
+import finite-coproducts-from-indexed
+import fam-mu-types.carrier
+import fam-mu-types
+import fam-stable-indexed
 import indexed-family
 
-open import functor using (Functor; Full; Faithful)
+open import functor using (Functor)
 open import Data.Product using (_,_; _×_; proj₁; proj₂)
-open import prop using (_,_)
+import Data.Nat
+import Data.Fin as Fin
+open Fin using (Fin; splitAt)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym) renaming (subst to ≡-subst)
+open import Data.Unit using (⊤; tt)
+open import prop using (_,_; ∃; ∃ₛ; Prf; ⟪_⟫)
 open import prop-setoid using (IsEquivalence; Setoid)
 open import finite-product-functor
   using (preserve-chosen-products; preserve-chosen-terminal)
+open import finite-coproduct-functor using (preserve-chosen-coproducts)
 
 open Functor
 
@@ -26,9 +43,7 @@ open Functor
 -- interpretation in Fam⟨𝒟⟩ from a model in Fam⟨𝒞⟩.
 
 open import fam-functor using (FamF)
-import language-fo-interpretation
 open import signature
-import lists
 import language-syntax
 
 module Interpretation
@@ -44,6 +59,12 @@ module Interpretation
   (F : Functor 𝒞 𝒟)
   (F-preserve-terminal : preserve-chosen-terminal F 𝒞-terminal 𝒟-terminal)
   (F-preserve-products : preserve-chosen-products F 𝒞-products (biproducts→products _ 𝒟-biproducts))
+  -- For the conservativity theorem: F is faithful and picks definability
+  -- witnesses uniformly (both hold when F is full and faithful)
+  (F-faithful : ∀ {a b} {g₁ g₂ : Category._⇒_ 𝒞 a b} → Category._≈_ 𝒟 (F .fmor g₁) (F .fmor g₂) → Category._≈_ 𝒞 g₁ g₂)
+  (F-def : ∀ {a b} (h : Category._⇒_ 𝒟 (F .fobj a) (F .fobj b)) →
+           Prf (∃ (Category._⇒_ 𝒞 a b) λ g → Category._≈_ 𝒟 (F .fmor g) h) →
+           ∃ₛ (Category._⇒_ 𝒞 a b) λ g → Category._≈_ 𝒟 (F .fmor g) h)
   where
 
   -- Target: Fam⟨𝒟⟩
@@ -63,8 +84,6 @@ module Interpretation
     using ()
     public
 
-  Fam⟨𝒟⟩-lists = lists.lists Fam⟨𝒟⟩.cat Fam⟨𝒟⟩-terminal Fam⟨𝒟⟩-products Fam⟨𝒟⟩-exponentials Fam⟨𝒟⟩.bigCoproducts
-
   Fam⟨𝒟⟩-bool =
     Fam⟨𝒟⟩-coproducts .HasCoproducts.coprod
       (Fam⟨𝒟⟩-terminal .HasTerminal.witness)
@@ -101,57 +120,261 @@ module Interpretation
     Fam⟨𝒟⟩.Mor-∘ (HasCoproducts.coprod-m Fam⟨𝒟⟩-coproducts (Fam⟨𝒟⟩-terminal .HasTerminal.to-terminal) (Fam⟨𝒟⟩-terminal .HasTerminal.to-terminal))
                   (Fam⟨F⟩-preserves-coproducts .Category.IsIso.inverse)
 
-  -- Interpretation
+  -- Direct interpretation of the language with general recursive types, via the
+  -- W-type μ-instance for Fam together with its initial-algebra laws.
+  Fam⟨𝒟⟩-strongCoproducts =
+    Fam⟨𝒟⟩.products.strongCoproducts (biproducts→products _ 𝒟-biproducts)
+
+  module Fam⟨𝒟⟩-μ =
+    fam-mu-types.carrier 0ℓ 0ℓ 𝒟-terminal (biproducts→products _ 𝒟-biproducts)
+
+  Fam⟨𝒟⟩-hasMu =
+    fam-mu-types.hasMu 0ℓ 0ℓ 𝒟-terminal (biproducts→products _ 𝒟-biproducts)
+
+  Fam⟨𝒟⟩-hasMuLaws =
+    fam-mu-types.hasMuLaws 0ℓ 0ℓ 𝒟-terminal (biproducts→products _ 𝒟-biproducts)
+
   module interp (Sig : Signature 0ℓ)
-                (Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig)
+                  (Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig)
      where
 
      open Fam⟨𝒟⟩.Mor public
      open Fam⟨𝒟⟩.Obj public
-     open language-syntax Sig using (_⊢_)
-     open indexed-family._⇒f_ using (transf)
-     open Setoid using (Carrier)
 
      open import language-interpretation Sig
        Fam⟨𝒟⟩.cat
        Fam⟨𝒟⟩-terminal
        Fam⟨𝒟⟩-products
-       Fam⟨𝒟⟩-coproducts
+       Fam⟨𝒟⟩-strongCoproducts
        Fam⟨𝒟⟩-exponentials
-       Fam⟨𝒟⟩-lists
+       Fam⟨𝒟⟩-hasMu
        (transport-model Sig Fam⟨F⟩ Fam⟨F⟩-preserves-terminal Fam⟨F⟩-preserves-products Fam⟨F⟩-preserves-bool Impl)
        public
 
+     open language-syntax Sig using (_⊢_; type; first-order; var; unit; base; _[+]_; _[×]_; μ)
+     open indexed-family._⇒f_ using (transf)
+     open Setoid using (Carrier)
+     open Model Impl using (⟦sort⟧)
+     open Fam⟨𝒞⟩ using (fm)
+     open Fam⟨𝒞⟩.Obj using (fam)
+
      -- The fibre map of a term at a given environment.
      mor : ∀ {Γ τ} (M : Γ ⊢ τ) (env : ⟦ Γ ⟧ctxt .idx .Carrier) → _
      mor M env = ⟦ M ⟧tm .famf .transf env
 
-  -- Conservativity at first-order types: when the first-order functor F is full and faithful, so
-  -- is Fam⟨F⟩, and the interpretation of a term of first-order type comes from Fam⟨𝒞⟩.
-  module FirstOrderConservativity
-      (F-full : Full F) (F-faithful : Faithful F)
-      (Sig : Signature 0ℓ)
-      (Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig)
-    where
-
-    private
-      module LFI = language-fo-interpretation Sig
-        Fam⟨𝒞⟩.cat Fam⟨𝒞⟩-terminal Fam⟨𝒞⟩-products Fam⟨𝒞⟩-coproducts
-        Fam⟨𝒟⟩.cat Fam⟨𝒟⟩-terminal Fam⟨𝒟⟩-products Fam⟨𝒟⟩-coproducts Fam⟨𝒟⟩-exponentials Fam⟨𝒟⟩-lists
-        Fam⟨F⟩ Fam⟨F⟩-preserves-terminal
-        (λ {X} {Y} → Fam⟨F⟩-preserves-products {X} {Y}) Fam⟨F⟩-preserves-coproducts
-        Impl
-
-    first-order-conservativity = LFI.first-order-conservativity
-      (fam-functor.FamF-full 0ℓ 0ℓ F
-        (λ {x} {y} → F-full {x} {y})
-        (λ {x} {y} {f} {g} → F-faithful {x} {y} {f} {g}))
+     -- Approximation structure on the fibres of first-order types: an object of
+     -- 𝒞 over each fibre of the interpretation, with 𝒞's terminal object at unit
+     -- and product at pairs. At μ the fibres are indexed by W-trees, so the
+     -- object at each fibre is computed by the same recursion that computes the
+     -- fibre, from objects given at the polynomial's const leaves.
+     private
+       Fib : Set o
+       Fib = Category.obj 𝒞
+
+       𝟘 : Fib
+       𝟘 = HasTerminal.witness 𝒞-terminal
+
+       _⊕_ : Fib → Fib → Fib
+       _⊕_ = HasProducts.prod 𝒞-products
+
+     module Pm = Fam⟨𝒟⟩-μ
+     module T0 = Pm.Tree {n = 0} (λ ())
+
+     -- For each const leaf of an index-erased polynomial, an assignment of a
+     -- fibre object to each element of its index set. This is the only input
+     -- needed to determine a fibre object at every element of the polynomial's
+     -- μ-type.
+     FibAlg : ∀ {k} → Pm.Sh.Poly k → Set o
+     FibAlg (Pm.const S) = (x : S .Carrier) → Fib
+     FibAlg (Pm.var j)   = Lift o ⊤
+     FibAlg (P Pm.+ Q)   = FibAlg P × FibAlg Q
+     FibAlg (P Pm.× Q)   = FibAlg P × FibAlg Q
+     FibAlg (Pm.μ Q)     = FibAlg Q
+
+     mutual
+       SortAlg : Pm.Sort 0 → Set o
+       SortAlg (Pm.mkSort Q ρ) = FibAlg Q × (∀ i → CtxAlg (ρ i))
+
+       CtxAlg : Fin 0 ⊎ Pm.Sort 0 → Set o
+       CtxAlg (inj₁ ())
+       CtxAlg (inj₂ s) = SortAlg s
+
+     extAlg : ∀ {k} {ρ : Fin k → Fin 0 ⊎ Pm.Sort 0} {v} →
+              (∀ i → CtxAlg (ρ i)) → CtxAlg v → ∀ i → CtxAlg (Pm.extend ρ v i)
+     extAlg ca va Fin.zero    = va
+     extAlg ca va (Fin.suc i) = ca i
+
+     -- Assign a fibre object to each element of a μ-type, by the same recursion
+     -- that computes the fibre.
+     mutual
+       mu : ∀ {k} {Q : Pm.Sh.Poly (Data.Nat.suc k)} {ρ} → SortAlg (Pm.mkSort Q ρ) → T0.W Q ρ → Fib
+       mu {Q = Q} {ρ = ρ} (fa , ca) (T0.sup x) =
+         mu-shape Q (Pm.extend ρ (inj₂ (Pm.mkSort Q ρ))) fa (extAlg ca (fa , ca)) x
+
+       mu-shape : ∀ {j} (Q : Pm.Sh.Poly j) (η : Fin j → Fin 0 ⊎ Pm.Sort 0) →
+                    FibAlg Q → (∀ i → CtxAlg (η i)) → T0.⟦_⟧shape Q η → Fib
+       mu-shape (Pm.const A) η fa ca x = fa x
+       mu-shape (Pm.var j)   η fa ca x = mu-el (η j) (ca j) x
+       mu-shape (P Pm.+ Q) η (fp , fq) ca (inj₁ x) = mu-shape P η fp ca x
+       mu-shape (P Pm.+ Q) η (fp , fq) ca (inj₂ y) = mu-shape Q η fq ca y
+       mu-shape (P Pm.× Q) η (fp , fq) ca (x , y) = mu-shape P η fp ca x ⊕ mu-shape Q η fq ca y
+       mu-shape (Pm.μ Q)   η fa ca x = mu (fa , ca) x
+
+       mu-el : (r : Fin 0 ⊎ Pm.Sort 0) → CtxAlg r → T0.El r → Fib
+       mu-el (inj₁ ()) ca x
+       mu-el (inj₂ (Pm.mkSort Q ρ)) sa x = mu sa x
+
+     -- Fibre-object data for the polynomial translation of a first-order type.
+     polyAlg : ∀ {Δ n} {δ : Fin Δ → Fam⟨𝒟⟩.Obj} {τ : type (n Data.Nat.+ Δ)} → first-order τ →
+               (∀ j (x : δ j .idx .Carrier) → Fib) → FibAlg Pm.∣ as-poly {Δ} {n} τ δ ∣
+     polyAlg {n = n} (var i) δᵃ with splitAt n i
+     ... | inj₁ k = lift tt
+     ... | inj₂ j = δᵃ j
+     polyAlg unit      δᵃ = λ x → 𝟘
+     polyAlg (base s)  δᵃ = λ i → ⟦sort⟧ s .fam .fm i
+     polyAlg (f [+] g) δᵃ = polyAlg f δᵃ , polyAlg g δᵃ
+     polyAlg (f [×] g) δᵃ = polyAlg f δᵃ , polyAlg g δᵃ
+     polyAlg (μ f)     δᵃ = polyAlg f δᵃ
+
+     -- Fibre object at each element of a first-order type's interpretation.
+     ty : ∀ {Δ} {δ : Fin Δ → Fam⟨𝒟⟩.Obj} {τ : type Δ} → first-order τ →
+          (∀ j (x : δ j .idx .Carrier) → Fib) →
+          (i : ⟦ τ ⟧ty δ .idx .Carrier) → Fib
+     ty (var i)   δᵃ x        = δᵃ i x
+     ty unit      δᵃ x        = 𝟘
+     ty (base s)  δᵃ i        = ⟦sort⟧ s .fam .fm i
+     ty (f [+] g) δᵃ (inj₁ i) = ty f δᵃ i
+     ty (f [+] g) δᵃ (inj₂ j) = ty g δᵃ j
+     ty (f [×] g) δᵃ (i , j)  = ty f δᵃ i ⊕ ty g δᵃ j
+     ty (μ f)     δᵃ t        = mu (polyAlg f δᵃ , (λ ())) t
+
+     -- Closed types have no environment to pin down.
+     ty₀ : ∀ {τ : type 0} → first-order τ → (i : ⟦ τ ⟧ty (λ ()) .idx .Carrier) → Fib
+     ty₀ fo = ty {Δ = 0} {δ = λ ()} fo (λ ())
 
   module Conservativity where
-    open import monad using (IdentityMonad; preserve-identity-monad; Identity-monad-preserve-coproducts)
+    open import monad using (Monad; IdentityMonad; preserve-identity-monad)
+    open import functor using (Id; Colimit; _∘F_; NatTrans)
+    open import prop using (∃ₛ)
+    open fam.CategoryOfFamilies.Obj
+    open fam.CategoryOfFamilies.Mor
+    open fam.CategoryOfFamilies._≃_
+    open indexed-family._⇒f_
+    open indexed-family._≃f_
+    open indexed-family.Fam
+    open prop-setoid._⇒_
+    open prop-setoid._≃m_
+    private module 𝒞C = Category 𝒞
+
+    𝒞istable = fam-stable-indexed.fam-stable-indexed {os = 0ℓ} 𝒞
+
+    private M = Monad.funct (IdentityMonad Fam⟨𝒞⟩.cat)
+
+    -- The identity monad functor preserves set-indexed coproducts: Id ∘F D and
+    -- D have the same action, so the two coproducts have identical data.
+    FM-DC : ∀ (S : Setoid 0ℓ 0ℓ) (D : functor.Functor (categories.setoid→category S) Fam⟨𝒞⟩.cat) →
+            ∃ₛ (Category.Iso Fam⟨𝒞⟩.cat
+                  (Colimit.apex (Fam⟨𝒞⟩.bigCoproducts S (M ∘F D)))
+                  (M .Functor.fobj (Colimit.apex (Fam⟨𝒞⟩.bigCoproducts S D))))
+               (λ i → ∀ s → Category._≈_ Fam⟨𝒞⟩.cat
+                             (Category._∘_ Fam⟨𝒞⟩.cat (Category.Iso.fwd i)
+                                (Colimit.cocone (Fam⟨𝒞⟩.bigCoproducts S (M ∘F D)) .NatTrans.transf s))
+                             (M .Functor.fmor (Colimit.cocone (Fam⟨𝒞⟩.bigCoproducts S D) .NatTrans.transf s)))
+    FM-DC S D = theIso , compat
+      where
+        Lo = Colimit.apex (Fam⟨𝒞⟩.bigCoproducts S (M ∘F D))
+        Ro = M .Functor.fobj (Colimit.apex (Fam⟨𝒞⟩.bigCoproducts S D))
+
+        fwd : Category._⇒_ Fam⟨𝒞⟩.cat Lo Ro
+        fwd .idxf .func p = p
+        fwd .idxf .func-resp-≈ e = e
+        fwd .famf .transf p = 𝒞C.id _
+        fwd .famf .natural e = 𝒞C.≈-trans 𝒞C.id-left (𝒞C.≈-sym 𝒞C.id-right)
+
+        bwd : Category._⇒_ Fam⟨𝒞⟩.cat Ro Lo
+        bwd .idxf .func p = p
+        bwd .idxf .func-resp-≈ e = e
+        bwd .famf .transf p = 𝒞C.id _
+        bwd .famf .natural e = 𝒞C.≈-trans 𝒞C.id-left (𝒞C.≈-sym 𝒞C.id-right)
+
+        theIso : Category.Iso Fam⟨𝒞⟩.cat Lo Ro
+        theIso .Category.Iso.fwd = fwd
+        theIso .Category.Iso.bwd = bwd
+        theIso .Category.Iso.fwd∘bwd≈id .idxf-eq .func-eq e = e
+        theIso .Category.Iso.fwd∘bwd≈id .famf-eq .transf-eq {p} =
+          𝒞C.≈-trans (𝒞C.∘-cong (Ro .fam .refl*) (𝒞C.≈-trans 𝒞C.id-left 𝒞C.id-left)) 𝒞C.id-left
+        theIso .Category.Iso.bwd∘fwd≈id .idxf-eq .func-eq e = e
+        theIso .Category.Iso.bwd∘fwd≈id .famf-eq .transf-eq {p} =
+          𝒞C.≈-trans (𝒞C.∘-cong (Lo .fam .refl*) (𝒞C.≈-trans 𝒞C.id-left 𝒞C.id-left)) 𝒞C.id-left
+
+        compat : ∀ s → Category._≈_ Fam⟨𝒞⟩.cat
+                        (Category._∘_ Fam⟨𝒞⟩.cat fwd (Colimit.cocone (Fam⟨𝒞⟩.bigCoproducts S (M ∘F D)) .NatTrans.transf s))
+                        (M .Functor.fmor (Colimit.cocone (Fam⟨𝒞⟩.bigCoproducts S D) .NatTrans.transf s))
+        compat s .idxf-eq .func-eq e =
+          Colimit.cocone (Fam⟨𝒞⟩.bigCoproducts S D) .NatTrans.transf s .idxf .func-resp-≈ e
+        compat s .famf-eq .transf-eq {d} =
+          𝒞C.≈-trans (𝒞C.∘-cong (Ro .fam .refl*) (𝒞C.≈-trans 𝒞C.id-left 𝒞C.id-left)) 𝒞C.id-left
+
     open import conservativity
-      Fam⟨𝒞⟩.cat Fam⟨𝒞⟩-terminal Fam⟨𝒞⟩-products Fam⟨𝒞⟩-coproducts Fam⟨𝒞⟩.fam-stable (IdentityMonad Fam⟨𝒞⟩.cat)
-      Fam⟨𝒟⟩.cat Fam⟨𝒟⟩-terminal Fam⟨𝒟⟩-products Fam⟨𝒟⟩-coproducts Fam⟨𝒟⟩-exponentials (IdentityMonad Fam⟨𝒟⟩.cat) Fam⟨𝒟⟩.bigCoproducts
-      Fam⟨F⟩ Fam⟨F⟩-preserves-terminal Fam⟨F⟩-preserves-products Fam⟨F⟩-preserves-coproducts
-      (preserve-identity-monad Fam⟨F⟩) (Identity-monad-preserve-coproducts Fam⟨𝒞⟩-coproducts)
+      Fam⟨𝒞⟩.cat Fam⟨𝒞⟩-terminal Fam⟨𝒞⟩-products (IdentityMonad Fam⟨𝒞⟩.cat)
+      Fam⟨𝒞⟩.bigCoproducts 𝒞istable
+      Fam⟨𝒟⟩.cat Fam⟨𝒟⟩-terminal Fam⟨𝒟⟩-products Fam⟨𝒟⟩-exponentials (IdentityMonad Fam⟨𝒟⟩.cat) Fam⟨𝒟⟩.bigCoproducts
+      Fam⟨F⟩ Fam⟨F⟩-preserves-terminal Fam⟨F⟩-preserves-products
+      (preserve-identity-monad Fam⟨F⟩)
+      FM-DC
+      (fam-functor.FamF-preserve-bigCopro 0ℓ 0ℓ F)
+      (fam-functor.FamF-faithful 0ℓ 0ℓ F F-faithful)
+      (fam-functor.FamF-def 0ℓ 0ℓ F F-def F-faithful)
       public
+
+    Fam⟨𝒞⟩-strongCoproducts : HasStrongCoproducts Fam⟨𝒞⟩.cat Fam⟨𝒞⟩-products
+    Fam⟨𝒞⟩-strongCoproducts = Fam⟨𝒞⟩.products.strongCoproducts 𝒞-products
+
+    Fam⟨𝒞⟩-hasMu : polynomial-functor.Interp.HasMu Fam⟨𝒞⟩-terminal Fam⟨𝒞⟩-products Fam⟨𝒞⟩-strongCoproducts
+    Fam⟨𝒞⟩-hasMu = fam-mu-types.hasMu 0ℓ 0ℓ 𝒞-terminal 𝒞-products
+
+    -- The embedding preserves the coproducts derived from the strong coproducts
+    -- on either side: the canonical maps differ from those for the chosen
+    -- coproducts only in the copairing, which is unique.
+    GF-preserve-strong-coproducts :
+      preserve-chosen-coproducts GF
+        (strong-coproducts→coproducts Fam⟨𝒞⟩-terminal Fam⟨𝒞⟩-strongCoproducts)
+        (strong-coproducts→coproducts GlPE.terminal (ccc→strong-coproducts GlCP.coproducts GlPE.exponentials))
+    GF-preserve-strong-coproducts {x} {y} = Glued.IsIso-cong comp≈n comp-isIso
+      where
+        open Glued.Iso
+        open Glued.IsIso
+        module CP' = HasCoproducts
+          (strong-coproducts→coproducts GlPE.terminal (ccc→strong-coproducts GlCP.coproducts GlPE.exponentials))
+        module CPC = HasCoproducts Fam⟨𝒞⟩-coproducts
+        module B-derive = finite-coproducts-from-indexed.derive Fam⟨𝒞⟩.bigCoproducts
+        module B = HasCoproducts B-derive.coproducts-from-indexed
+
+        -- The goal's chosen coproduct differs from the one conservativity uses
+        -- (the two-element instance of Fam⟨𝒞⟩'s set-indexed coproducts) only by
+        -- the canonical iso, which GF preserves.
+        ρ = coproducts-canonical-iso Fam⟨𝒞⟩-coproducts B-derive.coproducts-from-indexed x y
+
+        theIso : Glued.Iso (GlCPM.coprod (GF .fobj x) (GF .fobj y)) (GF .fobj (CPC.coprod x y))
+        theIso = Glued.Iso-trans (Glued.IsIso→Iso GF-preserve-coproducts)
+                                 (Glued.Iso-sym (functor-preserve-iso GF ρ))
+
+        comp-isIso : Glued.IsIso (theIso .fwd)
+        comp-isIso .inverse = theIso .bwd
+        comp-isIso .f∘inverse≈id = theIso .fwd∘bwd≈id
+        comp-isIso .inverse∘f≈id = theIso .bwd∘fwd≈id
+
+        n = CP'.copair (GF .fmor (CPC.in₁ {x} {y})) (GF .fmor (CPC.in₂ {x} {y}))
+
+        comp≈n : theIso .fwd Glued.≈ n
+        comp≈n = Glued.≈-trans (Glued.≈-sym (CP'.copair-ext (theIso .fwd)))
+                   (CP'.copair-cong onIn₁ onIn₂)
+          where
+            onIn₁ : (theIso .fwd Glued.∘ CP'.in₁) Glued.≈ GF .fmor (CPC.in₁ {x} {y})
+            onIn₁ = Glued.≈-trans (Glued.assoc _ _ _)
+                      (Glued.≈-trans (Glued.∘-cong Glued.≈-refl (GlCPM.copair-in₁ _ _))
+                        (Glued.≈-trans (Glued.≈-sym (GF .fmor-comp _ _)) (GF .fmor-cong (B.copair-in₁ _ _))))
+            onIn₂ : (theIso .fwd Glued.∘ CP'.in₂) Glued.≈ GF .fmor (CPC.in₂ {x} {y})
+            onIn₂ = Glued.≈-trans (Glued.assoc _ _ _)
+                      (Glued.≈-trans (Glued.∘-cong Glued.≈-refl (GlCPM.copair-in₂ _ _))
+                        (Glued.≈-trans (Glued.≈-sym (GF .fmor-comp _ _)) (GF .fmor-cong (B.copair-in₂ _ _))))
diff --git a/agda/src/indexed-family.agda b/agda/src/indexed-family.agda
index 29fd8739..283ef4fb 100644
--- a/agda/src/indexed-family.agda
+++ b/agda/src/indexed-family.agda
@@ -427,6 +427,37 @@ record HasSetoidProducts {o m e} os es (𝒞 : Category o m e) : Set (o ⊔ suc
 
 open import functor
 
+-- A family is a functor from the setoid, viewed as a category.
+module _ {o m e os es} {𝒞 : Category o m e} where
+
+  private
+    module 𝒞C = Category 𝒞
+
+  open Functor
+  open Fam
+
+  fam→functor : ∀ {A : Setoid os es} → Fam A 𝒞 → Functor (setoid→category A) 𝒞
+  fam→functor F .fobj = F .fm
+  fam→functor F .fmor ⟪ eq ⟫ = F .subst eq
+  fam→functor F .fmor-cong _ = 𝒞C.≈-refl
+  fam→functor F .fmor-id = F .refl*
+  fam→functor F .fmor-comp f g = F .trans* _ _
+
+  functor→fam : ∀ {A : Setoid os es} → Functor (setoid→category A) 𝒞 → Fam A 𝒞
+  functor→fam D .fm = D .fobj
+  functor→fam D .subst eq = D .fmor ⟪ eq ⟫
+  functor→fam D .refl* = D .fmor-id
+  functor→fam D .trans* e₁ e₂ = D .fmor-comp ⟪ e₁ ⟫ ⟪ e₂ ⟫
+
+  fam→functor-eta : ∀ {A : Setoid os es} (D : Functor (setoid→category A) 𝒞) →
+                    NatIso D (fam→functor (functor→fam D))
+  fam→functor-eta D .NatIso.transform .NatTrans.transf x = 𝒞C.id _
+  fam→functor-eta D .NatIso.transform .NatTrans.natural ⟪ p ⟫ =
+    𝒞C.≈-trans 𝒞C.id-right (𝒞C.≈-sym 𝒞C.id-left)
+  fam→functor-eta D .NatIso.transf-iso x .Category.IsIso.inverse = 𝒞C.id _
+  fam→functor-eta D .NatIso.transf-iso x .Category.IsIso.f∘inverse≈id = 𝒞C.id-left
+  fam→functor-eta D .NatIso.transf-iso x .Category.IsIso.inverse∘f≈id = 𝒞C.id-left
+
 -- If a category has all discrete limits, then it has all setoid
 -- products (almost by definition).
 module _ {o m e} os es (𝒞 : Category o m e)
@@ -445,13 +476,6 @@ module _ {o m e} os es (𝒞 : Category o m e)
 
   open IsEquivalence
 
-  fam→functor : ∀ {A : Setoid os es} → Fam A 𝒞 → Functor (setoid→category A) 𝒞
-  fam→functor F .fobj = F .fm
-  fam→functor F .fmor ⟪ eq ⟫ = F .subst eq
-  fam→functor F .fmor-cong _ = 𝒞.≈-refl
-  fam→functor F .fmor-id = F .refl*
-  fam→functor F .fmor-comp f g = F .trans* _ _
-
   -- FIXME: this is a bit messy
 
   hasSetoidProducts : HasSetoidProducts os es 𝒞
diff --git a/agda/src/join-semilattice.agda b/agda/src/join-semilattice.agda
index 62faeba1..9cf6858f 100644
--- a/agda/src/join-semilattice.agda
+++ b/agda/src/join-semilattice.agda
@@ -556,6 +556,40 @@ module _ where
     A .≤-refl , B .≤-refl
   L-costrength {A} .⊥-preserving = A .≤-refl , tt
 
+  -- Naturality of L-costrength: commutes with the bifunctorial action of L
+  -- combined with the product on the first arg.
+  L-costrength-natural : ∀ {A₁ A₂ B₁ B₂}
+                         {X₁ : JoinSemilattice A₁} {X₂ : JoinSemilattice A₂}
+                         {Y₁ : JoinSemilattice B₁} {Y₂ : JoinSemilattice B₂}
+                         (f : X₁ => X₂) (g : Y₁ => Y₂) →
+                         (⟨ f ∘ project₁ , L-map g ∘ project₂ ⟩ ∘ L-costrength {X = X₁} {Y = Y₁}) ≃m
+                         (L-costrength {X = X₂} {Y = Y₂} ∘ L-map ⟨ f ∘ project₁ , g ∘ project₂ ⟩)
+  L-costrength-natural {X₂ = X₂} f g .eqfunc .eqfun bottom .proj₁ =
+    f .⊥-preserving , tt
+  L-costrength-natural {X₂ = X₂} f g .eqfunc .eqfun bottom .proj₂ =
+    X₂ .⊥-isBottom .IsBottom.≤-bottom , tt
+  L-costrength-natural {A₂ = A₂} {B₂ = B₂} f g .eqfunc .eqfun < x , y > =
+    (A₂ × B₂) .≃-refl
+
+  L-costrength-p₂ : ∀ {A B}{X : JoinSemilattice A}{Y : JoinSemilattice B} →
+                    (project₂ {X = X} {Y = L Y} ∘ L-costrength {X = X} {Y = Y}) ≃m L-map (project₂ {X = X} {Y = Y})
+  L-costrength-p₂ .eqfunc .eqfun bottom = tt , tt
+  L-costrength-p₂ {B = B} .eqfunc .eqfun < x , y > = B .≃-refl
+
+  -- Associativity coherence dual to meet-semilattice.L-strength-assoc: L-costrength commutes
+  -- with the codiagonal [ inject₁ , id ].
+  L-costrength-assoc : ∀ {A B}{X : JoinSemilattice A}{Y : JoinSemilattice B} →
+                       ([ inject₁ {X = X} {Y = L Y} , L-costrength {X = X} {Y = Y} ] ∘ L-costrength {X = X} {Y = X ⊕ Y}) ≃m
+                       (L-costrength {X = X} {Y = Y} ∘ L-map [ inject₁ {X = X} {Y = Y} , id {X = X ⊕ Y} ])
+  L-costrength-assoc {A = A} {B = B} {X = X} {Y = Y} .eqfunc .eqfun bottom .proj₁ =
+    X .∨-isJoin .IsJoin.[_,_] (A .≤-refl) (A .≤-refl) , tt
+  L-costrength-assoc {A = A} {B = B} {X = X} {Y = Y} .eqfunc .eqfun bottom .proj₂ =
+    X .∨-isJoin .IsJoin.inl , tt
+  L-costrength-assoc {A = A} {B = B} {X = X} {Y = Y} .eqfunc .eqfun < x , (x' , y) > .proj₁ =
+    A .≤-refl , Y .∨-isJoin .IsJoin.inr
+  L-costrength-assoc {A = A} {B = B} {X = X} {Y = Y} .eqfunc .eqfun < x , (x' , y) > .proj₂ =
+    A .≤-refl , Y .∨-isJoin .IsJoin.[_,_] (Y .⊥-isBottom .IsBottom.≤-bottom) (B .≤-refl)
+
 {-
   L-coassoc : ∀ {A}{X : JoinSemilattice A} → (L-map L-dup ∘ L-dup) ≃m (L-dup ∘ L-dup {X = X})
   L-coassoc .eqfunc .eqfun bottom .proj₁ = tt
diff --git a/agda/src/language-fo-interpretation.agda b/agda/src/language-fo-interpretation.agda
index b1329ecc..5b730a9b 100644
--- a/agda/src/language-fo-interpretation.agda
+++ b/agda/src/language-fo-interpretation.agda
@@ -1,13 +1,16 @@
 {-# OPTIONS --postfix-projections --prop --safe #-}
 
-open import categories using (Category; HasTerminal; HasProducts; HasCoproducts; HasExponentials; HasBooleans; coproducts+exp→booleans; HasLists)
-open import functor using (Functor; Full)
-open import prop using (∃ₛ)
-open import finite-product-functor
-  using (preserve-chosen-products; module preserve-chosen-products-consequences)
-open import finite-coproduct-functor
-  using (preserve-chosen-coproducts; module preserve-chosen-coproducts-consequences)
-
+open import Data.Nat using (ℕ; suc; _+_)
+import Data.Fin as Fin
+open Fin using (Fin; splitAt)
+open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_])
+open import categories
+  using (Category; HasTerminal; HasProducts; HasCoproducts; HasStrongCoproducts;
+         strong-coproducts→coproducts; HasExponentials)
+open import functor using (Functor)
+open import finite-product-functor using (preserve-chosen-products)
+open import finite-coproduct-functor using (preserve-chosen-coproducts)
+import polynomial-functor
 import language-syntax
 open import signature
 
@@ -15,80 +18,112 @@ open Functor
 
 module language-fo-interpretation {ℓ} (Sig : Signature ℓ)
   {o₁ m₁ e₁ o₂ m₂ e₂}
-  (𝒞 : Category o₁ m₁ e₁) (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞CP : HasCoproducts 𝒞)
-  (𝒟 : Category o₂ m₂ e₂) (𝒟T : HasTerminal 𝒟) (𝒟P : HasProducts 𝒟) (𝒟CP : HasCoproducts 𝒟) (𝒟E : HasExponentials 𝒟 𝒟P) (𝒟L : HasLists 𝒟 𝒟T 𝒟P)
+  (𝒞 : Category o₁ m₁ e₁) (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞SC : HasStrongCoproducts 𝒞 𝒞P)
+  (𝒞Mu : polynomial-functor.Interp.HasMu 𝒞T 𝒞P 𝒞SC)
+  (𝒟 : Category o₂ m₂ e₂) (𝒟T : HasTerminal 𝒟) (𝒟P : HasProducts 𝒟) (𝒟SC : HasStrongCoproducts 𝒟 𝒟P)
+  (𝒟E : HasExponentials 𝒟 𝒟P)
+  (𝒟Mu : polynomial-functor.Interp.HasMu 𝒟T 𝒟P 𝒟SC)
+  (𝒟MuLaws : polynomial-functor.Interp.HasMuLaws 𝒟T 𝒟P 𝒟SC 𝒟Mu)
   (F : Functor 𝒞 𝒟)
   (FT : Category.IsIso 𝒟 (HasTerminal.to-terminal 𝒟T {F .fobj (𝒞T .HasTerminal.witness)}))
   (FP : preserve-chosen-products F 𝒞P 𝒟P)
-  (FC : preserve-chosen-coproducts F 𝒞CP 𝒟CP)
-  (𝒞-Sig-model : Model PFPC[ 𝒞 , 𝒞T , 𝒞P , 𝒞CP .HasCoproducts.coprod (𝒞T .HasTerminal.witness) (𝒞T .HasTerminal.witness) ] Sig)
+  (FC : preserve-chosen-coproducts F (strong-coproducts→coproducts 𝒞T 𝒞SC) (strong-coproducts→coproducts 𝒟T 𝒟SC))
+  (Fμ : polynomial-functor.Preserves-μ 𝒞T 𝒞P 𝒞SC 𝒟T 𝒟P 𝒟SC 𝒞Mu 𝒟Mu F)
+  (𝒞-Sig-model : Model PFPC[ 𝒞 , 𝒞T , 𝒞P ,
+                  HasCoproducts.coprod (strong-coproducts→coproducts 𝒞T 𝒞SC)
+                    (𝒞T .HasTerminal.witness) (𝒞T .HasTerminal.witness) ] Sig)
   where
 
 open language-syntax Sig
+open polynomial-functor using (Poly; Poly-map; extend)
 
+-- Interpretation of the first-order types in 𝒞, with μ-types via the
+-- polynomial translation of the first-order witness.
 module _ where
   open Category 𝒞
   open HasTerminal 𝒞T renaming (witness to 𝟙)
-  open HasProducts 𝒞P renaming (prod to _×_)
-  open HasCoproducts 𝒞CP renaming (coprod to _+_)
-
-  𝒞⟦_⟧ty : ∀ {τ} → first-order τ → obj
-  𝒞⟦ unit ⟧ty = 𝟙
-  𝒞⟦ bool ⟧ty = 𝟙 + 𝟙
-  𝒞⟦ base s ⟧ty = 𝒞-Sig-model .Model.⟦sort⟧ s
-  𝒞⟦ τ₁ [×] τ₂ ⟧ty = 𝒞⟦ τ₁ ⟧ty × 𝒞⟦ τ₂ ⟧ty
-  𝒞⟦ τ₁ [+] τ₂ ⟧ty = 𝒞⟦ τ₁ ⟧ty + 𝒞⟦ τ₂ ⟧ty
+  open HasProducts 𝒞P
+  open HasCoproducts (strong-coproducts→coproducts 𝒞T 𝒞SC)
+
+  module CMu = polynomial-functor.Interp.HasMu 𝒞Mu
+
+  fo-as-poly : ∀ {Δ n} {τ : type (n + Δ)} → first-order τ → (Fin Δ → obj) → Poly 𝒞 n
+  fo-as-poly {n = n} (var i)   δ = [ Poly.var , (λ j → Poly.const (δ j)) ] (splitAt n i)
+  fo-as-poly unit              δ = Poly.const 𝟙
+  fo-as-poly (base s)          δ = Poly.const (𝒞-Sig-model .Model.⟦sort⟧ s)
+  fo-as-poly (fo₁ [+] fo₂)     δ = fo-as-poly fo₁ δ Poly.+ fo-as-poly fo₂ δ
+  fo-as-poly (fo₁ [×] fo₂)     δ = fo-as-poly fo₁ δ Poly.× fo-as-poly fo₂ δ
+  fo-as-poly (μ fo)            δ = Poly.μ (fo-as-poly fo δ)
+
+  𝒞⟦_⟧ty : ∀ {Δ} {τ : type Δ} → first-order τ → (Fin Δ → obj) → obj
+  𝒞⟦ var i ⟧ty       δ = δ i
+  𝒞⟦ unit ⟧ty        δ = 𝟙
+  𝒞⟦ base s ⟧ty      δ = 𝒞-Sig-model .Model.⟦sort⟧ s
+  𝒞⟦ fo₁ [×] fo₂ ⟧ty δ = prod (𝒞⟦ fo₁ ⟧ty δ) (𝒞⟦ fo₂ ⟧ty δ)
+  𝒞⟦ fo₁ [+] fo₂ ⟧ty δ = coprod (𝒞⟦ fo₁ ⟧ty δ) (𝒞⟦ fo₂ ⟧ty δ)
+  𝒞⟦ μ fo ⟧ty        δ = CMu.μ-obj (fo-as-poly {n = 1} fo δ) (λ ())
 
   𝒞⟦_⟧ctxt : ∀ {Γ} → first-order-ctxt Γ → obj
-  𝒞⟦ emp ⟧ctxt = 𝟙
-  𝒞⟦ Γ , τ ⟧ctxt = 𝒞⟦ Γ ⟧ctxt × 𝒞⟦ τ ⟧ty
+  𝒞⟦ emp ⟧ctxt    = 𝟙
+  𝒞⟦ Γ , τ ⟧ctxt = prod 𝒞⟦ Γ ⟧ctxt (𝒞⟦ τ ⟧ty (λ ()))
 
 private
-  module 𝒞CP = HasCoproducts 𝒞CP
   module 𝒟 = Category 𝒟
-  module 𝒟CP = HasCoproducts 𝒟CP
-  module 𝒟P = HasProducts 𝒟P
+  module 𝒞CPm = HasCoproducts (strong-coproducts→coproducts 𝒞T 𝒞SC)
+  module 𝒟CPm = HasCoproducts (strong-coproducts→coproducts 𝒟T 𝒟SC)
+  module 𝒟Pm = HasProducts 𝒟P
+  module PM = polynomial-functor.MuIso 𝒟T 𝒟P 𝒟SC 𝒟Mu 𝒟MuLaws
 
-𝒞Bool = 𝒞CP.coprod (𝒞T .HasTerminal.witness) (𝒞T .HasTerminal.witness)
-𝒟Bool = 𝒟CP.coprod (𝒟T .HasTerminal.witness) (𝒟T .HasTerminal.witness)
+𝒞Bool = 𝒞CPm.coprod (𝒞T .HasTerminal.witness) (𝒞T .HasTerminal.witness)
+𝒟Bool = 𝒟CPm.coprod (𝒟T .HasTerminal.witness) (𝒟T .HasTerminal.witness)
 
 Bool-iso : 𝒟.Iso (F .fobj 𝒞Bool) 𝒟Bool
 Bool-iso =
   𝒟.Iso-trans (𝒟.Iso-sym (𝒟.IsIso→Iso FC))
-              (𝒟CP.coproduct-preserve-iso (𝒟.IsIso→Iso FT) (𝒟.IsIso→Iso FT))
+              (𝒟CPm.coproduct-preserve-iso (𝒟.IsIso→Iso FT) (𝒟.IsIso→Iso FT))
 
 𝒟-Sig-model : Model PFPC[ 𝒟 , 𝒟T , 𝒟P , 𝒟Bool ] Sig
 𝒟-Sig-model = transport-model Sig F FT FP (Bool-iso .𝒟.Iso.fwd) 𝒞-Sig-model
 
-open import language-interpretation Sig 𝒟 𝒟T 𝒟P 𝒟CP 𝒟E 𝒟L 𝒟-Sig-model
-  renaming (⟦_⟧ty to 𝒟⟦_⟧ty; ⟦_⟧ctxt to 𝒟⟦_⟧ctxt; ⟦_⟧tm to 𝒟⟦_⟧tm) using ()
+open import language-interpretation Sig 𝒟 𝒟T 𝒟P 𝒟SC 𝒟E 𝒟Mu 𝒟-Sig-model
+  renaming (⟦_⟧ty to 𝒟⟦_⟧ty; ⟦_⟧ctxt to 𝒟⟦_⟧ctxt; ⟦_⟧tm to 𝒟⟦_⟧tm; as-poly to 𝒟-as-poly)
+  using ()
   public
 
-⟦_⟧-iso : ∀ {τ} (τ-fo : first-order τ) → 𝒟.Iso (F .fobj 𝒞⟦ τ-fo ⟧ty) 𝒟⟦ τ ⟧ty
-⟦ unit ⟧-iso      = 𝒟.IsIso→Iso FT
-⟦ bool ⟧-iso      = Bool-iso
-⟦ base s ⟧-iso    = 𝒟.Iso-refl
-⟦ τ₁ [×] τ₂ ⟧-iso = 𝒟.Iso-trans (𝒟.IsIso→Iso FP) (𝒟P.product-preserves-iso ⟦ τ₁ ⟧-iso ⟦ τ₂ ⟧-iso)
-⟦ τ₁ [+] τ₂ ⟧-iso = 𝒟.Iso-trans (𝒟.Iso-sym (𝒟.IsIso→Iso FC)) (𝒟CP.coproduct-preserve-iso ⟦ τ₁ ⟧-iso ⟦ τ₂ ⟧-iso)
+-- The polynomial translations of a first-order type agree componentwise, up to
+-- the isomorphisms witnessing that F preserves the first-order structure.
+fo-poly-iso : ∀ {Δ n} {τ : type (n + Δ)} (fo : first-order τ)
+              (δ𝒞 : Fin Δ → Category.obj 𝒞) (δ𝒟 : Fin Δ → Category.obj 𝒟) →
+              (∀ i → 𝒟.Iso (F .fobj (δ𝒞 i)) (δ𝒟 i)) →
+              PM.PolyIso (Poly-map F (fo-as-poly {Δ} {n} fo δ𝒞)) (𝒟-as-poly {Δ} {n} τ δ𝒟)
+fo-poly-iso {n = n} (var i) δ𝒞 δ𝒟 es with splitAt n i
+... | inj₁ k = PM.pm-iso-var k
+... | inj₂ j = PM.pm-iso-const (es j)
+fo-poly-iso unit          δ𝒞 δ𝒟 es = PM.pm-iso-const (𝒟.IsIso→Iso FT)
+fo-poly-iso (base s)      δ𝒞 δ𝒟 es = PM.pm-iso-const 𝒟.Iso-refl
+fo-poly-iso (fo₁ [+] fo₂) δ𝒞 δ𝒟 es = PM.pm-iso-sum (fo-poly-iso fo₁ δ𝒞 δ𝒟 es) (fo-poly-iso fo₂ δ𝒞 δ𝒟 es)
+fo-poly-iso (fo₁ [×] fo₂) δ𝒞 δ𝒟 es = PM.pm-iso-prod (fo-poly-iso fo₁ δ𝒞 δ𝒟 es) (fo-poly-iso fo₂ δ𝒞 δ𝒟 es)
+fo-poly-iso (μ fo)        δ𝒞 δ𝒟 es = PM.pm-iso-μ (fo-poly-iso fo δ𝒞 δ𝒟 es)
+
+-- Every first-order type's interpretation in 𝒟 is isomorphic to the image
+-- under F of its interpretation in 𝒞; μ-types via preservation of μ and the
+-- componentwise isomorphism of the two polynomial translations.
+⟦_⟧-iso : ∀ {Δ} {τ : type Δ} (fo : first-order τ)
+          {δ𝒞 : Fin Δ → Category.obj 𝒞} {δ𝒟 : Fin Δ → Category.obj 𝒟} →
+          (∀ i → 𝒟.Iso (F .fobj (δ𝒞 i)) (δ𝒟 i)) →
+          𝒟.Iso (F .fobj (𝒞⟦ fo ⟧ty δ𝒞)) (𝒟⟦ τ ⟧ty δ𝒟)
+⟦ var i ⟧-iso es       = es i
+⟦ unit ⟧-iso es        = 𝒟.IsIso→Iso FT
+⟦ base s ⟧-iso es      = 𝒟.Iso-refl
+⟦ fo₁ [×] fo₂ ⟧-iso es =
+  𝒟.Iso-trans (𝒟.IsIso→Iso FP) (𝒟Pm.product-preserves-iso (⟦ fo₁ ⟧-iso es) (⟦ fo₂ ⟧-iso es))
+⟦ fo₁ [+] fo₂ ⟧-iso es =
+  𝒟.Iso-trans (𝒟.Iso-sym (𝒟.IsIso→Iso FC)) (𝒟CPm.coproduct-preserve-iso (⟦ fo₁ ⟧-iso es) (⟦ fo₂ ⟧-iso es))
+⟦ μ fo ⟧-iso {δ𝒞} {δ𝒟} es =
+  𝒟.Iso-trans (Fμ (fo-as-poly fo δ𝒞) (λ ()))
+              (PM.pm-μ-iso (fo-poly-iso fo δ𝒞 δ𝒟 es) (λ ()))
 
 ⟦_⟧ctxt-iso : ∀ {Γ} (Γ-fo : first-order-ctxt Γ) → 𝒟.Iso (F .fobj 𝒞⟦ Γ-fo ⟧ctxt) 𝒟⟦ Γ ⟧ctxt
-⟦ emp ⟧ctxt-iso   = 𝒟.IsIso→Iso FT
-⟦ Γ , τ ⟧ctxt-iso = 𝒟.Iso-trans (𝒟.IsIso→Iso FP) (𝒟P.product-preserves-iso ⟦ Γ ⟧ctxt-iso ⟦ τ ⟧-iso)
-
-------------------------------------------------------------------------------
--- When F is additionally full, the interpretation of the higher-order language is conservative
--- at first-order types: the interpretation of a term of first-order type, in a first-order
--- context, is the F-image of a morphism of 𝒞, up to the isomorphisms above.
-
-private
-  module 𝒞 = Category 𝒞
-
-open 𝒟.Iso
-
-first-order-conservativity :
-  Full F →
-  ∀ {Γ τ} (Γ-fo : first-order-ctxt Γ) (τ-fo : first-order τ) (M : Γ ⊢ τ) →
-  ∃ₛ (𝒞⟦ Γ-fo ⟧ctxt 𝒞.⇒ 𝒞⟦ τ-fo ⟧ty) λ g →
-    F .fmor g 𝒟.≈ (⟦ τ-fo ⟧-iso .bwd 𝒟.∘ (𝒟⟦ M ⟧tm 𝒟.∘ ⟦ Γ-fo ⟧ctxt-iso .fwd))
-first-order-conservativity F-full Γ-fo τ-fo M =
-  F-full (⟦ τ-fo ⟧-iso .bwd 𝒟.∘ (𝒟⟦ M ⟧tm 𝒟.∘ ⟦ Γ-fo ⟧ctxt-iso .fwd))
+⟦ emp ⟧ctxt-iso    = 𝒟.IsIso→Iso FT
+⟦ Γ , τ ⟧ctxt-iso =
+  𝒟.Iso-trans (𝒟.IsIso→Iso FP) (𝒟Pm.product-preserves-iso ⟦ Γ ⟧ctxt-iso (⟦ τ ⟧-iso (λ ())))
diff --git a/agda/src/language-interpretation.agda b/agda/src/language-interpretation.agda
index 3e19a0b9..5b309b9a 100644
--- a/agda/src/language-interpretation.agda
+++ b/agda/src/language-interpretation.agda
@@ -1,79 +1,256 @@
 {-# OPTIONS --prop --postfix-projections --safe #-}
 
-open import Level using (_⊔_)
-open import Data.List using (List; []; _∷_)
+import Data.Fin as Fin
+open Fin using (Fin; splitAt)
+open import Data.Nat using (zero; suc; _+_)
+open import Data.Sum using (_⊎_; [_,_]; inj₁; inj₂; map₁)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong; cong₂)
 open import categories
-  using (Category; HasTerminal; HasProducts; HasCoproducts; HasExponentials;
-         HasBooleans; coproducts+exp→booleans; HasLists)
+  using (Category; HasTerminal; HasProducts; HasCoproducts; HasStrongCoproducts;
+         strong-coproducts→coproducts; HasExponentials)
+open import signature using (Signature; Model; PointedFPCat; PFPC[_,_,_,_])
+import polynomial-functor
 import language-syntax
-open import signature using (Signature; Model; PFPC[_,_,_,_]; PointedFPCat)
-open import every using (Every; []; _∷_)
 
 module language-interpretation
   {ℓ} (Sig : Signature ℓ)
   {o m e}
   (𝒞 : Category o m e)
-  (T  : HasTerminal 𝒞)
-  (P  : HasProducts 𝒞)
-  (C  : HasCoproducts 𝒞)
-  (E  : HasExponentials 𝒞 P)
-  (L  : HasLists 𝒞 T P)
-  (Int : Model PFPC[ 𝒞 , T , P , HasBooleans.Bool (coproducts+exp→booleans T C E) ] Sig)
+  (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞SC : HasStrongCoproducts 𝒞 𝒞P)
+  (𝒞E : HasExponentials 𝒞 𝒞P)
+  (let open polynomial-functor.Interp 𝒞T 𝒞P 𝒞SC)
+  (let open polynomial-functor using (Poly; extend))
+  (Mu : HasMu)
+  (let Bool = HasCoproducts.coprod (strong-coproducts→coproducts 𝒞T 𝒞SC)
+              (HasTerminal.witness 𝒞T) (HasTerminal.witness 𝒞T))
+  (Int : Model PFPC[ 𝒞 , 𝒞T , 𝒞P , Bool ] Sig)
   where
 
-B : HasBooleans 𝒞 T P
-B = coproducts+exp→booleans T C E
-
-open HasExponentials E renaming (exp to _⟦→⟧_)
-open PointedFPCat PFPC[ 𝒞 , T , P , HasBooleans.Bool B ]
-open HasCoproducts C renaming (coprod to _+_)
-open HasBooleans B
-open HasLists L renaming (list to ⟦list⟧; nil to ⟦nil⟧; cons to ⟦cons⟧; fold to ⟦fold⟧)
-
+open Category 𝒞
+open HasTerminal 𝒞T renaming (witness to 𝟙)
+open HasProducts 𝒞P renaming (pair to ⟨_,_⟩)
+open HasCoproducts (strong-coproducts→coproducts 𝒞T 𝒞SC) using (coprod; coprod-m; in₁; in₂)
+open HasStrongCoproducts 𝒞SC using () renaming (copair to scopair)
+open HasExponentials 𝒞E using (lambda; eval) renaming (exp to _⟦→⟧_)
 open language-syntax Sig
+open HasMu Mu
 open Model Int
 
-⟦_⟧ty : type → obj
-⟦ unit ⟧ty = 𝟙
-⟦ bool ⟧ty = Bool
-⟦ base σ ⟧ty = ⟦sort⟧ σ
-⟦ τ₁ [×] τ₂ ⟧ty = ⟦ τ₁ ⟧ty × ⟦ τ₂ ⟧ty
-⟦ τ₁ [→] τ₂ ⟧ty = ⟦ τ₁ ⟧ty ⟦→⟧ ⟦ τ₂ ⟧ty
-⟦ τ₁ [+] τ₂ ⟧ty = ⟦ τ₁ ⟧ty + ⟦ τ₂ ⟧ty
-⟦ list τ ⟧ty = ⟦list⟧ ⟦ τ ⟧ty
+mutual
+  ⟦_⟧ty : ∀ {Δ} → type Δ → (Fin Δ → obj) → obj
+  ⟦ var i ⟧ty     δ = δ i
+  ⟦ unit ⟧ty      δ = 𝟙
+  ⟦ base s ⟧ty    δ = ⟦sort⟧ s
+  ⟦ σ [+] τ ⟧ty δ = coprod (⟦ σ ⟧ty δ) (⟦ τ ⟧ty δ)
+  ⟦ σ [×] τ ⟧ty δ = prod (⟦ σ ⟧ty δ) (⟦ τ ⟧ty δ)
+  ⟦ σ [→] τ ⟧ty δ = ⟦ σ ⟧ty (λ ()) ⟦→⟧ ⟦ τ ⟧ty (λ ())
+  ⟦ μ τ ⟧ty       δ = μ-obj (as-poly τ δ) (λ ())
+
+  as-poly : ∀ {Δ n} → type (n + Δ) → (Fin Δ → obj) → Poly 𝒞 n
+  as-poly {Δ} {n} (var i) δ = [ Poly.var , (λ j → Poly.const (δ j)) ] (splitAt n i)
+  as-poly unit            δ = Poly.const 𝟙
+  as-poly (base s)        δ = Poly.const (⟦sort⟧ s)
+  as-poly (σ [+] τ)       δ = as-poly σ δ Poly.+ as-poly τ δ
+  as-poly (σ [×] τ)       δ = as-poly σ δ Poly.× as-poly τ δ
+  as-poly (σ [→] τ)       δ = Poly.const (⟦ σ ⟧ty (λ ()) ⟦→⟧ ⟦ τ ⟧ty (λ ()))
+  as-poly (μ τ)           δ = Poly.μ (as-poly τ δ)
+
+-- Combined context: the first n variables from δ₀ (the Poly variables), the rest from δ.
+concat : ∀ {n Δ} → (Fin n → obj) → (Fin Δ → obj) → Fin (n + Δ) → obj
+concat {n} δ₀ δ i = [ δ₀ , δ ] (splitAt n i)
+
+-- Both as-poly and ⟦_⟧ty respect pointwise-equal environments.
+as-poly-cong : ∀ {Δ n} (τ : type (n + Δ)) {δ δ' : Fin Δ → obj} → (∀ i → δ i ≡ δ' i) → as-poly τ δ ≡ as-poly τ δ'
+as-poly-cong {Δ} {n} (var i) {δ} {δ'} h = go (splitAt n i)
+  where
+    go : (s : Fin n ⊎ Fin Δ) → [ Poly.var , (λ j → Poly.const (δ j)) ] s ≡ [ Poly.var , (λ j → Poly.const (δ' j)) ] s
+    go (inj₁ k) = refl
+    go (inj₂ j) = cong Poly.const (h j)
+as-poly-cong unit      h = refl
+as-poly-cong (base s)  h = refl
+as-poly-cong (σ [+] τ) h = cong₂ Poly._+_ (as-poly-cong σ h) (as-poly-cong τ h)
+as-poly-cong (σ [×] τ) h = cong₂ Poly._×_ (as-poly-cong σ h) (as-poly-cong τ h)
+as-poly-cong (σ [→] τ) h = refl
+as-poly-cong (μ τ)     h = cong Poly.μ (as-poly-cong τ h)
+
+ty-cong : ∀ {Δ} (τ : type Δ) {δ δ' : Fin Δ → obj} → (∀ i → δ i ≡ δ' i) → ⟦ τ ⟧ty δ ≡ ⟦ τ ⟧ty δ'
+ty-cong (var i)   h = h i
+ty-cong unit      h = refl
+ty-cong (base s)  h = refl
+ty-cong (σ [+] τ) h = cong₂ coprod (ty-cong σ h) (ty-cong τ h)
+ty-cong (σ [×] τ) h = cong₂ prod  (ty-cong σ h) (ty-cong τ h)
+ty-cong (σ [→] τ) h = refl
+ty-cong (μ τ)     h = cong (λ (P : Poly 𝒞 1) → μ-obj P (λ ())) (as-poly-cong τ h)
+
+-- Renaming a type is reindexing its environment. extᵗⁿ leaves the first n (poly) variables alone,
+-- so splitAt commutes with it.
+splitAt-extᵗⁿ : ∀ {Δ₁ Δ₂} n (ρ : TyRen Δ₁ Δ₂) (i : Fin (n + Δ₁)) →
+                splitAt n (extᵗⁿ n ρ i) ≡ [ inj₁ , (λ k → inj₂ (ρ k)) ] (splitAt n i)
+splitAt-extᵗⁿ zero    ρ i           = refl
+splitAt-extᵗⁿ (suc n) ρ Fin.zero    = refl
+splitAt-extᵗⁿ {Δ₁} (suc n) ρ (Fin.suc i) =
+  trans (cong (map₁ Fin.suc) (splitAt-extᵗⁿ n ρ i)) (go (splitAt n i))
+  where
+    go : (s : Fin n ⊎ Fin Δ₁) →
+         map₁ Fin.suc ([ inj₁ , (λ k → inj₂ (ρ k)) ] s) ≡ [ inj₁ , (λ k → inj₂ (ρ k)) ] (map₁ Fin.suc s)
+    go (inj₁ j) = refl
+    go (inj₂ k) = refl
+
+as-poly-ren : ∀ {Δ₁ Δ₂ n} (ρ : TyRen Δ₁ Δ₂) (τ : type (n + Δ₁)) (δ : Fin Δ₂ → obj) →
+              as-poly {Δ₂} {n} (extᵗⁿ n ρ *ᵗ τ) δ ≡ as-poly {Δ₁} {n} τ (λ i → δ (ρ i))
+as-poly-ren {Δ₁} {Δ₂} {n} ρ (var i) δ = go (splitAt n i) (splitAt n (extᵗⁿ n ρ i)) (splitAt-extᵗⁿ n ρ i)
+  where
+    go : (s : Fin n ⊎ Fin Δ₁) (s' : Fin n ⊎ Fin Δ₂) → s' ≡ [ inj₁ , (λ k → inj₂ (ρ k)) ] s →
+         [ Poly.var , (λ j → Poly.const (δ j)) ] s' ≡ [ Poly.var , (λ j → Poly.const (δ (ρ j))) ] s
+    go (inj₁ j) _ refl = refl
+    go (inj₂ k) _ refl = refl
+as-poly-ren ρ unit      δ = refl
+as-poly-ren ρ (base s)  δ = refl
+as-poly-ren ρ (σ [+] τ) δ = cong₂ Poly._+_ (as-poly-ren ρ σ δ) (as-poly-ren ρ τ δ)
+as-poly-ren ρ (σ [×] τ) δ = cong₂ Poly._×_ (as-poly-ren ρ σ δ) (as-poly-ren ρ τ δ)
+as-poly-ren ρ (σ [→] τ) δ = refl
+as-poly-ren ρ (μ τ)     δ = cong Poly.μ (as-poly-ren ρ τ δ)
+
+ty-ren : ∀ {Δ₁ Δ₂} (ρ : TyRen Δ₁ Δ₂) (τ : type Δ₁) (δ : Fin Δ₂ → obj) →
+         ⟦ ρ *ᵗ τ ⟧ty δ ≡ ⟦ τ ⟧ty (λ i → δ (ρ i))
+ty-ren ρ (var i)   δ = refl
+ty-ren ρ unit      δ = refl
+ty-ren ρ (base s)  δ = refl
+ty-ren ρ (σ [+] τ) δ = cong₂ coprod (ty-ren ρ σ δ) (ty-ren ρ τ δ)
+ty-ren ρ (σ [×] τ) δ = cong₂ prod  (ty-ren ρ σ δ) (ty-ren ρ τ δ)
+ty-ren ρ (σ [→] τ) δ = refl
+ty-ren ρ (μ τ)     δ = cong (λ (P : Poly 𝒞 1) → μ-obj P (λ ())) (as-poly-ren ρ τ δ)
+
+-- Freezing the poly-variables δ₀ into the environment (with X at position 0) reshuffles the
+-- combined context only up to pointwise equality.
+env-pw : ∀ {Δ n} (δ : Fin Δ → obj) (δ₀ : Fin n → obj) (X : obj) (i : Fin (suc (n + Δ))) →
+         concat (extend {0} (λ ()) X) (concat δ₀ δ) i ≡ concat (extend δ₀ X) δ i
+env-pw δ δ₀ X Fin.zero    = refl
+env-pw {n = n} δ δ₀ X (Fin.suc j) with splitAt n j
+... | inj₁ k = refl
+... | inj₂ l = refl
+
+-- Applying the polynomial (as-poly τ δ) is the interpretation of τ, in each direction. Morphisms
+-- suffice for the term semantics; the inverse laws are deferred.
+mutual
+  apply-fwd : ∀ {Δ n} (τ : type (n + Δ)) (δ : Fin Δ → obj) (δ₀ : Fin n → obj) →
+              ⟦ τ ⟧ty (concat δ₀ δ) ⇒ fobj μ-obj (as-poly {Δ} {n} τ δ) δ₀
+  apply-fwd {n = n} (var i) δ δ₀ with splitAt n i
+  ... | inj₁ j = id _
+  ... | inj₂ k = id _
+  apply-fwd unit      δ δ₀ = id _
+  apply-fwd (base s)  δ δ₀ = id _
+  apply-fwd (σ [+] τ) δ δ₀ = coprod-m (apply-fwd σ δ δ₀) (apply-fwd τ δ δ₀)
+  apply-fwd (σ [×] τ) δ δ₀ = prod-m (apply-fwd σ δ δ₀) (apply-fwd τ δ δ₀)
+  apply-fwd (σ [→] τ) δ δ₀ = id _
+  apply-fwd {Δ} {n} (μ τ) δ δ₀ =
+    μ-map (as-poly {n + Δ} {1} τ (concat δ₀ δ)) (λ ()) (as-poly {Δ} {suc n} τ δ) δ₀
+      (apply-fwd τ δ (extend δ₀ M) ∘ ≡-to-⇒ (ty-cong τ (env-pw δ δ₀ M)) ∘ apply-bwd {n = 1} τ (concat δ₀ δ) (extend (λ ()) M))
+    where M = μ-obj (as-poly {Δ} {suc n} τ δ) δ₀
+
+  apply-bwd : ∀ {Δ n} (τ : type (n + Δ)) (δ : Fin Δ → obj) (δ₀ : Fin n → obj) →
+              fobj μ-obj (as-poly {Δ} {n} τ δ) δ₀ ⇒ ⟦ τ ⟧ty (concat δ₀ δ)
+  apply-bwd {n = n} (var i) δ δ₀ with splitAt n i
+  ... | inj₁ j = id _
+  ... | inj₂ k = id _
+  apply-bwd unit      δ δ₀ = id _
+  apply-bwd (base s)  δ δ₀ = id _
+  apply-bwd (σ [+] τ) δ δ₀ = coprod-m (apply-bwd σ δ δ₀) (apply-bwd τ δ δ₀)
+  apply-bwd (σ [×] τ) δ δ₀ = prod-m (apply-bwd σ δ δ₀) (apply-bwd τ δ δ₀)
+  apply-bwd (σ [→] τ) δ δ₀ = id _
+  apply-bwd {Δ} {n} (μ τ) δ δ₀ =
+    μ-map (as-poly {Δ} {suc n} τ δ) δ₀ (as-poly {n + Δ} {1} τ (concat δ₀ δ)) (λ ())
+      (apply-fwd {n = 1} τ (concat δ₀ δ) (extend (λ ()) M) ∘ ≡-to-⇒ (sym (ty-cong τ (env-pw δ δ₀ M))) ∘ apply-bwd τ δ (extend δ₀ M))
+    where M = μ-obj (as-poly {n + Δ} {1} τ (concat δ₀ δ)) (λ ())
+
+-- Pointwise action of a lifted substitution on the extended environment: the new variable is mapped
+-- to itself, and the (weakened) old ones ignore it.
+sub-lift-pw : ∀ {Δ Δ'} (σ : TySub Δ Δ') (δ : Fin Δ' → obj) (X : obj) (i : Fin (suc Δ)) →
+              ⟦ sub-lift σ i ⟧ty (concat (extend {0} (λ ()) X) δ) ≡ concat (extend {0} (λ ()) X) (λ j → ⟦ σ j ⟧ty δ) i
+sub-lift-pw σ δ X Fin.zero    = refl
+sub-lift-pw σ δ X (Fin.suc j) = ty-ren Fin.suc (σ j) (concat (extend {0} (λ ()) X) δ)
+
+-- Semantic substitution: substituting then interpreting maps to interpreting in the environment
+-- that interprets the substituents (in each direction).
+subst-fwd : ∀ {Δ Δ'} (σ : TySub Δ Δ') (τ : type Δ) (δ : Fin Δ' → obj) →
+            ⟦ sub σ τ ⟧ty δ ⇒ ⟦ τ ⟧ty (λ i → ⟦ σ i ⟧ty δ)
+subst-fwd σ (var i)     δ = id _
+subst-fwd σ unit        δ = id _
+subst-fwd σ (base s)    δ = id _
+subst-fwd σ (τ₁ [+] τ₂) δ = coprod-m (subst-fwd σ τ₁ δ) (subst-fwd σ τ₂ δ)
+subst-fwd σ (τ₁ [×] τ₂) δ = prod-m (subst-fwd σ τ₁ δ) (subst-fwd σ τ₂ δ)
+subst-fwd σ (τ₁ [→] τ₂) δ = id _
+subst-fwd {Δ} {Δ'} σ (μ τ) δ =
+  μ-map (as-poly {Δ'} {1} (sub (sub-lift σ) τ) δ) (λ ()) (as-poly {Δ} {1} τ (λ i → ⟦ σ i ⟧ty δ)) (λ ())
+    (apply-fwd {n = 1} τ (λ i → ⟦ σ i ⟧ty δ) (extend (λ ()) M)
+     ∘ ≡-to-⇒ (ty-cong τ (sub-lift-pw σ δ M))
+     ∘ subst-fwd (sub-lift σ) τ (concat (extend {0} (λ ()) M) δ)
+     ∘ apply-bwd {n = 1} (sub (sub-lift σ) τ) δ (extend (λ ()) M))
+  where M = μ-obj (as-poly {Δ} {1} τ (λ i → ⟦ σ i ⟧ty δ)) (λ ())
+
+subst-bwd : ∀ {Δ Δ'} (σ : TySub Δ Δ') (τ : type Δ) (δ : Fin Δ' → obj) →
+            ⟦ τ ⟧ty (λ i → ⟦ σ i ⟧ty δ) ⇒ ⟦ sub σ τ ⟧ty δ
+subst-bwd σ (var i)     δ = id _
+subst-bwd σ unit        δ = id _
+subst-bwd σ (base s)    δ = id _
+subst-bwd σ (τ₁ [+] τ₂) δ = coprod-m (subst-bwd σ τ₁ δ) (subst-bwd σ τ₂ δ)
+subst-bwd σ (τ₁ [×] τ₂) δ = prod-m (subst-bwd σ τ₁ δ) (subst-bwd σ τ₂ δ)
+subst-bwd σ (τ₁ [→] τ₂) δ = id _
+subst-bwd {Δ} {Δ'} σ (μ τ) δ =
+  μ-map (as-poly {Δ} {1} τ (λ i → ⟦ σ i ⟧ty δ)) (λ ()) (as-poly {Δ'} {1} (sub (sub-lift σ) τ) δ) (λ ())
+    (apply-fwd {n = 1} (sub (sub-lift σ) τ) δ (extend (λ ()) M)
+     ∘ subst-bwd (sub-lift σ) τ (concat (extend {0} (λ ()) M) δ)
+     ∘ ≡-to-⇒ (sym (ty-cong τ (sub-lift-pw σ δ M)))
+     ∘ apply-bwd {n = 1} τ (λ i → ⟦ σ i ⟧ty δ) (extend (λ ()) M))
+  where M = μ-obj (as-poly {Δ'} {1} (sub (sub-lift σ) τ) δ) (λ ())
+
+-- The single substitution push τ', read pointwise as an environment.
+push-pw : ∀ (τ' : type 0) (i : Fin 1) → ⟦ push τ' i ⟧ty (λ ()) ≡ concat (extend {0} (λ ()) (⟦ τ' ⟧ty (λ ()))) (λ ()) i
+push-pw τ' Fin.zero = refl
+
+-- Syntactic substitution is functor application.
+sub-as-apply-fwd : (τ : type 1) (τ' : type 0) →
+                   ⟦ τ [ τ' ] ⟧ty (λ ()) ⇒ fobj μ-obj (as-poly {0} {1} τ (λ ())) (extend (λ ()) (⟦ τ' ⟧ty (λ ())))
+sub-as-apply-fwd τ τ' =
+  apply-fwd {0} {1} τ (λ ()) (extend (λ ()) (⟦ τ' ⟧ty (λ ()))) ∘
+  ≡-to-⇒ (ty-cong τ (push-pw τ')) ∘ subst-fwd (push τ') τ (λ ())
+
+sub-as-apply-bwd : (τ : type 1) (τ' : type 0) →
+                   fobj μ-obj (as-poly {0} {1} τ (λ ())) (extend (λ ()) (⟦ τ' ⟧ty (λ ()))) ⇒ ⟦ τ [ τ' ] ⟧ty (λ ())
+sub-as-apply-bwd τ τ' =
+  subst-bwd (push τ') τ (λ ()) ∘
+  ≡-to-⇒ (sym (ty-cong τ (push-pw τ'))) ∘ apply-bwd {0} {1} τ (λ ()) (extend (λ ()) (⟦ τ' ⟧ty (λ ())))
 
 ⟦_⟧ctxt : ctxt → obj
-⟦ emp ⟧ctxt = 𝟙
-⟦ Γ , τ ⟧ctxt = ⟦ Γ ⟧ctxt × ⟦ τ ⟧ty
+⟦ emp ⟧ctxt   = 𝟙
+⟦ Γ , τ ⟧ctxt = prod ⟦ Γ ⟧ctxt (⟦ τ ⟧ty (λ ()))
 
-⟦_⟧var : ∀ {Γ τ} → Γ ∋ τ → ⟦ Γ ⟧ctxt ⇒ ⟦ τ ⟧ty
-⟦ zero ⟧var = p₂
+⟦_⟧var : ∀ {Γ τ} → Γ ∋ τ → ⟦ Γ ⟧ctxt ⇒ ⟦ τ ⟧ty (λ ())
+⟦ zero ⟧var   = p₂
 ⟦ succ x ⟧var = ⟦ x ⟧var ∘ p₁
 
-swap : ∀ {x y} → (x × y) ⇒ (y × x)
-swap = ⟨ p₂ , p₁ ⟩
+open import every using (Every; []; _∷_)
+open PointedFPCat PFPC[ 𝒞 , 𝒞T , 𝒞P , Bool ] using (list→product)
 
 mutual
-  ⟦_⟧tm : ∀ {Γ τ} → Γ ⊢ τ → ⟦ Γ ⟧ctxt ⇒ ⟦ τ ⟧ty
-  ⟦ var x ⟧tm = ⟦ x ⟧var
-  ⟦ unit ⟧tm = to-terminal
-  ⟦ true ⟧tm = True ∘ to-terminal
-  ⟦ false ⟧tm = False ∘ to-terminal
-  ⟦ if M then M₁ else M₂ ⟧tm = cond ⟦ M₁ ⟧tm ⟦ M₂ ⟧tm ∘ ⟨ id _ , ⟦ M ⟧tm ⟩
-  ⟦ inl M ⟧tm = in₁ ∘ ⟦ M ⟧tm
-  ⟦ inr M ⟧tm = in₂ ∘ ⟦ M ⟧tm
-  ⟦ case M M₁ M₂ ⟧tm = eval ∘ ⟨ copair (lambda (⟦ M₁ ⟧tm ∘ swap)) (lambda (⟦ M₂ ⟧tm ∘ swap)) ∘ ⟦ M ⟧tm , id _ ⟩
-  ⟦ pair M N ⟧tm = ⟨ ⟦ M ⟧tm , ⟦ N ⟧tm ⟩
-  ⟦ fst M ⟧tm = p₁ ∘ ⟦ M ⟧tm
-  ⟦ snd M ⟧tm = p₂ ∘ ⟦ M ⟧tm
-  ⟦ lam M ⟧tm = lambda ⟦ M ⟧tm
-  ⟦ app M  N ⟧tm = eval ∘ ⟨ ⟦ M ⟧tm , ⟦ N ⟧tm ⟩
-  ⟦ bop ω Ms ⟧tm = ⟦op⟧ ω ∘ ⟦ Ms ⟧tms
-  ⟦ brel ω Ms ⟧tm = ⟦rel⟧ ω ∘ ⟦ Ms ⟧tms
-  ⟦ nil ⟧tm = ⟦nil⟧ ∘ to-terminal
-  ⟦ cons M N ⟧tm = ⟦cons⟧ ∘ ⟨ ⟦ M ⟧tm , ⟦ N ⟧tm ⟩
-  ⟦ fold M₁ M₂ M ⟧tm = ⟦fold⟧ ⟦ M₁ ⟧tm ⟦ M₂ ⟧tm ∘ ⟨ id _ , ⟦ M ⟧tm ⟩
+  ⟦_⟧tm : ∀ {Γ τ} → Γ ⊢ τ → ⟦ Γ ⟧ctxt ⇒ ⟦ τ ⟧ty (λ ())
+  ⟦ var x ⟧tm           = ⟦ x ⟧var
+  ⟦ unit ⟧tm            = to-terminal
+  ⟦ inl M ⟧tm           = in₁ ∘ ⟦ M ⟧tm
+  ⟦ inr M ⟧tm           = in₂ ∘ ⟦ M ⟧tm
+  ⟦ case M M₁ M₂ ⟧tm    = scopair ⟦ M₁ ⟧tm ⟦ M₂ ⟧tm ∘ ⟨ id _ , ⟦ M ⟧tm ⟩
+  ⟦ pair M N ⟧tm        = ⟨ ⟦ M ⟧tm , ⟦ N ⟧tm ⟩
+  ⟦ fst M ⟧tm           = p₁ ∘ ⟦ M ⟧tm
+  ⟦ snd M ⟧tm           = p₂ ∘ ⟦ M ⟧tm
+  ⟦ lam M ⟧tm           = lambda ⟦ M ⟧tm
+  ⟦ app M N ⟧tm         = eval ∘ ⟨ ⟦ M ⟧tm , ⟦ N ⟧tm ⟩
+  ⟦ bop ω Ms ⟧tm        = ⟦op⟧ ω ∘ ⟦ Ms ⟧tms
+  ⟦ brel r Ms ⟧tm       = ⟦rel⟧ r ∘ ⟦ Ms ⟧tms
+  ⟦ roll {τ = τ} M ⟧tm  =
+    inMap (as-poly τ (λ ())) (λ ()) ∘ sub-as-apply-fwd τ (μ τ) ∘ ⟦ M ⟧tm
+  ⟦ fold {τ = τ} {σ = σ} alg M ⟧tm =
+    ⦅ ⟦ alg ⟧tm ∘ prod-m (id _) (sub-as-apply-bwd τ σ) ⦆ ∘ ⟨ id _ , ⟦ M ⟧tm ⟩
 
   ⟦_⟧tms : ∀ {Γ σs} → Every (λ σ → Γ ⊢ base σ) σs → ⟦ Γ ⟧ctxt ⇒ list→product ⟦sort⟧ σs
-  ⟦ [] ⟧tms = to-terminal
+  ⟦ [] ⟧tms     = to-terminal
   ⟦ M ∷ Ms ⟧tms = ⟨ ⟦ M ⟧tm , ⟦ Ms ⟧tms ⟩
diff --git a/agda/src/language-operational/agreement.agda b/agda/src/language-operational/agreement.agda
new file mode 100644
index 00000000..39b86fd5
--- /dev/null
+++ b/agda/src/language-operational/agreement.agda
@@ -0,0 +1,2552 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import signature using (Signature)
+open import primitives using (Primitives)
+open import commutative-semiring using (CommutativeSemiring)
+import matrix
+import two
+
+-- Agreement of the graph judgement with evaluation: collapsing a derivation's graph recovers the
+-- run's dependency relation, case by case on the rules.
+module language-operational.agreement {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open import language-syntax Sig renaming (_,_ to _▸_)
+open import type-substitution Sig using (unfold₁; unfold₁-inst)
+open import language-operational.evaluation Sig 𝒫
+open import language-operational.path Sig 𝒫
+open import language-operational.graph Sig 𝒫
+open import language-operational.hide Sig 𝒫
+
+private
+  module M = matrix.Mat two.semiring
+
+open CommutativeSemiring two.semiring using (+-comm; +-cong; +-lunit; +-assoc; +-interchange; refl; trans)
+import Data.Bool as Bool
+import Data.Fin as Fin
+import Data.Nat
+open import Data.List using (List; []; _∷_; _++_; map)
+open import every using (Every; []; _∷_)
+open import Data.List.Properties using (map-++)
+open import Data.List.Relation.Unary.All using (All; []; _∷_; universal)
+open import Data.List.Relation.Unary.All.Properties using (map⁺; ++⁺)
+open import Relation.Binary.PropositionalEquality using (_≡_) renaming (refl to ≡-refl; cong to ≡-cong; trans to ≡-trans; sym to ≡-sym)
+  using (subst)
+open import prop-setoid using (module ≈-Reasoning) renaming (_⇒_ to _⇒ₛ_)
+open _⇒ₛ_ using (func)
+open import Data.Sum using (inj₁; inj₂) renaming (_⊎_ to _⊎'_)
+open import Data.Unit.Polymorphic using () renaming (⊤ to ⊤')
+import Level
+open import categories using (Category; HasTerminal)
+open Category M.cat using (_⇒_; ∘-cong; ∘-cong₁; ∘-cong₂; assoc; id-left; id-right; ≈-refl; ≈-sym; ≈-trans; isEquiv) renaming (id to idm)
+open HasTerminal M.terminal using (to-terminal)
+
++ₘ-runit : ∀ {m n} (R : M.Matrix m n) → (R M.+ₘ M.εₘ) M.≈ₘ R
++ₘ-runit R i j = +-comm {x = R i j} {y = two.O}
+
+-- The root of a graph is a sink: its row is zero.
+root-sink : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (y : Vertex D) →
+            graph D (at ε) y M.≈ₘ M.εₘ
+root-sink (⇓-var x) env i j = refl {x = two.O}
+root-sink (⇓-var x) (at ε) i j = refl {x = two.O}
+root-sink ⇓-unit env i j = refl {x = two.O}
+root-sink ⇓-unit (at ε) i j = refl {x = two.O}
+root-sink ⇓-lam env i j = refl {x = two.O}
+root-sink ⇓-lam (at ε) i j = refl {x = two.O}
+root-sink (⇓-inl D) env i j = refl {x = two.O}
+root-sink (⇓-inl D) (at ε) i j = refl {x = two.O}
+root-sink (⇓-inl D) (at (inl q)) i j = refl {x = two.O}
+root-sink (⇓-inr D) env i j = refl {x = two.O}
+root-sink (⇓-inr D) (at ε) i j = refl {x = two.O}
+root-sink (⇓-inr D) (at (inr q)) i j = refl {x = two.O}
+root-sink (⇓-fst D) env i j = refl {x = two.O}
+root-sink (⇓-fst D) (at ε) i j = refl {x = two.O}
+root-sink (⇓-fst D) (at (fst q)) i j = refl {x = two.O}
+root-sink (⇓-snd D) env i j = refl {x = two.O}
+root-sink (⇓-snd D) (at ε) i j = refl {x = two.O}
+root-sink (⇓-snd D) (at (snd q)) i j = refl {x = two.O}
+root-sink (⇓-roll D) env i j = refl {x = two.O}
+root-sink (⇓-roll D) (at ε) i j = refl {x = two.O}
+root-sink (⇓-roll D) (at (roll q)) i j = refl {x = two.O}
+root-sink (⇓-case-l D₁ D₂) env i j = refl {x = two.O}
+root-sink (⇓-case-l D₁ D₂) (at ε) i j = refl {x = two.O}
+root-sink (⇓-case-l D₁ D₂) (at (case-l₁ q)) i j = refl {x = two.O}
+root-sink (⇓-case-l D₁ D₂) (at (case-l₂ q)) i j = refl {x = two.O}
+root-sink (⇓-case-r D₁ D₂) env i j = refl {x = two.O}
+root-sink (⇓-case-r D₁ D₂) (at ε) i j = refl {x = two.O}
+root-sink (⇓-case-r D₁ D₂) (at (case-r₁ q)) i j = refl {x = two.O}
+root-sink (⇓-case-r D₁ D₂) (at (case-r₂ q)) i j = refl {x = two.O}
+root-sink (⇓-pair D₁ D₂) env i j = refl {x = two.O}
+root-sink (⇓-pair D₁ D₂) (at ε) i j = refl {x = two.O}
+root-sink (⇓-pair D₁ D₂) (at (pair₁ q)) i j = refl {x = two.O}
+root-sink (⇓-pair D₁ D₂) (at (pair₂ q)) i j = refl {x = two.O}
+root-sink (⇓-app D₁ D₂ D₃) env i j = refl {x = two.O}
+root-sink (⇓-app D₁ D₂ D₃) (at ε) i j = refl {x = two.O}
+root-sink (⇓-app D₁ D₂ D₃) (at (app₁ q)) i j = refl {x = two.O}
+root-sink (⇓-app D₁ D₂ D₃) (at (app₂ q)) i j = refl {x = two.O}
+root-sink (⇓-app D₁ D₂ D₃) (at (app₃ q)) i j = refl {x = two.O}
+root-sink (⇓-bop D) env i j = refl {x = two.O}
+root-sink (⇓-bop D) (at ε) i j = refl {x = two.O}
+root-sink (⇓-bop D) (at (bop q)) i j = refl {x = two.O}
+root-sink (⇓-brel D) env i j = refl {x = two.O}
+root-sink (⇓-brel D) (at ε) i j = refl {x = two.O}
+root-sink (⇓-brel D) (at (brel q)) i j = refl {x = two.O}
+root-sink (⇓-fold D₁ D₂) env i j = refl {x = two.O}
+root-sink (⇓-fold D₁ D₂) (at ε) i j = refl {x = two.O}
+root-sink (⇓-fold D₁ D₂) (at (fold₁ q)) i j = refl {x = two.O}
+root-sink (⇓-fold D₁ D₂) (at (fold₂ q)) i j = refl {x = two.O}
+
+-- Absorb a correction routed through a zero row.
+absorb : ∀ {m n k} (R : M.Matrix m n) (S : M.Matrix k n) → (R M.+ₘ (M.εₘ M.∘ S)) M.≈ₘ R
+absorb R S i j = trans (+-cong (refl {x = R i j}) (M.comp-bilinear-ε₁ S i j))
+                       (+-comm {x = R i j} {y = two.O})
+
+-- Axiom rules: the only path is the root, and hiding it composes a zero column, so the collapse is
+-- the rule's relation on the nose.
+agree-var : ∀ {Γ τ} {γ : Env Γ} (x : Γ ∋ τ) → collapse (⇓-var x) M.≈ₘ proj-var x γ
+agree-var {γ = γ} x = absorb (proj-var x γ) (proj-var x γ)
+
+agree-unit : ∀ {Γ} {γ : Env Γ} → collapse (⇓-unit {γ = γ}) M.≈ₘ to-terminal
+agree-unit () j
+
+agree-lam : ∀ {Γ σ τ} {γ : Env Γ} {t : Γ ▸ σ ⊢ τ} →
+            collapse (⇓-lam {γ = γ} {t = t}) M.≈ₘ idm (width-env γ)
+agree-lam {γ = γ} = absorb (idm (width-env γ)) (idm (width-env γ))
+
++ₘ-cong : ∀ {m n} {R R' S S' : M.Matrix m n} →
+          R M.≈ₘ R' → S M.≈ₘ S' → (R M.+ₘ S) M.≈ₘ (R' M.+ₘ S')
++ₘ-cong h k i j = +-cong (h i j) (k i j)
+
+-- Hiding the root changes nothing, its row being zero.
+hide-root : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (x y : Vertex D) →
+            hide (graph D) (at ε) x y M.≈ₘ graph D x y
+hide-root D x y =
+  ≈-trans (+ₘ-cong ≈-refl (∘-cong (root-sink D y) ≈-refl))
+          (absorb (graph D x y) (graph D x (at ε)))
+
+
++ₘ-lunit : ∀ {m n} (R : M.Matrix m n) → (M.εₘ M.+ₘ R) M.≈ₘ R
++ₘ-lunit R i j = +-lunit {x = R i j}
+
+-- Off the root, a root edge contributes nothing.
+edge-off : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} {m}
+           (S : M.Matrix m (width v)) (p : Path D) → is-ε p ≡ Bool.false →
+           edge S p M.≈ₘ M.εₘ
+edge-off S ε ()
+edge-off S (inl p) np i j = refl {x = two.O}
+edge-off S (inr p) np i j = refl {x = two.O}
+edge-off S (case-l₁ p) np i j = refl {x = two.O}
+edge-off S (case-l₂ p) np i j = refl {x = two.O}
+edge-off S (case-r₁ p) np i j = refl {x = two.O}
+edge-off S (case-r₂ p) np i j = refl {x = two.O}
+edge-off S (pair₁ p) np i j = refl {x = two.O}
+edge-off S (pair₂ p) np i j = refl {x = two.O}
+edge-off S (fst p) np i j = refl {x = two.O}
+edge-off S (snd p) np i j = refl {x = two.O}
+edge-off S (app₁ p) np i j = refl {x = two.O}
+edge-off S (app₂ p) np i j = refl {x = two.O}
+edge-off S (app₃ p) np i j = refl {x = two.O}
+edge-off S (roll p) np i j = refl {x = two.O}
+edge-off S (fold₁ p) np i j = refl {x = two.O}
+edge-off S (bop p) np i j = refl {x = two.O}
+edge-off S (brel p) np i j = refl {x = two.O}
+edge-off S (fold₂ p) np i j = refl {x = two.O}
+
+-- Interior paths are never the root.
+interior-not-root : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+                    All (λ p → is-ε p ≡ Bool.false) (interior D)
+interior-not-root (⇓-var x) = []
+interior-not-root ⇓-unit = []
+interior-not-root ⇓-lam = []
+interior-not-root (⇓-inl D) = map⁺ (universal (λ _ → ≡-refl) (paths D))
+interior-not-root (⇓-inr D) = map⁺ (universal (λ _ → ≡-refl) (paths D))
+interior-not-root (⇓-fst D) = map⁺ (universal (λ _ → ≡-refl) (paths D))
+interior-not-root (⇓-snd D) = map⁺ (universal (λ _ → ≡-refl) (paths D))
+interior-not-root (⇓-roll D) = map⁺ (universal (λ _ → ≡-refl) (paths D))
+interior-not-root (⇓-case-l D₁ D₂) = ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths D₁))) (map⁺ (universal (λ _ → ≡-refl) (paths D₂)))
+interior-not-root (⇓-case-r D₁ D₂) = ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths D₁))) (map⁺ (universal (λ _ → ≡-refl) (paths D₂)))
+interior-not-root (⇓-pair D₁ D₂) = ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths D₁))) (map⁺ (universal (λ _ → ≡-refl) (paths D₂)))
+interior-not-root (⇓-app D₁ D₂ D₃) = ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths D₁))) (++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths D₂))) (map⁺ (universal (λ _ → ≡-refl) (paths D₃))))
+interior-not-root (⇓-bop D) = map⁺ (universal (λ _ → ≡-refl) (paths-s D))
+interior-not-root (⇓-brel D) = map⁺ (universal (λ _ → ≡-refl) (paths-s D))
+interior-not-root (⇓-fold D₁ D₂) = ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths D₁))) (map⁺ (universal (λ _ → ≡-refl) (paths-m D₂)))
+
++ₘ-assoc : ∀ {m n} (X Y Z : M.Matrix m n) → ((X M.+ₘ Y) M.+ₘ Z) M.≈ₘ (X M.+ₘ (Y M.+ₘ Z))
++ₘ-assoc X Y Z i j = +-assoc {x = X i j} {y = Y i j} {z = Z i j}
+
+absorb-r : ∀ {m n k} (R : M.Matrix m n) (S : M.Matrix m k) → (R M.+ₘ (S M.∘ M.εₘ)) M.≈ₘ R
+absorb-r R S = ≈-trans (+ₘ-cong ≈-refl (M.comp-bilinear-ε₂ S)) (+ₘ-runit R)
+
+≈-of-≡ : ∀ {m n} {X Y : M.Matrix m n} → X ≡ Y → X M.≈ₘ Y
+≈-of-≡ ≡-refl = ≈-refl
+
+hide-all-++ : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+              (G : Graph D) (xs ys : List (Vertex D)) →
+              hide-all G (xs ++ ys) ≡ hide-all (hide-all G xs) ys
+hide-all-++ G []       ys = ≡-refl
+hide-all-++ G (x ∷ xs) ys = hide-all-++ (hide G x) xs ys
+
+hide-all-s-++ : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                {D : γ , Ms ⇓s vs [ R ]}
+                (G : GraphS D) (xs ys : List (VertexS D)) →
+                hide-all-s G (xs ++ ys) ≡ hide-all-s (hide-all-s G xs) ys
+hide-all-s-++ G []       ys = ≡-refl
+hide-all-s-++ G (x ∷ xs) ys = hide-all-s-++ (hide-s G x) xs ys
+
+distrib-root : ∀ {m n k l} (P : M.Matrix m n) (X : M.Matrix n k)
+               (Y : M.Matrix n l) (Z : M.Matrix l k) →
+               ((P M.∘ X) M.+ₘ ((P M.∘ Y) M.∘ Z)) M.≈ₘ (P M.∘ (X M.+ₘ (Y M.∘ Z)))
+distrib-root P X Y Z =
+  ≈-trans (+ₘ-cong ≈-refl (assoc P Y Z)) (≈-sym (M.comp-bilinear₂ P X (Y M.∘ Z)))
+
+
+-- Collapsing an inl derivation collapses its premise.
+offset-distrib : ∀ {m n l g} (K : M.Matrix m g) (P : M.Matrix m n) (X : M.Matrix n g)
+                 (Y : M.Matrix n l) (Z : M.Matrix l g) →
+                 ((K M.+ₘ (P M.∘ X)) M.+ₘ ((P M.∘ Y) M.∘ Z)) M.≈ₘ (K M.+ₘ (P M.∘ (X M.+ₘ (Y M.∘ Z))))
+offset-distrib K P X Y Z =
+  ≈-trans (+ₘ-assoc K (P M.∘ X) ((P M.∘ Y) M.∘ Z)) (+ₘ-cong ≈-refl (distrib-root P X Y Z))
+
+-- One hide step on related entries, root columns distributing through P.
+root-step : ∀ {m n l g} {P : M.Matrix m n} {G₁ : M.Matrix m g} {X : M.Matrix n g}
+            {G₂ : M.Matrix m l} {Y : M.Matrix n l} {G₃ Z : M.Matrix l g} →
+            G₁ M.≈ₘ (P M.∘ X) → G₂ M.≈ₘ (P M.∘ Y) → G₃ M.≈ₘ Z →
+            (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ (P M.∘ (X M.+ₘ (Y M.∘ Z)))
+root-step {P = P} {X = X} {Y = Y} {Z = Z} a b c =
+  ≈-trans (+ₘ-cong a (∘-cong b c)) (distrib-root P X Y Z)
+
+offset-step : ∀ {m n l g} {K : M.Matrix m g} {P : M.Matrix m n} {G₁ : M.Matrix m g}
+              {X : M.Matrix n g} {G₂ : M.Matrix m l} {Y : M.Matrix n l} {G₃ Z : M.Matrix l g} →
+              G₁ M.≈ₘ (K M.+ₘ (P M.∘ X)) → G₂ M.≈ₘ (P M.∘ Y) → G₃ M.≈ₘ Z →
+              (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ (K M.+ₘ (P M.∘ (X M.+ₘ (Y M.∘ Z))))
+offset-step {K = K} {P} {X = X} {Y = Y} {Z = Z} a b c =
+  ≈-trans (+ₘ-cong a (∘-cong b c)) (offset-distrib K P X Y Z)
+
+-- The two initial hides, in terms of the underlying graph's entries.
+hide-hide-root : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (r x y : Vertex D) →
+                 hide (hide (graph D) (at ε)) r x y
+                 M.≈ₘ (graph D x y M.+ₘ (graph D r y M.∘ graph D x r))
+hide-hide-root D r x y = +ₘ-cong (hide-root D x y) (∘-cong (hide-root D r y) (hide-root D x r))
+
+-- Clean a zero direct entry against a routed one, and restore the premise's hidden root.
+into-hidden : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) {m}
+              (P : M.Matrix m (width v)) (x : Vertex D) →
+              (M.εₘ M.+ₘ (P M.∘ graph D x (at ε))) M.≈ₘ (P M.∘ hide (graph D) (at ε) x (at ε))
+into-hidden D P x =
+  ≈-trans (+ₘ-lunit (P M.∘ graph D x (at ε))) (∘-cong₂ (≈-sym (hide-root D x (at ε))))
+
+-- Collapsing an inl derivation collapses its premise.
+module Inl {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁} {v : Val τ₁} {R : width-env γ ⇒ width v}
+           {D : γ , t ⇓ v [ R ]} where
+
+  record Embeds (G : Graph (⇓-inl {τ₂ = τ₂} D)) (H : Graph D)
+                (P : M.Matrix (width v) (width v)) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (inl q)) M.≈ₘ H env (at q)
+      embed-embed : ∀ p q → G (at (inl p)) (at (inl q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      embed-root  : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (inl p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : Path D) → is-ε w ≡ Bool.false →
+                Embeds G H P → Embeds (hide G (at (inl w))) (hide H (at w)) P
+  embeds-hide w nw s .env-embed q   = +ₘ-cong (s .env-embed q) (∘-cong (s .embed-embed w q) (s .env-embed w))
+  embeds-hide w nw s .embed-embed p q = +ₘ-cong (s .embed-embed p q) (∘-cong (s .embed-embed w q) (s .embed-embed p w))
+  embeds-hide {P = P} w nw s .env-root = root-step {P = P} (s .env-root) (s .embed-root w nw) (s .env-embed w)
+  embeds-hide {P = P} w nw s .embed-root p np =
+    root-step {P = P} (s .embed-root p np) (s .embed-root w nw) (s .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (Path D)) → All (λ w → is-ε w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all G (map at (map inl ws))) (hide-all H (map at ws)) P
+  embeds-hide-all []       []         s = s
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) s = embeds-hide-all ws nws (embeds-hide w nw s)
+
+  private
+    embeds₀ : Embeds (hide (hide (graph (⇓-inl {τ₂ = τ₂} D)) (at ε)) (at (inl ε)))
+                     (hide (graph D) (at ε)) M.I
+    embeds₀ .env-embed q   = hide-hide-root (⇓-inl {τ₂ = τ₂} D) (at (inl ε)) env (at (inl q))
+    embeds₀ .embed-embed p q = hide-hide-root (⇓-inl {τ₂ = τ₂} D) (at (inl ε)) (at (inl p)) (at (inl q))
+    embeds₀ .env-root      =
+      ≈-trans (hide-hide-root (⇓-inl {τ₂ = τ₂} D) (at (inl ε)) env (at ε)) (into-hidden D M.I env)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root (⇓-inl {τ₂ = τ₂} D) (at (inl ε)) (at (inl p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off M.I p np) ≈-refl) (into-hidden D M.I (at p)))
+
+  agree : collapse (⇓-inl {τ₂ = τ₂} D) M.≈ₘ collapse D
+  agree = ≈-trans (embeds-hide-all (interior D) (interior-not-root D) embeds₀ .env-root) id-left
+
+-- Collapsing an inr derivation collapses its premise.
+module Inr {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₂} {v : Val τ₂} {R : width-env γ ⇒ width v}
+           {D : γ , t ⇓ v [ R ]} where
+
+  record Embeds (G : Graph (⇓-inr {τ₁ = τ₁} D)) (H : Graph D)
+                (P : M.Matrix (width v) (width v)) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (inr q)) M.≈ₘ H env (at q)
+      embed-embed : ∀ p q → G (at (inr p)) (at (inr q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      embed-root  : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (inr p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : Path D) → is-ε w ≡ Bool.false →
+                Embeds G H P → Embeds (hide G (at (inr w))) (hide H (at w)) P
+  embeds-hide w nw s .env-embed q   = +ₘ-cong (s .env-embed q) (∘-cong (s .embed-embed w q) (s .env-embed w))
+  embeds-hide w nw s .embed-embed p q = +ₘ-cong (s .embed-embed p q) (∘-cong (s .embed-embed w q) (s .embed-embed p w))
+  embeds-hide {P = P} w nw s .env-root = root-step {P = P} (s .env-root) (s .embed-root w nw) (s .env-embed w)
+  embeds-hide {P = P} w nw s .embed-root p np =
+    root-step {P = P} (s .embed-root p np) (s .embed-root w nw) (s .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (Path D)) → All (λ w → is-ε w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all G (map at (map inr ws))) (hide-all H (map at ws)) P
+  embeds-hide-all []       []         s = s
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) s = embeds-hide-all ws nws (embeds-hide w nw s)
+
+  private
+    embeds₀ : Embeds (hide (hide (graph (⇓-inr {τ₁ = τ₁} D)) (at ε)) (at (inr ε)))
+                     (hide (graph D) (at ε)) M.I
+    embeds₀ .env-embed q   = hide-hide-root (⇓-inr {τ₁ = τ₁} D) (at (inr ε)) env (at (inr q))
+    embeds₀ .embed-embed p q = hide-hide-root (⇓-inr {τ₁ = τ₁} D) (at (inr ε)) (at (inr p)) (at (inr q))
+    embeds₀ .env-root      =
+      ≈-trans (hide-hide-root (⇓-inr {τ₁ = τ₁} D) (at (inr ε)) env (at ε)) (into-hidden D M.I env)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root (⇓-inr {τ₁ = τ₁} D) (at (inr ε)) (at (inr p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off M.I p np) ≈-refl) (into-hidden D M.I (at p)))
+
+  agree : collapse (⇓-inr {τ₁ = τ₁} D) M.≈ₘ collapse D
+  agree = ≈-trans (embeds-hide-all (interior D) (interior-not-root D) embeds₀ .env-root) id-left
+
+-- Collapsing a fst derivation projects its premise's collapse.
+module Fst {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁ [×] τ₂} {v : Val τ₁} {u : Val τ₂}
+           {R : width-env γ ⇒ width (pair v u)} {D : γ , t ⇓ pair v u [ R ]} where
+
+  record Embeds (G : Graph (⇓-fst D)) (H : Graph D)
+                (P : M.Matrix (width v) (width (pair v u))) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (fst q)) M.≈ₘ H env (at q)
+      embed-embed : ∀ p q → G (at (fst p)) (at (fst q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      embed-root  : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (fst p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : Path D) → is-ε w ≡ Bool.false →
+                Embeds G H P → Embeds (hide G (at (fst w))) (hide H (at w)) P
+  embeds-hide w nw s .env-embed q   = +ₘ-cong (s .env-embed q) (∘-cong (s .embed-embed w q) (s .env-embed w))
+  embeds-hide w nw s .embed-embed p q = +ₘ-cong (s .embed-embed p q) (∘-cong (s .embed-embed w q) (s .embed-embed p w))
+  embeds-hide {P = P} w nw s .env-root = root-step {P = P} (s .env-root) (s .embed-root w nw) (s .env-embed w)
+  embeds-hide {P = P} w nw s .embed-root p np =
+    root-step {P = P} (s .embed-root p np) (s .embed-root w nw) (s .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (Path D)) → All (λ w → is-ε w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all G (map at (map fst ws))) (hide-all H (map at ws)) P
+  embeds-hide-all []       []         s = s
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) s = embeds-hide-all ws nws (embeds-hide w nw s)
+
+  private
+    embeds₀ : Embeds (hide (hide (graph (⇓-fst D)) (at ε)) (at (fst ε)))
+                     (hide (graph D) (at ε)) M.p₁
+    embeds₀ .env-embed q   = hide-hide-root (⇓-fst D) (at (fst ε)) env (at (fst q))
+    embeds₀ .embed-embed p q = hide-hide-root (⇓-fst D) (at (fst ε)) (at (fst p)) (at (fst q))
+    embeds₀ .env-root      =
+      ≈-trans (hide-hide-root (⇓-fst D) (at (fst ε)) env (at ε)) (into-hidden D M.p₁ env)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root (⇓-fst D) (at (fst ε)) (at (fst p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off M.p₁ p np) ≈-refl) (into-hidden D M.p₁ (at p)))
+
+  agree : collapse (⇓-fst D) M.≈ₘ (M.p₁ M.∘ collapse D)
+  agree = embeds-hide-all (interior D) (interior-not-root D) embeds₀ .env-root
+
+-- Collapsing a snd derivation projects its premise's collapse.
+module Snd {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁ [×] τ₂} {v : Val τ₁} {u : Val τ₂}
+           {R : width-env γ ⇒ width (pair v u)} {D : γ , t ⇓ pair v u [ R ]} where
+
+  record Embeds (G : Graph (⇓-snd D)) (H : Graph D)
+                (P : M.Matrix (width u) (width (pair v u))) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (snd q)) M.≈ₘ H env (at q)
+      embed-embed : ∀ p q → G (at (snd p)) (at (snd q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      embed-root  : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (snd p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : Path D) → is-ε w ≡ Bool.false →
+                Embeds G H P → Embeds (hide G (at (snd w))) (hide H (at w)) P
+  embeds-hide w nw s .env-embed q   = +ₘ-cong (s .env-embed q) (∘-cong (s .embed-embed w q) (s .env-embed w))
+  embeds-hide w nw s .embed-embed p q = +ₘ-cong (s .embed-embed p q) (∘-cong (s .embed-embed w q) (s .embed-embed p w))
+  embeds-hide {P = P} w nw s .env-root = root-step {P = P} (s .env-root) (s .embed-root w nw) (s .env-embed w)
+  embeds-hide {P = P} w nw s .embed-root p np =
+    root-step {P = P} (s .embed-root p np) (s .embed-root w nw) (s .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (Path D)) → All (λ w → is-ε w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all G (map at (map snd ws))) (hide-all H (map at ws)) P
+  embeds-hide-all []       []         s = s
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) s = embeds-hide-all ws nws (embeds-hide w nw s)
+
+  private
+    embeds₀ : Embeds (hide (hide (graph (⇓-snd D)) (at ε)) (at (snd ε)))
+                     (hide (graph D) (at ε)) M.p₂
+    embeds₀ .env-embed q   = hide-hide-root (⇓-snd D) (at (snd ε)) env (at (snd q))
+    embeds₀ .embed-embed p q = hide-hide-root (⇓-snd D) (at (snd ε)) (at (snd p)) (at (snd q))
+    embeds₀ .env-root      =
+      ≈-trans (hide-hide-root (⇓-snd D) (at (snd ε)) env (at ε)) (into-hidden D M.p₂ env)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root (⇓-snd D) (at (snd ε)) (at (snd p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off M.p₂ p np) ≈-refl) (into-hidden D M.p₂ (at p)))
+
+  agree : collapse (⇓-snd D) M.≈ₘ (M.p₂ M.∘ collapse D)
+  agree = embeds-hide-all (interior D) (interior-not-root D) embeds₀ .env-root
+
+-- Collapsing a roll derivation collapses its premise.
+module Roll {Γ} {τ : type 1} {γ : Env Γ} {t : Γ ⊢ τ [ μ τ ]} {v : Val (τ [ μ τ ])}
+           {R : width-env γ ⇒ width v} {D : γ , t ⇓ v [ R ]} where
+
+  record Embeds (G : Graph (⇓-roll {τ = τ} D)) (H : Graph D)
+                (P : M.Matrix (width v) (width v)) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (roll q)) M.≈ₘ H env (at q)
+      embed-embed : ∀ p q → G (at (roll p)) (at (roll q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      embed-root  : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (roll p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : Path D) → is-ε w ≡ Bool.false →
+                Embeds G H P → Embeds (hide G (at (roll w))) (hide H (at w)) P
+  embeds-hide w nw s .env-embed q   = +ₘ-cong (s .env-embed q) (∘-cong (s .embed-embed w q) (s .env-embed w))
+  embeds-hide w nw s .embed-embed p q = +ₘ-cong (s .embed-embed p q) (∘-cong (s .embed-embed w q) (s .embed-embed p w))
+  embeds-hide {P = P} w nw s .env-root = root-step {P = P} (s .env-root) (s .embed-root w nw) (s .env-embed w)
+  embeds-hide {P = P} w nw s .embed-root p np =
+    root-step {P = P} (s .embed-root p np) (s .embed-root w nw) (s .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (Path D)) → All (λ w → is-ε w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all G (map at (map roll ws))) (hide-all H (map at ws)) P
+  embeds-hide-all []       []         s = s
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) s = embeds-hide-all ws nws (embeds-hide w nw s)
+
+  private
+    embeds₀ : Embeds (hide (hide (graph (⇓-roll {τ = τ} D)) (at ε)) (at (roll ε)))
+                     (hide (graph D) (at ε)) M.I
+    embeds₀ .env-embed q   = hide-hide-root (⇓-roll {τ = τ} D) (at (roll ε)) env (at (roll q))
+    embeds₀ .embed-embed p q = hide-hide-root (⇓-roll {τ = τ} D) (at (roll ε)) (at (roll p)) (at (roll q))
+    embeds₀ .env-root      =
+      ≈-trans (hide-hide-root (⇓-roll {τ = τ} D) (at (roll ε)) env (at ε)) (into-hidden D M.I env)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root (⇓-roll {τ = τ} D) (at (roll ε)) (at (roll p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off M.I p np) ≈-refl) (into-hidden D M.I (at p)))
+
+  agree : collapse (⇓-roll {τ = τ} D) M.≈ₘ collapse D
+  agree = ≈-trans (embeds-hide-all (interior D) (interior-not-root D) embeds₀ .env-root) id-left
+
+-- Two same-environment premises: while the first premise folds, the second premise's entries and
+-- the cross entries must be seen undisturbed (nine families); the second phase then folds the
+-- second premise against the finished first contribution as a constant offset K.
+module Pair {Γ τ₁ τ₂} {γ : Env Γ} {ts : Γ ⊢ τ₁} {tt : Γ ⊢ τ₂} {v : Val τ₁} {u : Val τ₂}
+            {R : width-env γ ⇒ width v} {S : width-env γ ⇒ width u}
+            {D₁ : γ , ts ⇓ v [ R ]} {D₂ : γ , tt ⇓ u [ S ]} where
+
+  record Phase₁ (G : Graph (⇓-pair D₁ D₂)) (H : Graph D₁) : Set ℓ where
+    field
+      env-left    : ∀ q → G env (at (pair₁ q)) M.≈ₘ H env (at q)
+      left-left   : ∀ p q → G (at (pair₁ p)) (at (pair₁ q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (M.in₁ M.∘ H env (at ε))
+      left-root   : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (pair₁ p)) (at ε) M.≈ₘ (M.in₁ M.∘ H (at p) (at ε))
+      env-right   : ∀ q → G env (at (pair₂ q)) M.≈ₘ graph D₂ env (at q)
+      right-right : ∀ p q → G (at (pair₂ p)) (at (pair₂ q)) M.≈ₘ graph D₂ (at p) (at q)
+      right-root  : ∀ p → G (at (pair₂ p)) (at ε) M.≈ₘ edge M.in₂ p
+      left-right  : ∀ p q → G (at (pair₁ p)) (at (pair₂ q)) M.≈ₘ M.εₘ
+      right-left  : ∀ p q → G (at (pair₂ p)) (at (pair₁ q)) M.≈ₘ M.εₘ
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (w : Path D₁) → is-ε w ≡ Bool.false →
+          Phase₁ G H → Phase₁ (hide G (at (pair₁ w))) (hide H (at w))
+  step₁ w nw r .env-left q  = +ₘ-cong (r .env-left q) (∘-cong (r .left-left w q) (r .env-left w))
+  step₁ w nw r .left-left p q = +ₘ-cong (r .left-left p q) (∘-cong (r .left-left w q) (r .left-left p w))
+  step₁ w nw r .env-root = root-step {P = M.in₁ {width v} {width u}} (r .env-root) (r .left-root w nw) (r .env-left w)
+  step₁ w nw r .left-root p np = root-step {P = M.in₁ {width v} {width u}} (r .left-root p np) (r .left-root w nw) (r .left-left p w)
+  step₁ {G} w nw r .env-right q =
+    ≈-trans (+ₘ-cong (r .env-right q) (∘-cong₁ (r .left-right w q)))
+            (absorb (graph D₂ env (at q)) (G env (at (pair₁ w))))
+  step₁ {G} w nw r .right-right p q =
+    ≈-trans (+ₘ-cong (r .right-right p q) (∘-cong₁ (r .left-right w q)))
+            (absorb (graph D₂ (at p) (at q)) (G (at (pair₂ p)) (at (pair₁ w))))
+  step₁ {G} w nw r .right-root p =
+    ≈-trans (+ₘ-cong (r .right-root p) (∘-cong₂ (r .right-left p w)))
+            (absorb-r (edge M.in₂ p) (G (at (pair₁ w)) (at ε)))
+  step₁ {G} w nw r .left-right p q =
+    ≈-trans (+ₘ-cong (r .left-right p q) (∘-cong₁ (r .left-right w q)))
+            (absorb M.εₘ (G (at (pair₁ p)) (at (pair₁ w))))
+  step₁ {G} w nw r .right-left p q =
+    ≈-trans (+ₘ-cong (r .right-left p q) (∘-cong₂ (r .right-left p w)))
+            (absorb-r M.εₘ (G (at (pair₁ w)) (at (pair₁ q))))
+
+  steps₁ : ∀ {G H} (ws : List (Path D₁)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₁ G H → Phase₁ (hide-all G (map at (map pair₁ ws))) (hide-all H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (w ∷ ws) (nw ∷ nws) r = steps₁ ws nws (step₁ w nw r)
+
+  private
+    hh : ∀ x y → hide (hide (graph (⇓-pair D₁ D₂)) (at ε)) (at (pair₁ ε)) x y
+         M.≈ₘ (graph (⇓-pair D₁ D₂) x y
+               M.+ₘ (graph (⇓-pair D₁ D₂) (at (pair₁ ε)) y M.∘ graph (⇓-pair D₁ D₂) x (at (pair₁ ε))))
+    hh = hide-hide-root (⇓-pair D₁ D₂) (at (pair₁ ε))
+
+    base₁ : Phase₁ (hide (hide (graph (⇓-pair D₁ D₂)) (at ε)) (at (pair₁ ε)))
+                   (hide (graph D₁) (at ε))
+    base₁ .env-left q  = hh env (at (pair₁ q))
+    base₁ .left-left p q = hh (at (pair₁ p)) (at (pair₁ q))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (into-hidden D₁ M.in₁ env)
+    base₁ .left-root p np =
+      ≈-trans (hh (at (pair₁ p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off M.in₁ p np) ≈-refl) (into-hidden D₁ M.in₁ (at p)))
+    base₁ .env-right q = ≈-trans (hh env (at (pair₂ q))) (absorb (graph D₂ env (at q)) (graph D₁ env (at ε)))
+    base₁ .right-right p q =
+      ≈-trans (hh (at (pair₂ p)) (at (pair₂ q)))
+              (absorb (graph D₂ (at p) (at q)) (graph (⇓-pair D₁ D₂) (at (pair₂ p)) (at (pair₁ ε))))
+    base₁ .right-root p =
+      ≈-trans (hh (at (pair₂ p)) (at ε))
+              (absorb-r (edge M.in₂ p) (graph (⇓-pair D₁ D₂) (at (pair₁ ε)) (at ε)))
+    base₁ .left-right p q =
+      ≈-trans (hh (at (pair₁ p)) (at (pair₂ q))) (absorb M.εₘ (graph D₁ (at p) (at ε)))
+    base₁ .right-left p q =
+      ≈-trans (hh (at (pair₂ p)) (at (pair₁ q))) (absorb-r M.εₘ (graph D₁ (at ε) (at q)))
+
+  record Phase₂ (G : Graph (⇓-pair D₁ D₂)) (H : Graph D₂)
+                (K : M.Matrix (width (pair v u)) (width-env γ)) : Set ℓ where
+    field
+      env-right   : ∀ q → G env (at (pair₂ q)) M.≈ₘ H env (at q)
+      right-right : ∀ p q → G (at (pair₂ p)) (at (pair₂ q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (K M.+ₘ (M.in₂ M.∘ H env (at ε)))
+      right-root  : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (pair₂ p)) (at ε) M.≈ₘ (M.in₂ M.∘ H (at p) (at ε))
+
+  open Phase₂
+
+  step₂ : ∀ {G H K} (w : Path D₂) → is-ε w ≡ Bool.false →
+          Phase₂ G H K → Phase₂ (hide G (at (pair₂ w))) (hide H (at w)) K
+  step₂ w nw r .env-right q  = +ₘ-cong (r .env-right q) (∘-cong (r .right-right w q) (r .env-right w))
+  step₂ w nw r .right-right p q = +ₘ-cong (r .right-right p q) (∘-cong (r .right-right w q) (r .right-right p w))
+  step₂ w nw r .env-root = offset-step {P = M.in₂ {width v} {width u}} (r .env-root) (r .right-root w nw) (r .env-right w)
+  step₂ w nw r .right-root p np = root-step {P = M.in₂ {width v} {width u}} (r .right-root p np) (r .right-root w nw) (r .right-right p w)
+
+  steps₂ : ∀ {G H K} (ws : List (Path D₂)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₂ G H K → Phase₂ (hide-all G (map at (map pair₂ ws))) (hide-all H (map at ws)) K
+  steps₂ []       []         r = r
+  steps₂ (w ∷ ws) (nw ∷ nws) r = steps₂ ws nws (step₂ w nw r)
+
+  private
+    r1 : Phase₁ (hide-all (hide (hide (graph (⇓-pair D₁ D₂)) (at ε)) (at (pair₁ ε)))
+                          (map at (map pair₁ (interior D₁))))
+                (hide-all (hide (graph D₁) (at ε)) (map at (interior D₁)))
+    r1 = steps₁ (interior D₁) (interior-not-root D₁) base₁
+
+    base₂ : Phase₂ (hide (hide-all (hide (hide (graph (⇓-pair D₁ D₂)) (at ε)) (at (pair₁ ε)))
+                                   (map at (map pair₁ (interior D₁))))
+                         (at (pair₂ ε)))
+                   (hide (graph D₂) (at ε))
+                   (M.in₁ M.∘ collapse D₁)
+    base₂ .env-right q = +ₘ-cong (r1 .env-right q) (∘-cong (r1 .right-right ε q) (r1 .env-right ε))
+    base₂ .right-right p q = +ₘ-cong (r1 .right-right p q) (∘-cong (r1 .right-right ε q) (r1 .right-right p ε))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (r1 .env-root) (∘-cong (r1 .right-root ε) (r1 .env-right ε)))
+              (+ₘ-cong ≈-refl (∘-cong₂ (≈-sym (hide-root D₂ env (at ε)))))
+    base₂ .right-root p np =
+      ≈-trans (+ₘ-cong (r1 .right-root p) (∘-cong (r1 .right-root ε) (r1 .right-right p ε)))
+      (≈-trans (+ₘ-cong (edge-off M.in₂ p np) ≈-refl) (into-hidden D₂ M.in₂ (at p)))
+
+  -- Collapsing a pair derivation pairs its premises' collapses.
+  agree : collapse (⇓-pair D₁ D₂)
+               M.≈ₘ ((M.in₁ M.∘ collapse D₁) M.+ₘ (M.in₂ M.∘ collapse D₂))
+  agree =
+    ≈-trans (≈-of-≡ plumb) (steps₂ (interior D₂) (interior-not-root D₂) base₂ .env-root)
+    where
+      plumb : hide-all (hide (graph (⇓-pair D₁ D₂)) (at ε))
+                       (map at (map pair₁ (paths D₁) ++ map pair₂ (paths D₂))) env (at ε)
+              ≡ hide-all (hide-all (hide (graph (⇓-pair D₁ D₂)) (at ε))
+                                   (map at (map pair₁ (paths D₁))))
+                         (map at (map pair₂ (paths D₂))) env (at ε)
+      plumb =
+        ≡-trans (≡-cong (λ L → hide-all (hide (graph (⇓-pair D₁ D₂)) (at ε)) L env (at ε))
+                        (map-++ at (map pair₁ (paths D₁)) (map pair₂ (paths D₂))))
+                (≡-cong (λ Gg → Gg env (at ε))
+                        (hide-all-++ (hide (graph (⇓-pair D₁ D₂)) (at ε))
+                                     (map at (map pair₁ (paths D₁)))
+                                     (map at (map pair₂ (paths D₂)))))
+
+-- One hide step under a fixed post-composition W.
+step-under : ∀ {m l g g'} {W : M.Matrix g g'} {G₁ : M.Matrix m g'} {X : M.Matrix m g}
+             {G₂ : M.Matrix m l} {Y : M.Matrix m l} {G₃ : M.Matrix l g'} {Z : M.Matrix l g} →
+             G₁ M.≈ₘ (X M.∘ W) → G₂ M.≈ₘ Y → G₃ M.≈ₘ (Z M.∘ W) →
+             (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ ((X M.+ₘ (Y M.∘ Z)) M.∘ W)
+step-under {W = W} {X = X} {Y = Y} {Z = Z} a b c =
+  ≈-trans (+ₘ-cong a (∘-cong b c))
+  (≈-trans (+ₘ-cong ≈-refl (≈-sym (assoc Y Z W))) (≈-sym (M.comp-bilinear₁ X (Y M.∘ Z) W)))
+
+-- Regroup a rewired column: the env slice plus the routed slice factor through the substitution.
+factor : ∀ {m g wv} (B : M.Matrix m (g Data.Nat.+ wv)) (C : M.Matrix wv g) →
+         ((B M.∘ M.in₁) M.+ₘ ((B M.∘ M.in₂) M.∘ C)) M.≈ₘ (B M.∘ (M.in₁ M.+ₘ (M.in₂ M.∘ C)))
+factor B C =
+  ≈-trans (+ₘ-cong ≈-refl (assoc B M.in₂ C)) (≈-sym (M.comp-bilinear₂ B M.in₁ (M.in₂ M.∘ C)))
+
+-- Left case branch, evaluated under the extended environment. Phase one folds the scrutinee: the branch's rewired columns carry the env slice
+-- plus the routed slice through the evolving scrutinee collapse. Phase two folds the branch with
+-- its env columns composed with the substitution W.
+module CaseL {Γ τ₁ τ₂ τ} {γ : Env Γ} {ts : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+            {v : Val τ₁} {u : Val τ}
+            {R : width-env γ ⇒ width v} {S : width-env (γ · v) ⇒ width u}
+            {D₁ : γ , ts ⇓ inl v [ R ]} {D₂ : γ · v , t₁ ⇓ u [ S ]} where
+
+  iₗ : M.Matrix (width-env (γ · v)) (width-env γ)
+  iₗ = M.in₁ {width-env γ} {width v}
+
+  iᵣ : M.Matrix (width-env (γ · v)) (width v)
+  iᵣ = M.in₂ {width-env γ} {width v}
+
+  B : (q : Path D₂) → M.Matrix (width-at q) (width-env (γ · v))
+  B q = graph D₂ env (at q)
+
+  W : M.Matrix (width-env (γ · v)) (width-env γ)
+  W = iₗ M.+ₘ (iᵣ M.∘ collapse D₁)
+
+  record Phase₁ (G : Graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (H : Graph D₁) : Set ℓ where
+    field
+      env-scrut    : ∀ q → G env (at (case-l₁ q)) M.≈ₘ H env (at q)
+      scrut-scrut  : ∀ p q → G (at (case-l₁ p)) (at (case-l₁ q)) M.≈ₘ H (at p) (at q)
+      env-branch   : ∀ q → G env (at (case-l₂ q))
+                     M.≈ₘ ((B q M.∘ iₗ) M.+ₘ ((B q M.∘ iᵣ) M.∘ H env (at ε)))
+      scrut-branch : ∀ p → is-ε p ≡ Bool.false → ∀ q →
+                     G (at (case-l₁ p)) (at (case-l₂ q)) M.≈ₘ ((B q M.∘ iᵣ) M.∘ H (at p) (at ε))
+      branch-branch : ∀ p q → G (at (case-l₂ p)) (at (case-l₂ q)) M.≈ₘ graph D₂ (at p) (at q)
+      branch-scrut  : ∀ p q → G (at (case-l₂ p)) (at (case-l₁ q)) M.≈ₘ M.εₘ
+      env-root      : G env (at ε) M.≈ₘ M.εₘ
+      scrut-root    : ∀ p → G (at (case-l₁ p)) (at ε) M.≈ₘ M.εₘ
+      branch-root   : ∀ p → G (at (case-l₂ p)) (at ε) M.≈ₘ edge M.I p
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (w : Path D₁) → is-ε w ≡ Bool.false →
+          Phase₁ G H → Phase₁ (hide G (at (case-l₁ w))) (hide H (at w))
+  step₁ w nw r .env-scrut q  = +ₘ-cong (r .env-scrut q) (∘-cong (r .scrut-scrut w q) (r .env-scrut w))
+  step₁ w nw r .scrut-scrut p q = +ₘ-cong (r .scrut-scrut p q) (∘-cong (r .scrut-scrut w q) (r .scrut-scrut p w))
+  step₁ w nw r .env-branch q =
+    offset-step {K = B q M.∘ iₗ} {P = B q M.∘ iᵣ}
+                (r .env-branch q) (r .scrut-branch w nw q) (r .env-scrut w)
+  step₁ w nw r .scrut-branch p np q =
+    root-step {P = B q M.∘ iᵣ} (r .scrut-branch p np q) (r .scrut-branch w nw q) (r .scrut-scrut p w)
+  step₁ {G} w nw r .branch-branch p q =
+    ≈-trans (+ₘ-cong (r .branch-branch p q) (∘-cong₂ (r .branch-scrut p w)))
+            (absorb-r (graph D₂ (at p) (at q)) (G (at (case-l₁ w)) (at (case-l₂ q))))
+  step₁ {G} w nw r .branch-scrut p q =
+    ≈-trans (+ₘ-cong (r .branch-scrut p q) (∘-cong₂ (r .branch-scrut p w)))
+            (absorb-r M.εₘ (G (at (case-l₁ w)) (at (case-l₁ q))))
+  step₁ {G} w nw r .env-root =
+    ≈-trans (+ₘ-cong (r .env-root) (∘-cong₁ (r .scrut-root w))) (absorb M.εₘ (G env (at (case-l₁ w))))
+  step₁ {G} w nw r .scrut-root p =
+    ≈-trans (+ₘ-cong (r .scrut-root p) (∘-cong₁ (r .scrut-root w)))
+            (absorb M.εₘ (G (at (case-l₁ p)) (at (case-l₁ w))))
+  step₁ {G} w nw r .branch-root p =
+    ≈-trans (+ₘ-cong (r .branch-root p) (∘-cong₁ (r .scrut-root w)))
+            (absorb (edge M.I p) (G (at (case-l₂ p)) (at (case-l₁ w))))
+
+  steps₁ : ∀ {G H} (ws : List (Path D₁)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₁ G H → Phase₁ (hide-all G (map at (map case-l₁ ws))) (hide-all H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (w ∷ ws) (nw ∷ nws) r = steps₁ ws nws (step₁ w nw r)
+
+  private
+    hh : ∀ x y → hide (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε)) (at (case-l₁ ε)) x y
+         M.≈ₘ (graph (⇓-case-l {t₂ = t₂} D₁ D₂) x y
+               M.+ₘ (graph (⇓-case-l {t₂ = t₂} D₁ D₂) (at (case-l₁ ε)) y M.∘ graph (⇓-case-l {t₂ = t₂} D₁ D₂) x (at (case-l₁ ε))))
+    hh = hide-hide-root (⇓-case-l {t₂ = t₂} D₁ D₂) (at (case-l₁ ε))
+
+    base₁ : Phase₁ (hide (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε)) (at (case-l₁ ε))) (hide (graph D₁) (at ε))
+    base₁ .env-scrut q  = hh env (at (case-l₁ q))
+    base₁ .scrut-scrut p q = hh (at (case-l₁ p)) (at (case-l₁ q))
+    base₁ .env-branch q =
+      ≈-trans (hh env (at (case-l₂ q)))
+              (+ₘ-cong ≈-refl (∘-cong₂ (≈-sym (hide-root D₁ env (at ε)))))
+    base₁ .scrut-branch p np q =
+      ≈-trans (hh (at (case-l₁ p)) (at (case-l₂ q)))
+      (≈-trans (+ₘ-cong (edge-off (B q M.∘ iᵣ) p np) ≈-refl)
+               (into-hidden D₁ (B q M.∘ iᵣ) (at p)))
+    base₁ .branch-branch p q =
+      ≈-trans (hh (at (case-l₂ p)) (at (case-l₂ q))) (absorb-r (graph D₂ (at p) (at q)) (B q M.∘ iᵣ))
+    base₁ .branch-scrut p q =
+      ≈-trans (hh (at (case-l₂ p)) (at (case-l₁ q))) (absorb-r M.εₘ (graph D₁ (at ε) (at q)))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (absorb M.εₘ (graph D₁ env (at ε)))
+    base₁ .scrut-root p = ≈-trans (hh (at (case-l₁ p)) (at ε)) (absorb M.εₘ (graph D₁ (at p) (at ε)))
+    base₁ .branch-root p =
+      ≈-trans (hh (at (case-l₂ p)) (at ε))
+              (absorb (edge M.I p) (graph (⇓-case-l {t₂ = t₂} D₁ D₂) (at (case-l₂ p)) (at (case-l₁ ε))))
+
+  record Phase₂ (G : Graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (H : Graph D₂) : Set ℓ where
+    field
+      env-branch    : ∀ q → G env (at (case-l₂ q)) M.≈ₘ (H env (at q) M.∘ W)
+      branch-branch : ∀ p q → G (at (case-l₂ p)) (at (case-l₂ q)) M.≈ₘ H (at p) (at q)
+      env-root      : G env (at ε) M.≈ₘ (H env (at ε) M.∘ W)
+      branch-root   : ∀ p → is-ε p ≡ Bool.false → G (at (case-l₂ p)) (at ε) M.≈ₘ H (at p) (at ε)
+
+  open Phase₂
+
+  step₂ : ∀ {G H} (w : Path D₂) → is-ε w ≡ Bool.false →
+          Phase₂ G H → Phase₂ (hide G (at (case-l₂ w))) (hide H (at w))
+  step₂ w nw r .env-branch q =
+    step-under {W = W} (r .env-branch q) (r .branch-branch w q) (r .env-branch w)
+  step₂ w nw r .branch-branch p q = +ₘ-cong (r .branch-branch p q) (∘-cong (r .branch-branch w q) (r .branch-branch p w))
+  step₂ w nw r .env-root =
+    step-under {W = W} (r .env-root) (r .branch-root w nw) (r .env-branch w)
+  step₂ w nw r .branch-root p np = +ₘ-cong (r .branch-root p np) (∘-cong (r .branch-root w nw) (r .branch-branch p w))
+
+  steps₂ : ∀ {G H} (ws : List (Path D₂)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₂ G H → Phase₂ (hide-all G (map at (map case-l₂ ws))) (hide-all H (map at ws))
+  steps₂ []       []         r = r
+  steps₂ (w ∷ ws) (nw ∷ nws) r = steps₂ ws nws (step₂ w nw r)
+
+  private
+    r1 : Phase₁ (hide-all (hide (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε)) (at (case-l₁ ε)))
+                          (map at (map case-l₁ (interior D₁))))
+                (hide-all (hide (graph D₁) (at ε)) (map at (interior D₁)))
+    r1 = steps₁ (interior D₁) (interior-not-root D₁) base₁
+
+    base₂ : Phase₂ (hide (hide-all (hide (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε)) (at (case-l₁ ε)))
+                                   (map at (map case-l₁ (interior D₁))))
+                         (at (case-l₂ ε)))
+                   (hide (graph D₂) (at ε))
+    base₂ .env-branch q =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .env-branch q) (factor (B q) (collapse D₁)))
+                       (∘-cong₁ (≈-trans (r1 .branch-branch ε q) (root-sink D₂ (at q)))))
+      (≈-trans (absorb (B q M.∘ W) (graph (⇓-case-l {t₂ = t₂} D₁ D₂) env (at (case-l₂ ε))))
+               (≈-sym (∘-cong₁ (hide-root D₂ env (at q)))))
+    base₂ .branch-branch p q =
+      +ₘ-cong (r1 .branch-branch p q) (∘-cong (r1 .branch-branch ε q) (r1 .branch-branch p ε))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (r1 .env-root)
+                       (∘-cong (r1 .branch-root ε) (≈-trans (r1 .env-branch ε) (factor (B ε) (collapse D₁)))))
+      (≈-trans (+ₘ-lunit (M.I M.∘ (B ε M.∘ W)))
+      (≈-trans id-left (≈-sym (∘-cong₁ (hide-root D₂ env (at ε))))))
+    base₂ .branch-root p np =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .branch-root p) (edge-off M.I p np))
+                       (∘-cong (r1 .branch-root ε) (r1 .branch-branch p ε)))
+      (≈-trans (into-hidden D₂ M.I (at p)) id-left)
+
+  -- Collapsing a agree-branch derivation composes the branch collapse with the substitution.
+  agree : collapse (⇓-case-l {t₂ = t₂} D₁ D₂)
+             M.≈ₘ (collapse D₂ M.∘ W)
+  agree =
+    ≈-trans (≈-of-≡ plumb) (steps₂ (interior D₂) (interior-not-root D₂) base₂ .env-root)
+    where
+      plumb : hide-all (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε))
+                       (map at (map case-l₁ (paths D₁) ++ map case-l₂ (paths D₂))) env (at ε)
+              ≡ hide-all (hide-all (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε)) (map at (map case-l₁ (paths D₁))))
+                         (map at (map case-l₂ (paths D₂))) env (at ε)
+      plumb =
+        ≡-trans (≡-cong (λ L → hide-all (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε)) L env (at ε))
+                        (map-++ at (map case-l₁ (paths D₁)) (map case-l₂ (paths D₂))))
+                (≡-cong (λ Gg → Gg env (at ε))
+                        (hide-all-++ (hide (graph (⇓-case-l {t₂ = t₂} D₁ D₂)) (at ε))
+                                     (map at (map case-l₁ (paths D₁)))
+                                     (map at (map case-l₂ (paths D₂)))))
+
+-- Right case branch, evaluated under the extended environment. Phase one folds the scrutinee: the branch's rewired columns carry the env slice
+-- plus the routed slice through the evolving scrutinee collapse. Phase two folds the branch with
+-- its env columns composed with the substitution W.
+module CaseR {Γ τ₁ τ₂ τ} {γ : Env Γ} {ts : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+            {v : Val τ₂} {u : Val τ}
+            {R : width-env γ ⇒ width v} {S : width-env (γ · v) ⇒ width u}
+            {D₁ : γ , ts ⇓ inr v [ R ]} {D₂ : γ · v , t₂ ⇓ u [ S ]} where
+
+  iₗ : M.Matrix (width-env (γ · v)) (width-env γ)
+  iₗ = M.in₁ {width-env γ} {width v}
+
+  iᵣ : M.Matrix (width-env (γ · v)) (width v)
+  iᵣ = M.in₂ {width-env γ} {width v}
+
+  B : (q : Path D₂) → M.Matrix (width-at q) (width-env (γ · v))
+  B q = graph D₂ env (at q)
+
+  W : M.Matrix (width-env (γ · v)) (width-env γ)
+  W = iₗ M.+ₘ (iᵣ M.∘ collapse D₁)
+
+  record Phase₁ (G : Graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (H : Graph D₁) : Set ℓ where
+    field
+      env-scrut    : ∀ q → G env (at (case-r₁ q)) M.≈ₘ H env (at q)
+      scrut-scrut  : ∀ p q → G (at (case-r₁ p)) (at (case-r₁ q)) M.≈ₘ H (at p) (at q)
+      env-branch   : ∀ q → G env (at (case-r₂ q))
+                     M.≈ₘ ((B q M.∘ iₗ) M.+ₘ ((B q M.∘ iᵣ) M.∘ H env (at ε)))
+      scrut-branch : ∀ p → is-ε p ≡ Bool.false → ∀ q →
+                     G (at (case-r₁ p)) (at (case-r₂ q)) M.≈ₘ ((B q M.∘ iᵣ) M.∘ H (at p) (at ε))
+      branch-branch : ∀ p q → G (at (case-r₂ p)) (at (case-r₂ q)) M.≈ₘ graph D₂ (at p) (at q)
+      branch-scrut  : ∀ p q → G (at (case-r₂ p)) (at (case-r₁ q)) M.≈ₘ M.εₘ
+      env-root      : G env (at ε) M.≈ₘ M.εₘ
+      scrut-root    : ∀ p → G (at (case-r₁ p)) (at ε) M.≈ₘ M.εₘ
+      branch-root   : ∀ p → G (at (case-r₂ p)) (at ε) M.≈ₘ edge M.I p
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (w : Path D₁) → is-ε w ≡ Bool.false →
+          Phase₁ G H → Phase₁ (hide G (at (case-r₁ w))) (hide H (at w))
+  step₁ w nw r .env-scrut q  = +ₘ-cong (r .env-scrut q) (∘-cong (r .scrut-scrut w q) (r .env-scrut w))
+  step₁ w nw r .scrut-scrut p q = +ₘ-cong (r .scrut-scrut p q) (∘-cong (r .scrut-scrut w q) (r .scrut-scrut p w))
+  step₁ w nw r .env-branch q =
+    offset-step {K = B q M.∘ iₗ} {P = B q M.∘ iᵣ}
+                (r .env-branch q) (r .scrut-branch w nw q) (r .env-scrut w)
+  step₁ w nw r .scrut-branch p np q =
+    root-step {P = B q M.∘ iᵣ} (r .scrut-branch p np q) (r .scrut-branch w nw q) (r .scrut-scrut p w)
+  step₁ {G} w nw r .branch-branch p q =
+    ≈-trans (+ₘ-cong (r .branch-branch p q) (∘-cong₂ (r .branch-scrut p w)))
+            (absorb-r (graph D₂ (at p) (at q)) (G (at (case-r₁ w)) (at (case-r₂ q))))
+  step₁ {G} w nw r .branch-scrut p q =
+    ≈-trans (+ₘ-cong (r .branch-scrut p q) (∘-cong₂ (r .branch-scrut p w)))
+            (absorb-r M.εₘ (G (at (case-r₁ w)) (at (case-r₁ q))))
+  step₁ {G} w nw r .env-root =
+    ≈-trans (+ₘ-cong (r .env-root) (∘-cong₁ (r .scrut-root w))) (absorb M.εₘ (G env (at (case-r₁ w))))
+  step₁ {G} w nw r .scrut-root p =
+    ≈-trans (+ₘ-cong (r .scrut-root p) (∘-cong₁ (r .scrut-root w)))
+            (absorb M.εₘ (G (at (case-r₁ p)) (at (case-r₁ w))))
+  step₁ {G} w nw r .branch-root p =
+    ≈-trans (+ₘ-cong (r .branch-root p) (∘-cong₁ (r .scrut-root w)))
+            (absorb (edge M.I p) (G (at (case-r₂ p)) (at (case-r₁ w))))
+
+  steps₁ : ∀ {G H} (ws : List (Path D₁)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₁ G H → Phase₁ (hide-all G (map at (map case-r₁ ws))) (hide-all H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (w ∷ ws) (nw ∷ nws) r = steps₁ ws nws (step₁ w nw r)
+
+  private
+    hh : ∀ x y → hide (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε)) (at (case-r₁ ε)) x y
+         M.≈ₘ (graph (⇓-case-r {t₁ = t₁} D₁ D₂) x y
+               M.+ₘ (graph (⇓-case-r {t₁ = t₁} D₁ D₂) (at (case-r₁ ε)) y M.∘ graph (⇓-case-r {t₁ = t₁} D₁ D₂) x (at (case-r₁ ε))))
+    hh = hide-hide-root (⇓-case-r {t₁ = t₁} D₁ D₂) (at (case-r₁ ε))
+
+    base₁ : Phase₁ (hide (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε)) (at (case-r₁ ε))) (hide (graph D₁) (at ε))
+    base₁ .env-scrut q  = hh env (at (case-r₁ q))
+    base₁ .scrut-scrut p q = hh (at (case-r₁ p)) (at (case-r₁ q))
+    base₁ .env-branch q =
+      ≈-trans (hh env (at (case-r₂ q)))
+              (+ₘ-cong ≈-refl (∘-cong₂ (≈-sym (hide-root D₁ env (at ε)))))
+    base₁ .scrut-branch p np q =
+      ≈-trans (hh (at (case-r₁ p)) (at (case-r₂ q)))
+      (≈-trans (+ₘ-cong (edge-off (B q M.∘ iᵣ) p np) ≈-refl)
+               (into-hidden D₁ (B q M.∘ iᵣ) (at p)))
+    base₁ .branch-branch p q =
+      ≈-trans (hh (at (case-r₂ p)) (at (case-r₂ q))) (absorb-r (graph D₂ (at p) (at q)) (B q M.∘ iᵣ))
+    base₁ .branch-scrut p q =
+      ≈-trans (hh (at (case-r₂ p)) (at (case-r₁ q))) (absorb-r M.εₘ (graph D₁ (at ε) (at q)))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (absorb M.εₘ (graph D₁ env (at ε)))
+    base₁ .scrut-root p = ≈-trans (hh (at (case-r₁ p)) (at ε)) (absorb M.εₘ (graph D₁ (at p) (at ε)))
+    base₁ .branch-root p =
+      ≈-trans (hh (at (case-r₂ p)) (at ε))
+              (absorb (edge M.I p) (graph (⇓-case-r {t₁ = t₁} D₁ D₂) (at (case-r₂ p)) (at (case-r₁ ε))))
+
+  record Phase₂ (G : Graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (H : Graph D₂) : Set ℓ where
+    field
+      env-branch    : ∀ q → G env (at (case-r₂ q)) M.≈ₘ (H env (at q) M.∘ W)
+      branch-branch : ∀ p q → G (at (case-r₂ p)) (at (case-r₂ q)) M.≈ₘ H (at p) (at q)
+      env-root      : G env (at ε) M.≈ₘ (H env (at ε) M.∘ W)
+      branch-root   : ∀ p → is-ε p ≡ Bool.false → G (at (case-r₂ p)) (at ε) M.≈ₘ H (at p) (at ε)
+
+  open Phase₂
+
+  step₂ : ∀ {G H} (w : Path D₂) → is-ε w ≡ Bool.false →
+          Phase₂ G H → Phase₂ (hide G (at (case-r₂ w))) (hide H (at w))
+  step₂ w nw r .env-branch q =
+    step-under {W = W} (r .env-branch q) (r .branch-branch w q) (r .env-branch w)
+  step₂ w nw r .branch-branch p q = +ₘ-cong (r .branch-branch p q) (∘-cong (r .branch-branch w q) (r .branch-branch p w))
+  step₂ w nw r .env-root =
+    step-under {W = W} (r .env-root) (r .branch-root w nw) (r .env-branch w)
+  step₂ w nw r .branch-root p np = +ₘ-cong (r .branch-root p np) (∘-cong (r .branch-root w nw) (r .branch-branch p w))
+
+  steps₂ : ∀ {G H} (ws : List (Path D₂)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₂ G H → Phase₂ (hide-all G (map at (map case-r₂ ws))) (hide-all H (map at ws))
+  steps₂ []       []         r = r
+  steps₂ (w ∷ ws) (nw ∷ nws) r = steps₂ ws nws (step₂ w nw r)
+
+  private
+    r1 : Phase₁ (hide-all (hide (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε)) (at (case-r₁ ε)))
+                          (map at (map case-r₁ (interior D₁))))
+                (hide-all (hide (graph D₁) (at ε)) (map at (interior D₁)))
+    r1 = steps₁ (interior D₁) (interior-not-root D₁) base₁
+
+    base₂ : Phase₂ (hide (hide-all (hide (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε)) (at (case-r₁ ε)))
+                                   (map at (map case-r₁ (interior D₁))))
+                         (at (case-r₂ ε)))
+                   (hide (graph D₂) (at ε))
+    base₂ .env-branch q =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .env-branch q) (factor (B q) (collapse D₁)))
+                       (∘-cong₁ (≈-trans (r1 .branch-branch ε q) (root-sink D₂ (at q)))))
+      (≈-trans (absorb (B q M.∘ W) (graph (⇓-case-r {t₁ = t₁} D₁ D₂) env (at (case-r₂ ε))))
+               (≈-sym (∘-cong₁ (hide-root D₂ env (at q)))))
+    base₂ .branch-branch p q =
+      +ₘ-cong (r1 .branch-branch p q) (∘-cong (r1 .branch-branch ε q) (r1 .branch-branch p ε))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (r1 .env-root)
+                       (∘-cong (r1 .branch-root ε) (≈-trans (r1 .env-branch ε) (factor (B ε) (collapse D₁)))))
+      (≈-trans (+ₘ-lunit (M.I M.∘ (B ε M.∘ W)))
+      (≈-trans id-left (≈-sym (∘-cong₁ (hide-root D₂ env (at ε))))))
+    base₂ .branch-root p np =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .branch-root p) (edge-off M.I p np))
+                       (∘-cong (r1 .branch-root ε) (r1 .branch-branch p ε)))
+      (≈-trans (into-hidden D₂ M.I (at p)) id-left)
+
+  -- Collapsing a agree-branch derivation composes the branch collapse with the substitution.
+  agree : collapse (⇓-case-r {t₁ = t₁} D₁ D₂)
+             M.≈ₘ (collapse D₂ M.∘ W)
+  agree =
+    ≈-trans (≈-of-≡ plumb) (steps₂ (interior D₂) (interior-not-root D₂) base₂ .env-root)
+    where
+      plumb : hide-all (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε))
+                       (map at (map case-r₁ (paths D₁) ++ map case-r₂ (paths D₂))) env (at ε)
+              ≡ hide-all (hide-all (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε)) (map at (map case-r₁ (paths D₁))))
+                         (map at (map case-r₂ (paths D₂))) env (at ε)
+      plumb =
+        ≡-trans (≡-cong (λ L → hide-all (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε)) L env (at ε))
+                        (map-++ at (map case-r₁ (paths D₁)) (map case-r₂ (paths D₂))))
+                (≡-cong (λ Gg → Gg env (at ε))
+                        (hide-all-++ (hide (graph (⇓-case-r {t₁ = t₁} D₁ D₂)) (at ε))
+                                     (map at (map case-r₁ (paths D₁)))
+                                     (map at (map case-r₂ (paths D₂)))))
+
+-- Regroup a fully rewired column: both slices factor through the assembled substitution.
+factor₂ : ∀ {m g wγ wv} (B : M.Matrix m (wγ Data.Nat.+ wv))
+          (C₁ : M.Matrix wγ g) (C₂ : M.Matrix wv g) →
+          (((B M.∘ M.in₁) M.∘ C₁) M.+ₘ ((B M.∘ M.in₂) M.∘ C₂))
+          M.≈ₘ (B M.∘ ((M.in₁ M.∘ C₁) M.+ₘ (M.in₂ M.∘ C₂)))
+factor₂ B C₁ C₂ =
+  ≈-trans (+ₘ-cong (assoc B M.in₁ C₁) (assoc B M.in₂ C₂))
+          (≈-sym (M.comp-bilinear₂ B (M.in₁ M.∘ C₁) (M.in₂ M.∘ C₂)))
+
+-- Application: the function and argument premises fold in turn, the body's rewired columns
+-- accumulating each collapse through its slice; the body then folds under the substitution W.
+module App {Γ Γ' σ τ} {γ : Env Γ} {γ' : Env Γ'} {ts : Γ ⊢ σ [→] τ} {tt : Γ ⊢ σ}
+           {tb : Γ' ▸ σ ⊢ τ} {v : Val σ} {u : Val τ}
+           {R : width-env γ ⇒ width-env γ'} {S : width-env γ ⇒ width v}
+           {T : width-env (γ' · v) ⇒ width u}
+           {D₁ : γ , ts ⇓ clo γ' tb [ R ]} {D₂ : γ , tt ⇓ v [ S ]}
+           {D₃ : γ' · v , tb ⇓ u [ T ]} where
+
+  iₗ : M.Matrix (width-env (γ' · v)) (width-env γ')
+  iₗ = M.in₁ {width-env γ'} {width v}
+
+  iᵣ : M.Matrix (width-env (γ' · v)) (width v)
+  iᵣ = M.in₂ {width-env γ'} {width v}
+
+  B : (q : Path D₃) → M.Matrix (width-at q) (width-env (γ' · v))
+  B q = graph D₃ env (at q)
+
+  W : M.Matrix (width-env (γ' · v)) (width-env γ)
+  W = (iₗ M.∘ collapse D₁) M.+ₘ (iᵣ M.∘ collapse D₂)
+
+  record Phase₁ (G : Graph (⇓-app D₁ D₂ D₃)) (H : Graph D₁) : Set ℓ where
+    field
+      env-fun   : ∀ q → G env (at (app₁ q)) M.≈ₘ H env (at q)
+      fun-fun   : ∀ p q → G (at (app₁ p)) (at (app₁ q)) M.≈ₘ H (at p) (at q)
+      env-arg   : ∀ q → G env (at (app₂ q)) M.≈ₘ graph D₂ env (at q)
+      arg-arg   : ∀ p q → G (at (app₂ p)) (at (app₂ q)) M.≈ₘ graph D₂ (at p) (at q)
+      fun-arg   : ∀ p q → G (at (app₁ p)) (at (app₂ q)) M.≈ₘ M.εₘ
+      arg-fun   : ∀ p q → G (at (app₂ p)) (at (app₁ q)) M.≈ₘ M.εₘ
+      env-body  : ∀ q → G env (at (app₃ q)) M.≈ₘ ((B q M.∘ iₗ) M.∘ H env (at ε))
+      fun-body  : ∀ p → is-ε p ≡ Bool.false → ∀ q →
+                  G (at (app₁ p)) (at (app₃ q)) M.≈ₘ ((B q M.∘ iₗ) M.∘ H (at p) (at ε))
+      arg-body  : ∀ p q → G (at (app₂ p)) (at (app₃ q)) M.≈ₘ edge (B q M.∘ iᵣ) p
+      body-body : ∀ p q → G (at (app₃ p)) (at (app₃ q)) M.≈ₘ graph D₃ (at p) (at q)
+      body-fun  : ∀ p q → G (at (app₃ p)) (at (app₁ q)) M.≈ₘ M.εₘ
+      body-arg  : ∀ p q → G (at (app₃ p)) (at (app₂ q)) M.≈ₘ M.εₘ
+      env-root  : G env (at ε) M.≈ₘ M.εₘ
+      fun-root  : ∀ p → G (at (app₁ p)) (at ε) M.≈ₘ M.εₘ
+      arg-root  : ∀ p → G (at (app₂ p)) (at ε) M.≈ₘ M.εₘ
+      body-root : ∀ p → G (at (app₃ p)) (at ε) M.≈ₘ edge M.I p
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (w : Path D₁) → is-ε w ≡ Bool.false →
+          Phase₁ G H → Phase₁ (hide G (at (app₁ w))) (hide H (at w))
+  step₁ w nw r .env-fun q  = +ₘ-cong (r .env-fun q) (∘-cong (r .fun-fun w q) (r .env-fun w))
+  step₁ w nw r .fun-fun p q = +ₘ-cong (r .fun-fun p q) (∘-cong (r .fun-fun w q) (r .fun-fun p w))
+  step₁ {G} w nw r .env-arg q =
+    ≈-trans (+ₘ-cong (r .env-arg q) (∘-cong₁ (r .fun-arg w q)))
+            (absorb (graph D₂ env (at q)) (G env (at (app₁ w))))
+  step₁ {G} w nw r .arg-arg p q =
+    ≈-trans (+ₘ-cong (r .arg-arg p q) (∘-cong₁ (r .fun-arg w q)))
+            (absorb (graph D₂ (at p) (at q)) (G (at (app₂ p)) (at (app₁ w))))
+  step₁ {G} w nw r .fun-arg p q =
+    ≈-trans (+ₘ-cong (r .fun-arg p q) (∘-cong₁ (r .fun-arg w q)))
+            (absorb M.εₘ (G (at (app₁ p)) (at (app₁ w))))
+  step₁ {G} w nw r .arg-fun p q =
+    ≈-trans (+ₘ-cong (r .arg-fun p q) (∘-cong₂ (r .arg-fun p w)))
+            (absorb-r M.εₘ (G (at (app₁ w)) (at (app₁ q))))
+  step₁ w nw r .env-body q =
+    root-step {P = B q M.∘ iₗ} (r .env-body q) (r .fun-body w nw q) (r .env-fun w)
+  step₁ w nw r .fun-body p np q =
+    root-step {P = B q M.∘ iₗ} (r .fun-body p np q) (r .fun-body w nw q) (r .fun-fun p w)
+  step₁ {G} w nw r .arg-body p q =
+    ≈-trans (+ₘ-cong (r .arg-body p q) (∘-cong₂ (r .arg-fun p w)))
+            (absorb-r (edge (B q M.∘ iᵣ) p) (G (at (app₁ w)) (at (app₃ q))))
+  step₁ {G} w nw r .body-body p q =
+    ≈-trans (+ₘ-cong (r .body-body p q) (∘-cong₂ (r .body-fun p w)))
+            (absorb-r (graph D₃ (at p) (at q)) (G (at (app₁ w)) (at (app₃ q))))
+  step₁ {G} w nw r .body-fun p q =
+    ≈-trans (+ₘ-cong (r .body-fun p q) (∘-cong₂ (r .body-fun p w)))
+            (absorb-r M.εₘ (G (at (app₁ w)) (at (app₁ q))))
+  step₁ {G} w nw r .body-arg p q =
+    ≈-trans (+ₘ-cong (r .body-arg p q) (∘-cong₁ (r .fun-arg w q)))
+            (absorb M.εₘ (G (at (app₃ p)) (at (app₁ w))))
+  step₁ {G} w nw r .env-root =
+    ≈-trans (+ₘ-cong (r .env-root) (∘-cong₁ (r .fun-root w))) (absorb M.εₘ (G env (at (app₁ w))))
+  step₁ {G} w nw r .fun-root p =
+    ≈-trans (+ₘ-cong (r .fun-root p) (∘-cong₁ (r .fun-root w)))
+            (absorb M.εₘ (G (at (app₁ p)) (at (app₁ w))))
+  step₁ {G} w nw r .arg-root p =
+    ≈-trans (+ₘ-cong (r .arg-root p) (∘-cong₁ (r .fun-root w)))
+            (absorb M.εₘ (G (at (app₂ p)) (at (app₁ w))))
+  step₁ {G} w nw r .body-root p =
+    ≈-trans (+ₘ-cong (r .body-root p) (∘-cong₁ (r .fun-root w)))
+            (absorb (edge M.I p) (G (at (app₃ p)) (at (app₁ w))))
+
+  steps₁ : ∀ {G H} (ws : List (Path D₁)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₁ G H → Phase₁ (hide-all G (map at (map app₁ ws))) (hide-all H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (w ∷ ws) (nw ∷ nws) r = steps₁ ws nws (step₁ w nw r)
+
+  private
+    hh : ∀ x y → hide (hide (graph (⇓-app D₁ D₂ D₃)) (at ε)) (at (app₁ ε)) x y
+         M.≈ₘ (graph (⇓-app D₁ D₂ D₃) x y
+               M.+ₘ (graph (⇓-app D₁ D₂ D₃) (at (app₁ ε)) y
+                     M.∘ graph (⇓-app D₁ D₂ D₃) x (at (app₁ ε))))
+    hh = hide-hide-root (⇓-app D₁ D₂ D₃) (at (app₁ ε))
+
+    base₁ : Phase₁ (hide (hide (graph (⇓-app D₁ D₂ D₃)) (at ε)) (at (app₁ ε)))
+                   (hide (graph D₁) (at ε))
+    base₁ .env-fun q  = hh env (at (app₁ q))
+    base₁ .fun-fun p q = hh (at (app₁ p)) (at (app₁ q))
+    base₁ .env-arg q =
+      ≈-trans (hh env (at (app₂ q))) (absorb (graph D₂ env (at q)) (graph D₁ env (at ε)))
+    base₁ .arg-arg p q =
+      ≈-trans (hh (at (app₂ p)) (at (app₂ q)))
+              (absorb (graph D₂ (at p) (at q))
+                      (graph (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₁ ε))))
+    base₁ .fun-arg p q =
+      ≈-trans (hh (at (app₁ p)) (at (app₂ q))) (absorb M.εₘ (graph D₁ (at p) (at ε)))
+    base₁ .arg-fun p q =
+      ≈-trans (hh (at (app₂ p)) (at (app₁ q))) (absorb-r M.εₘ (graph D₁ (at ε) (at q)))
+    base₁ .env-body q =
+      ≈-trans (hh env (at (app₃ q))) (into-hidden D₁ (B q M.∘ iₗ) env)
+    base₁ .fun-body p np q =
+      ≈-trans (hh (at (app₁ p)) (at (app₃ q)))
+      (≈-trans (+ₘ-cong (edge-off (B q M.∘ iₗ) p np) ≈-refl)
+               (into-hidden D₁ (B q M.∘ iₗ) (at p)))
+    base₁ .arg-body p q =
+      ≈-trans (hh (at (app₂ p)) (at (app₃ q)))
+              (absorb-r (edge (B q M.∘ iᵣ) p) (B q M.∘ iₗ))
+    base₁ .body-body p q =
+      ≈-trans (hh (at (app₃ p)) (at (app₃ q)))
+              (absorb-r (graph D₃ (at p) (at q)) (B q M.∘ iₗ))
+    base₁ .body-fun p q =
+      ≈-trans (hh (at (app₃ p)) (at (app₁ q))) (absorb-r M.εₘ (graph D₁ (at ε) (at q)))
+    base₁ .body-arg p q =
+      ≈-trans (hh (at (app₃ p)) (at (app₂ q)))
+              (absorb M.εₘ (graph (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at (app₁ ε))))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (absorb M.εₘ (graph D₁ env (at ε)))
+    base₁ .fun-root p = ≈-trans (hh (at (app₁ p)) (at ε)) (absorb M.εₘ (graph D₁ (at p) (at ε)))
+    base₁ .arg-root p =
+      ≈-trans (hh (at (app₂ p)) (at ε))
+              (absorb M.εₘ (graph (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₁ ε))))
+    base₁ .body-root p =
+      ≈-trans (hh (at (app₃ p)) (at ε))
+              (absorb (edge M.I p) (graph (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at (app₁ ε))))
+
+    PA : Graph (⇓-app D₁ D₂ D₃)
+    PA = hide-all (hide (hide (graph (⇓-app D₁ D₂ D₃)) (at ε)) (at (app₁ ε)))
+                  (map at (map app₁ (interior D₁)))
+
+    rA : Phase₁ PA (hide-all (hide (graph D₁) (at ε)) (map at (interior D₁)))
+    rA = steps₁ (interior D₁) (interior-not-root D₁) base₁
+
+  record Phase₂ (G : Graph (⇓-app D₁ D₂ D₃)) (H : Graph D₂) : Set ℓ where
+    field
+      env-arg   : ∀ q → G env (at (app₂ q)) M.≈ₘ H env (at q)
+      arg-arg   : ∀ p q → G (at (app₂ p)) (at (app₂ q)) M.≈ₘ H (at p) (at q)
+      env-body  : ∀ q → G env (at (app₃ q))
+                  M.≈ₘ (((B q M.∘ iₗ) M.∘ collapse D₁) M.+ₘ ((B q M.∘ iᵣ) M.∘ H env (at ε)))
+      arg-body  : ∀ p → is-ε p ≡ Bool.false → ∀ q →
+                  G (at (app₂ p)) (at (app₃ q)) M.≈ₘ ((B q M.∘ iᵣ) M.∘ H (at p) (at ε))
+      body-body : ∀ p q → G (at (app₃ p)) (at (app₃ q)) M.≈ₘ graph D₃ (at p) (at q)
+      body-arg  : ∀ p q → G (at (app₃ p)) (at (app₂ q)) M.≈ₘ M.εₘ
+      env-root  : G env (at ε) M.≈ₘ M.εₘ
+      arg-root  : ∀ p → G (at (app₂ p)) (at ε) M.≈ₘ M.εₘ
+      body-root : ∀ p → G (at (app₃ p)) (at ε) M.≈ₘ edge M.I p
+
+  open Phase₂
+
+  step₂ : ∀ {G H} (w : Path D₂) → is-ε w ≡ Bool.false →
+          Phase₂ G H → Phase₂ (hide G (at (app₂ w))) (hide H (at w))
+  step₂ w nw r .env-arg q  = +ₘ-cong (r .env-arg q) (∘-cong (r .arg-arg w q) (r .env-arg w))
+  step₂ w nw r .arg-arg p q = +ₘ-cong (r .arg-arg p q) (∘-cong (r .arg-arg w q) (r .arg-arg p w))
+  step₂ w nw r .env-body q =
+    offset-step {K = (B q M.∘ iₗ) M.∘ collapse D₁} {P = B q M.∘ iᵣ}
+                (r .env-body q) (r .arg-body w nw q) (r .env-arg w)
+  step₂ w nw r .arg-body p np q =
+    root-step {P = B q M.∘ iᵣ} (r .arg-body p np q) (r .arg-body w nw q) (r .arg-arg p w)
+  step₂ {G} w nw r .body-body p q =
+    ≈-trans (+ₘ-cong (r .body-body p q) (∘-cong₂ (r .body-arg p w)))
+            (absorb-r (graph D₃ (at p) (at q)) (G (at (app₂ w)) (at (app₃ q))))
+  step₂ {G} w nw r .body-arg p q =
+    ≈-trans (+ₘ-cong (r .body-arg p q) (∘-cong₂ (r .body-arg p w)))
+            (absorb-r M.εₘ (G (at (app₂ w)) (at (app₂ q))))
+  step₂ {G} w nw r .env-root =
+    ≈-trans (+ₘ-cong (r .env-root) (∘-cong₁ (r .arg-root w))) (absorb M.εₘ (G env (at (app₂ w))))
+  step₂ {G} w nw r .arg-root p =
+    ≈-trans (+ₘ-cong (r .arg-root p) (∘-cong₁ (r .arg-root w)))
+            (absorb M.εₘ (G (at (app₂ p)) (at (app₂ w))))
+  step₂ {G} w nw r .body-root p =
+    ≈-trans (+ₘ-cong (r .body-root p) (∘-cong₁ (r .arg-root w)))
+            (absorb (edge M.I p) (G (at (app₃ p)) (at (app₂ w))))
+
+  steps₂ : ∀ {G H} (ws : List (Path D₂)) → All (λ w → is-ε w ≡ Bool.false) ws →
+           Phase₂ G H → Phase₂ (hide-all G (map at (map app₂ ws))) (hide-all H (map at ws))
+  steps₂ []       []         r = r
+  steps₂ (w ∷ ws) (nw ∷ nws) r = steps₂ ws nws (step₂ w nw r)
+
+  private
+    base₂ : Phase₂ (hide PA (at (app₂ ε))) (hide (graph D₂) (at ε))
+    base₂ .env-arg q = +ₘ-cong (rA .env-arg q) (∘-cong (rA .arg-arg ε q) (rA .env-arg ε))
+    base₂ .arg-arg p q = +ₘ-cong (rA .arg-arg p q) (∘-cong (rA .arg-arg ε q) (rA .arg-arg p ε))
+    base₂ .env-body q =
+      ≈-trans (+ₘ-cong (rA .env-body q) (∘-cong (rA .arg-body ε q) (rA .env-arg ε)))
+              (+ₘ-cong ≈-refl (∘-cong₂ (≈-sym (hide-root D₂ env (at ε)))))
+    base₂ .arg-body p np q =
+      ≈-trans (+ₘ-cong (≈-trans (rA .arg-body p q) (edge-off (B q M.∘ iᵣ) p np))
+                       (∘-cong (rA .arg-body ε q) (rA .arg-arg p ε)))
+              (into-hidden D₂ (B q M.∘ iᵣ) (at p))
+    base₂ .body-body p q =
+      ≈-trans (+ₘ-cong (rA .body-body p q) (∘-cong (rA .arg-body ε q) (rA .body-arg p ε)))
+              (absorb-r (graph D₃ (at p) (at q)) (B q M.∘ iᵣ))
+    base₂ .body-arg p q =
+      ≈-trans (+ₘ-cong (rA .body-arg p q) (∘-cong (rA .arg-arg ε q) (rA .body-arg p ε)))
+              (absorb-r M.εₘ (graph D₂ (at ε) (at q)))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (rA .env-root) (∘-cong₁ (rA .arg-root ε)))
+              (absorb M.εₘ (PA env (at (app₂ ε))))
+    base₂ .arg-root p =
+      ≈-trans (+ₘ-cong (rA .arg-root p) (∘-cong₁ (rA .arg-root ε)))
+              (absorb M.εₘ (PA (at (app₂ p)) (at (app₂ ε))))
+    base₂ .body-root p =
+      ≈-trans (+ₘ-cong (rA .body-root p) (∘-cong₁ (rA .arg-root ε)))
+              (absorb (edge M.I p) (PA (at (app₃ p)) (at (app₂ ε))))
+
+    PB : Graph (⇓-app D₁ D₂ D₃)
+    PB = hide-all (hide PA (at (app₂ ε))) (map at (map app₂ (interior D₂)))
+
+    rB : Phase₂ PB (hide-all (hide (graph D₂) (at ε)) (map at (interior D₂)))
+    rB = steps₂ (interior D₂) (interior-not-root D₂) base₂
+
+  record Phase₃ (G : Graph (⇓-app D₁ D₂ D₃)) (H : Graph D₃) : Set ℓ where
+    field
+      env-body  : ∀ q → G env (at (app₃ q)) M.≈ₘ (H env (at q) M.∘ W)
+      body-body : ∀ p q → G (at (app₃ p)) (at (app₃ q)) M.≈ₘ H (at p) (at q)
+      env-root  : G env (at ε) M.≈ₘ (H env (at ε) M.∘ W)
+      body-root : ∀ p → is-ε p ≡ Bool.false → G (at (app₃ p)) (at ε) M.≈ₘ H (at p) (at ε)
+
+  open Phase₃
+
+  step₃ : ∀ {G H} (w : Path D₃) → is-ε w ≡ Bool.false →
+          Phase₃ G H → Phase₃ (hide G (at (app₃ w))) (hide H (at w))
+  step₃ w nw r .env-body q =
+    step-under {W = W} (r .env-body q) (r .body-body w q) (r .env-body w)
+  step₃ w nw r .body-body p q = +ₘ-cong (r .body-body p q) (∘-cong (r .body-body w q) (r .body-body p w))
+  step₃ w nw r .env-root = step-under {W = W} (r .env-root) (r .body-root w nw) (r .env-body w)
+  step₃ w nw r .body-root p np = +ₘ-cong (r .body-root p np) (∘-cong (r .body-root w nw) (r .body-body p w))
+
+  steps₃ : ∀ {G H} (ws : List (Path D₃)) → All (λ w → is-ε w ≡ Bool.false) ws →
+          Phase₃ G H → Phase₃ (hide-all G (map at (map app₃ ws))) (hide-all H (map at ws))
+  steps₃ []       []         r = r
+  steps₃ (w ∷ ws) (nw ∷ nws) r = steps₃ ws nws (step₃ w nw r)
+
+  private
+    base₃ : Phase₃ (hide PB (at (app₃ ε))) (hide (graph D₃) (at ε))
+    base₃ .env-body q =
+      ≈-trans (+ₘ-cong (≈-trans (rB .env-body q) (factor₂ (B q) (collapse D₁) (collapse D₂)))
+                       (∘-cong₁ (≈-trans (rB .body-body ε q) (root-sink D₃ (at q)))))
+      (≈-trans (absorb (B q M.∘ W) (PB env (at (app₃ ε))))
+               (≈-sym (∘-cong₁ (hide-root D₃ env (at q)))))
+    base₃ .body-body p q =
+      +ₘ-cong (rB .body-body p q) (∘-cong (rB .body-body ε q) (rB .body-body p ε))
+    base₃ .env-root =
+      ≈-trans (+ₘ-cong (rB .env-root)
+                       (∘-cong (rB .body-root ε)
+                               (≈-trans (rB .env-body ε) (factor₂ (B ε) (collapse D₁) (collapse D₂)))))
+      (≈-trans (+ₘ-lunit (M.I M.∘ (B ε M.∘ W)))
+      (≈-trans id-left (≈-sym (∘-cong₁ (hide-root D₃ env (at ε))))))
+    base₃ .body-root p np =
+      ≈-trans (+ₘ-cong (≈-trans (rB .body-root p) (edge-off M.I p np))
+                       (∘-cong (rB .body-root ε) (rB .body-body p ε)))
+      (≈-trans (into-hidden D₃ M.I (at p)) id-left)
+
+  -- Collapsing an application composes the body's collapse with the assembled substitution.
+  agree : collapse (⇓-app D₁ D₂ D₃) M.≈ₘ (collapse D₃ M.∘ W)
+  agree =
+    ≈-trans (≈-of-≡ plumb) (steps₃ (interior D₃) (interior-not-root D₃) base₃ .env-root)
+    where
+      A₁ = hide (graph (⇓-app D₁ D₂ D₃)) (at ε)
+      L₁ = map app₁ (paths D₁)
+      L₂ = map app₂ (paths D₂)
+      L₃ = map app₃ (paths D₃)
+      plumb : hide-all A₁ (map at (L₁ ++ L₂ ++ L₃)) env (at ε)
+              ≡ hide-all (hide-all (hide-all A₁ (map at L₁)) (map at L₂)) (map at L₃) env (at ε)
+      plumb =
+        ≡-trans (≡-cong (λ L → hide-all A₁ L env (at ε))
+                        (≡-trans (map-++ at L₁ (L₂ ++ L₃))
+                                 (≡-cong (λ z → map at L₁ ++ z) (map-++ at L₂ L₃))))
+        (≡-trans (≡-cong (λ Gg → Gg env (at ε))
+                         (hide-all-++ A₁ (map at L₁) (map at L₂ ++ map at L₃)))
+                 (≡-cong (λ Gg → Gg env (at ε))
+                         (hide-all-++ (hide-all A₁ (map at L₁)) (map at L₂) (map at L₃))))
+
+-- Operand lists: the S-family analogues of the root and edge lemmas.
+root-sink-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+              (D₁ : γ , Ms ⇓s vs [ R ]) (y : VertexS D₁) → graphS D₁ (at ε) y M.≈ₘ M.εₘ
+root-sink-s []       env    i j = refl {x = two.O}
+root-sink-s []       (at ε) i j = refl {x = two.O}
+root-sink-s (D ∷ D₁) env    i j = refl {x = two.O}
+root-sink-s (D ∷ D₁) (at ε) i j = refl {x = two.O}
+root-sink-s (D ∷ D₁) (at (hd q)) i j = refl {x = two.O}
+root-sink-s (D ∷ D₁) (at (tl q)) i j = refl {x = two.O}
+
+hide-root-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+              (D₁ : γ , Ms ⇓s vs [ R ]) (x y : VertexS D₁) →
+              hide-s (graphS D₁) (at ε) x y M.≈ₘ graphS D₁ x y
+hide-root-s D₁ x y =
+  ≈-trans (+ₘ-cong ≈-refl (∘-cong₁ (root-sink-s D₁ y)))
+          (absorb (graphS D₁ x y) (graphS D₁ x (at ε)))
+
+hide-hide-root-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                   (D₁ : γ , Ms ⇓s vs [ R ]) (r x y : VertexS D₁) →
+                   hide-s (hide-s (graphS D₁) (at ε)) r x y
+                   M.≈ₘ (graphS D₁ x y M.+ₘ (graphS D₁ r y M.∘ graphS D₁ x r))
+hide-hide-root-s D₁ r x y =
+  +ₘ-cong (hide-root-s D₁ x y) (∘-cong (hide-root-s D₁ r y) (hide-root-s D₁ x r))
+
+edge-off-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+             {D₁ : γ , Ms ⇓s vs [ R ]} {m}
+             (S : M.Matrix m (bases-width is)) (p : PathS D₁) → is-ε-s p ≡ Bool.false →
+             edge-s S p M.≈ₘ M.εₘ
+edge-off-s S ε ()
+edge-off-s S (hd p) np i j = refl {x = two.O}
+edge-off-s S (tl p) np i j = refl {x = two.O}
+
+into-hidden-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                (D₁ : γ , Ms ⇓s vs [ R ]) {m}
+                (P : M.Matrix m (bases-width is)) (x : VertexS D₁) →
+                (M.εₘ M.+ₘ (P M.∘ graphS D₁ x (at ε)))
+                M.≈ₘ (P M.∘ hide-s (graphS D₁) (at ε) x (at ε))
+into-hidden-s D₁ P x =
+  ≈-trans (+ₘ-lunit (P M.∘ graphS D₁ x (at ε))) (∘-cong₂ (≈-sym (hide-root-s D₁ x (at ε))))
+
+interior-not-root-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                      (D₁ : γ , Ms ⇓s vs [ R ]) →
+                      All (λ p → is-ε-s p ≡ Bool.false) (interior-s D₁)
+interior-not-root-s []       = []
+interior-not-root-s (D ∷ D₁) =
+  ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths D))) (map⁺ (universal (λ _ → ≡-refl) (paths-s D₁)))
+
+-- An operand cons: head premise then tail premise, as for pair but with the tail in the S family.
+module SCons {Γ i is} {γ : Env Γ} {M : Γ ⊢ base i} {Ms : Every (λ s → Γ ⊢ base s) is}
+             {v : sort-val i} {vs : sort-vals is}
+             {R : width-env γ ⇒ width (const {s = i} v)} {Rs : width-env γ ⇒ bases-width is}
+             {D₁ : γ , M ⇓ const v [ R ]} {D₂ : γ , Ms ⇓s vs [ Rs ]} where
+
+  record Phase₁ (G : GraphS (D₁ ∷ D₂)) (H : Graph D₁) : Set ℓ where
+    field
+      env-left    : ∀ q → G env (at (hd q)) M.≈ₘ H env (at q)
+      left-left   : ∀ p q → G (at (hd p)) (at (hd q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (M.in₁ M.∘ H env (at ε))
+      left-root   : ∀ p → is-ε p ≡ Bool.false →
+                    G (at (hd p)) (at ε) M.≈ₘ (M.in₁ M.∘ H (at p) (at ε))
+      env-right   : ∀ q → G env (at (tl q)) M.≈ₘ graphS D₂ env (at q)
+      right-right : ∀ p q → G (at (tl p)) (at (tl q)) M.≈ₘ graphS D₂ (at p) (at q)
+      right-root  : ∀ p → G (at (tl p)) (at ε) M.≈ₘ edge-s M.in₂ p
+      left-right  : ∀ p q → G (at (hd p)) (at (tl q)) M.≈ₘ M.εₘ
+      right-left  : ∀ p q → G (at (tl p)) (at (hd q)) M.≈ₘ M.εₘ
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (w : Path D₁) → is-ε w ≡ Bool.false →
+          Phase₁ G H → Phase₁ (hide-s G (at (hd w))) (hide H (at w))
+  step₁ w nw r .env-left q  = +ₘ-cong (r .env-left q) (∘-cong (r .left-left w q) (r .env-left w))
+  step₁ w nw r .left-left p q = +ₘ-cong (r .left-left p q) (∘-cong (r .left-left w q) (r .left-left p w))
+  step₁ w nw r .env-root = root-step {P = M.in₁ {sort-width i} {bases-width is}} (r .env-root) (r .left-root w nw) (r .env-left w)
+  step₁ w nw r .left-root p np = root-step {P = M.in₁ {sort-width i} {bases-width is}} (r .left-root p np) (r .left-root w nw) (r .left-left p w)
+  step₁ {G} w nw r .env-right q =
+    ≈-trans (+ₘ-cong (r .env-right q) (∘-cong₁ (r .left-right w q)))
+            (absorb (graphS D₂ env (at q)) (G env (at (hd w))))
+  step₁ {G} w nw r .right-right p q =
+    ≈-trans (+ₘ-cong (r .right-right p q) (∘-cong₁ (r .left-right w q)))
+            (absorb (graphS D₂ (at p) (at q)) (G (at (tl p)) (at (hd w))))
+  step₁ {G} w nw r .right-root p =
+    ≈-trans (+ₘ-cong (r .right-root p) (∘-cong₂ (r .right-left p w)))
+            (absorb-r (edge-s M.in₂ p) (G (at (hd w)) (at ε)))
+  step₁ {G} w nw r .left-right p q =
+    ≈-trans (+ₘ-cong (r .left-right p q) (∘-cong₁ (r .left-right w q)))
+            (absorb M.εₘ (G (at (hd p)) (at (hd w))))
+  step₁ {G} w nw r .right-left p q =
+    ≈-trans (+ₘ-cong (r .right-left p q) (∘-cong₂ (r .right-left p w)))
+            (absorb-r M.εₘ (G (at (hd w)) (at (hd q))))
+
+  steps₁ : ∀ {G H} (ws : List (Path D₁)) → All (λ w → is-ε w ≡ Bool.false) ws →
+           Phase₁ G H → Phase₁ (hide-all-s G (map at (map hd ws))) (hide-all H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (w ∷ ws) (nw ∷ nws) r = steps₁ ws nws (step₁ w nw r)
+
+  private
+    hh : ∀ x y → hide-s (hide-s (graphS (D₁ ∷ D₂)) (at ε)) (at (hd ε)) x y
+         M.≈ₘ (graphS (D₁ ∷ D₂) x y
+               M.+ₘ (graphS (D₁ ∷ D₂) (at (hd ε)) y M.∘ graphS (D₁ ∷ D₂) x (at (hd ε))))
+    hh = hide-hide-root-s (D₁ ∷ D₂) (at (hd ε))
+
+    base₁ : Phase₁ (hide-s (hide-s (graphS (D₁ ∷ D₂)) (at ε)) (at (hd ε))) (hide (graph D₁) (at ε))
+    base₁ .env-left q  = hh env (at (hd q))
+    base₁ .left-left p q = hh (at (hd p)) (at (hd q))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (into-hidden D₁ M.in₁ env)
+    base₁ .left-root p np =
+      ≈-trans (hh (at (hd p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off M.in₁ p np) ≈-refl) (into-hidden D₁ M.in₁ (at p)))
+    base₁ .env-right q =
+      ≈-trans (hh env (at (tl q))) (absorb (graphS D₂ env (at q)) (graph D₁ env (at ε)))
+    base₁ .right-right p q =
+      ≈-trans (hh (at (tl p)) (at (tl q)))
+              (absorb (graphS D₂ (at p) (at q)) (graphS (D₁ ∷ D₂) (at (tl p)) (at (hd ε))))
+    base₁ .right-root p =
+      ≈-trans (hh (at (tl p)) (at ε))
+              (absorb-r (edge-s M.in₂ p) (graphS (D₁ ∷ D₂) (at (hd ε)) (at ε)))
+    base₁ .left-right p q =
+      ≈-trans (hh (at (hd p)) (at (tl q))) (absorb M.εₘ (graph D₁ (at p) (at ε)))
+    base₁ .right-left p q =
+      ≈-trans (hh (at (tl p)) (at (hd q))) (absorb-r M.εₘ (graph D₁ (at ε) (at q)))
+
+  record Phase₂ (G : GraphS (D₁ ∷ D₂)) (H : GraphS D₂)
+                (K : M.Matrix (bases-width (i ∷ is)) (width-env γ)) : Set ℓ where
+    field
+      env-right   : ∀ q → G env (at (tl q)) M.≈ₘ H env (at q)
+      right-right : ∀ p q → G (at (tl p)) (at (tl q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (K M.+ₘ (M.in₂ M.∘ H env (at ε)))
+      right-root  : ∀ p → is-ε-s p ≡ Bool.false →
+                    G (at (tl p)) (at ε) M.≈ₘ (M.in₂ M.∘ H (at p) (at ε))
+
+  open Phase₂
+
+  step₂ : ∀ {G H K} (w : PathS D₂) → is-ε-s w ≡ Bool.false →
+          Phase₂ G H K → Phase₂ (hide-s G (at (tl w))) (hide-s H (at w)) K
+  step₂ w nw r .env-right q  = +ₘ-cong (r .env-right q) (∘-cong (r .right-right w q) (r .env-right w))
+  step₂ w nw r .right-right p q = +ₘ-cong (r .right-right p q) (∘-cong (r .right-right w q) (r .right-right p w))
+  step₂ w nw r .env-root =
+    offset-step {P = M.in₂ {sort-width i} {bases-width is}} (r .env-root) (r .right-root w nw) (r .env-right w)
+  step₂ w nw r .right-root p np =
+    root-step {P = M.in₂ {sort-width i} {bases-width is}} (r .right-root p np) (r .right-root w nw) (r .right-right p w)
+
+  steps₂ : ∀ {G H K} (ws : List (PathS D₂)) → All (λ w → is-ε-s w ≡ Bool.false) ws →
+           Phase₂ G H K → Phase₂ (hide-all-s G (map at (map tl ws))) (hide-all-s H (map at ws)) K
+  steps₂ []       []         r = r
+  steps₂ (w ∷ ws) (nw ∷ nws) r = steps₂ ws nws (step₂ w nw r)
+
+  private
+    r1 : Phase₁ (hide-all-s (hide-s (hide-s (graphS (D₁ ∷ D₂)) (at ε)) (at (hd ε)))
+                            (map at (map hd (interior D₁))))
+                (hide-all (hide (graph D₁) (at ε)) (map at (interior D₁)))
+    r1 = steps₁ (interior D₁) (interior-not-root D₁) base₁
+
+    base₂ : Phase₂ (hide-s (hide-all-s (hide-s (hide-s (graphS (D₁ ∷ D₂)) (at ε)) (at (hd ε)))
+                                       (map at (map hd (interior D₁))))
+                           (at (tl ε)))
+                   (hide-s (graphS D₂) (at ε))
+                   (M.in₁ M.∘ collapse D₁)
+    base₂ .env-right q = +ₘ-cong (r1 .env-right q) (∘-cong (r1 .right-right ε q) (r1 .env-right ε))
+    base₂ .right-right p q = +ₘ-cong (r1 .right-right p q) (∘-cong (r1 .right-right ε q) (r1 .right-right p ε))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (r1 .env-root) (∘-cong (r1 .right-root ε) (r1 .env-right ε)))
+              (+ₘ-cong ≈-refl (∘-cong₂ (≈-sym (hide-root-s D₂ env (at ε)))))
+    base₂ .right-root p np =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .right-root p) (edge-off-s M.in₂ p np))
+                       (∘-cong (r1 .right-root ε) (r1 .right-right p ε)))
+              (into-hidden-s D₂ M.in₂ (at p))
+
+  -- Collapsing an operand cons pairs the head and tail collapses.
+  agree : collapse-s (D₁ ∷ D₂)
+                 M.≈ₘ ((M.in₁ M.∘ collapse D₁) M.+ₘ (M.in₂ M.∘ collapse-s D₂))
+  agree =
+    ≈-trans (≈-of-≡ plumb) (steps₂ (interior-s D₂) (interior-not-root-s D₂) base₂ .env-root)
+    where
+      plumb : hide-all-s (hide-s (graphS (D₁ ∷ D₂)) (at ε))
+                         (map at (map hd (paths D₁) ++ map tl (paths-s D₂))) env (at ε)
+              ≡ hide-all-s (hide-all-s (hide-s (graphS (D₁ ∷ D₂)) (at ε))
+                                       (map at (map hd (paths D₁))))
+                           (map at (map tl (paths-s D₂))) env (at ε)
+      plumb =
+        ≡-trans (≡-cong (λ L → hide-all-s (hide-s (graphS (D₁ ∷ D₂)) (at ε)) L env (at ε))
+                        (map-++ at (map hd (paths D₁)) (map tl (paths-s D₂))))
+                (≡-cong (λ Gg → Gg env (at ε))
+                        (hide-all-s-++ (hide-s (graphS (D₁ ∷ D₂)) (at ε))
+                                       (map at (map hd (paths D₁)))
+                                       (map at (map tl (paths-s D₂)))))
+
+-- A primitive operation: one operand-list premise, with the operator's derivative as root edge.
+module Bop {Γ is o'} {γ : Env Γ} {ω : op is o'} {Ms : Every (λ s → Γ ⊢ base s) is}
+           {vs : sort-vals is} {Rs : width-env γ ⇒ bases-width is}
+           {D : γ , Ms ⇓s vs [ Rs ]} where
+
+  record Embeds (G : Graph (⇓-bop {ω = ω} D)) (H : GraphS D)
+                (P : M.Matrix (sort-width o') (bases-width is)) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (bop q)) M.≈ₘ H env (at q)
+      embed-embed : ∀ p q → G (at (bop p)) (at (bop q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      embed-root  : ∀ p → is-ε-s p ≡ Bool.false →
+                    G (at (bop p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : PathS D) → is-ε-s w ≡ Bool.false →
+                Embeds G H P → Embeds (hide G (at (bop w))) (hide-s H (at w)) P
+  embeds-hide w nw s .env-embed q   = +ₘ-cong (s .env-embed q) (∘-cong (s .embed-embed w q) (s .env-embed w))
+  embeds-hide w nw s .embed-embed p q = +ₘ-cong (s .embed-embed p q) (∘-cong (s .embed-embed w q) (s .embed-embed p w))
+  embeds-hide {P = P} w nw s .env-root = root-step {P = P} (s .env-root) (s .embed-root w nw) (s .env-embed w)
+  embeds-hide {P = P} w nw s .embed-root p np =
+    root-step {P = P} (s .embed-root p np) (s .embed-root w nw) (s .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (PathS D)) → All (λ w → is-ε-s w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all G (map at (map bop ws))) (hide-all-s H (map at ws)) P
+  embeds-hide-all []       []         s = s
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) s = embeds-hide-all ws nws (embeds-hide w nw s)
+
+  private
+    embeds₀ : Embeds (hide (hide (graph (⇓-bop {ω = ω} D)) (at ε)) (at (bop ε)))
+                     (hide-s (graphS D) (at ε)) (op-deps ω .func vs)
+    embeds₀ .env-embed q   = hide-hide-root (⇓-bop {ω = ω} D) (at (bop ε)) env (at (bop q))
+    embeds₀ .embed-embed p q = hide-hide-root (⇓-bop {ω = ω} D) (at (bop ε)) (at (bop p)) (at (bop q))
+    embeds₀ .env-root =
+      ≈-trans (hide-hide-root (⇓-bop {ω = ω} D) (at (bop ε)) env (at ε))
+              (into-hidden-s D (op-deps ω .func vs) env)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root (⇓-bop {ω = ω} D) (at (bop ε)) (at (bop p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off-s (op-deps ω .func vs) p np) ≈-refl)
+               (into-hidden-s D (op-deps ω .func vs) (at p)))
+
+  -- Collapsing an operation composes the derivative with the operands' collapse.
+  agree : collapse (⇓-bop {ω = ω} D) M.≈ₘ ((op-deps ω .func vs) M.∘ collapse-s D)
+  agree = embeds-hide-all (interior-s D) (interior-not-root-s D) embeds₀ .env-root
+
+-- A primitive relation: the result has no positions, so any two matrices agree.
+rows-zero : ∀ {n g} → n ≡ 0 → (X Y : M.Matrix n g) → X M.≈ₘ Y
+rows-zero ≡-refl X Y ()
+
+sum-width : ∀ (b : ⊤' {Level.0ℓ} ⊎' ⊤' {Level.0ℓ}) → width (bool→val b) ≡ 0
+sum-width (inj₁ _) = ≡-refl
+sum-width (inj₂ _) = ≡-refl
+
+agree-brel : ∀ {Γ is} {γ : Env Γ} {ω : rel is} {Ms : Every (λ s → Γ ⊢ base s) is}
+             {vs : sort-vals is} {Rs : width-env γ ⇒ bases-width is}
+             {D : γ , Ms ⇓s vs [ Rs ]} →
+             collapse (⇓-brel {ω = ω} D) M.≈ₘ brel-mat γ (rel-pred ω .func vs)
+agree-brel {γ = γ} {ω = ω} {vs = vs} {D = D} =
+  rows-zero (sum-width (rel-pred ω .func vs)) (collapse (⇓-brel {ω = ω} D))
+            (brel-mat γ (rel-pred ω .func vs))
+
+-- One summand survives because a factor of the other is zero.
+keep-l : ∀ {m n k} {G₁ C : M.Matrix m n} {G₂ : M.Matrix m k} {G₃ : M.Matrix k n} →
+         G₁ M.≈ₘ C → G₂ M.≈ₘ M.εₘ → (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ C
+keep-l {C = C} {G₃ = G₃} a b = ≈-trans (+ₘ-cong a (∘-cong₁ b)) (absorb C G₃)
+
+keep-r : ∀ {m n k} {G₁ C : M.Matrix m n} {G₂ : M.Matrix m k} {G₃ : M.Matrix k n} →
+         G₁ M.≈ₘ C → G₃ M.≈ₘ M.εₘ → (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ C
+keep-r {C = C} {G₂ = G₂} a c = ≈-trans (+ₘ-cong a (∘-cong₂ c)) (absorb-r C G₂)
+
+
+zap-l : ∀ {m n k} (C : M.Matrix m n) (G₃ : M.Matrix k n) →
+        (C M.+ₘ (M.εₘ {m} {k} M.∘ G₃)) M.≈ₘ C
+zap-l {m} {n} {k} C G₃ =
+  keep-l {C = C} {G₂ = M.εₘ} {G₃ = G₃} (≈-refl {f = C}) (≈-refl {f = M.εₘ {m} {k}})
+
+zap-r : ∀ {m n k} (C : M.Matrix m n) (G₂ : M.Matrix m k) →
+        (C M.+ₘ (G₂ M.∘ M.εₘ {k} {n})) M.≈ₘ C
+zap-r {m} {n} {k} C G₂ =
+  keep-r {C = C} {G₂ = G₂} {G₃ = M.εₘ} (≈-refl {f = C}) (≈-refl {f = M.εₘ {k} {n}})
+
+-- The fold-action family: mirrors of the root and edge lemmas.
+root-sink-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+    {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+    {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+              (D : Map γ s σ' v R v' R') (y : VertexM D) → graphM D (at ε) y M.≈ₘ M.εₘ
+root-sink-m (m-rec D₁ D₂) env i j = refl {x = two.O}
+root-sink-m (m-rec D₁ D₂) input i j = refl {x = two.O}
+root-sink-m (m-rec D₁ D₂) (at ε) i j = refl {x = two.O}
+root-sink-m (m-rec D₁ D₂) (at (m-rec₁ q)) i j = refl {x = two.O}
+root-sink-m (m-rec D₁ D₂) (at (m-rec₂ q)) i j = refl {x = two.O}
+root-sink-m m-unit env i j = refl {x = two.O}
+root-sink-m m-unit input i j = refl {x = two.O}
+root-sink-m m-unit (at ε) i j = refl {x = two.O}
+root-sink-m m-base env i j = refl {x = two.O}
+root-sink-m m-base input i j = refl {x = two.O}
+root-sink-m m-base (at ε) i j = refl {x = two.O}
+root-sink-m m-arrow env i j = refl {x = two.O}
+root-sink-m m-arrow input i j = refl {x = two.O}
+root-sink-m m-arrow (at ε) i j = refl {x = two.O}
+root-sink-m (m-inl D) env i j = refl {x = two.O}
+root-sink-m (m-inl D) input i j = refl {x = two.O}
+root-sink-m (m-inl D) (at ε) i j = refl {x = two.O}
+root-sink-m (m-inl D) (at (m-inl q)) i j = refl {x = two.O}
+root-sink-m (m-inr D) env i j = refl {x = two.O}
+root-sink-m (m-inr D) input i j = refl {x = two.O}
+root-sink-m (m-inr D) (at ε) i j = refl {x = two.O}
+root-sink-m (m-inr D) (at (m-inr q)) i j = refl {x = two.O}
+root-sink-m (m-pair D₁ D₂) env i j = refl {x = two.O}
+root-sink-m (m-pair D₁ D₂) input i j = refl {x = two.O}
+root-sink-m (m-pair D₁ D₂) (at ε) i j = refl {x = two.O}
+root-sink-m (m-pair D₁ D₂) (at (m-pair₁ q)) i j = refl {x = two.O}
+root-sink-m (m-pair D₁ D₂) (at (m-pair₂ q)) i j = refl {x = two.O}
+root-sink-m (m-mu D) env i j = refl {x = two.O}
+root-sink-m (m-mu D) input i j = refl {x = two.O}
+root-sink-m (m-mu D) (at ε) i j = refl {x = two.O}
+root-sink-m (m-mu D) (at (m-mu q)) i j = refl {x = two.O}
+
+hide-root-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+    {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+    {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+              (D : Map γ s σ' v R v' R') (x y : VertexM D) →
+              hide-m (graphM D) (at ε) x y M.≈ₘ graphM D x y
+hide-root-m D x y =
+  ≈-trans (+ₘ-cong ≈-refl (∘-cong₁ (root-sink-m D y)))
+          (absorb (graphM D x y) (graphM D x (at ε)))
+
+hide-hide-root-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+    {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+    {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                   (D : Map γ s σ' v R v' R') (r x y : VertexM D) →
+                   hide-m (hide-m (graphM D) (at ε)) r x y
+                   M.≈ₘ (graphM D x y M.+ₘ (graphM D r y M.∘ graphM D x r))
+hide-hide-root-m D r x y =
+  +ₘ-cong (hide-root-m D x y) (∘-cong (hide-root-m D r y) (hide-root-m D x r))
+
+edge-off-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+    {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+    {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'} {D : Map γ s σ' v R v' R'} {m}
+             (S : M.Matrix m (width v')) (p : PathM D) → is-ε-m p ≡ Bool.false →
+             edge-m S p M.≈ₘ M.εₘ
+edge-off-m S ε ()
+edge-off-m S (m-rec₁ p) np i j = refl {x = two.O}
+edge-off-m S (m-rec₂ p) np i j = refl {x = two.O}
+edge-off-m S (m-inl p) np i j = refl {x = two.O}
+edge-off-m S (m-inr p) np i j = refl {x = two.O}
+edge-off-m S (m-pair₁ p) np i j = refl {x = two.O}
+edge-off-m S (m-pair₂ p) np i j = refl {x = two.O}
+edge-off-m S (m-mu p) np i j = refl {x = two.O}
+
+into-hidden-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+    {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+    {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                (D : Map γ s σ' v R v' R') {m}
+                (P : M.Matrix m (width v')) (x : VertexM D) →
+                (M.εₘ M.+ₘ (P M.∘ graphM D x (at ε)))
+                M.≈ₘ (P M.∘ hide-m (graphM D) (at ε) x (at ε))
+into-hidden-m D P x =
+  ≈-trans (+ₘ-lunit (P M.∘ graphM D x (at ε))) (∘-cong₂ (≈-sym (hide-root-m D x (at ε))))
+
+interior-not-root-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+    {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+    {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                      (D : Map γ s σ' v R v' R') →
+                      All (λ p → is-ε-m p ≡ Bool.false) (interior-m D)
+interior-not-root-m (m-rec D₁ D₂)   = ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths-m D₁))) (map⁺ (universal (λ _ → ≡-refl) (paths D₂)))
+interior-not-root-m m-unit          = []
+interior-not-root-m m-base          = []
+interior-not-root-m m-arrow         = []
+interior-not-root-m (m-inl D)       = map⁺ (universal (λ _ → ≡-refl) (paths-m D))
+interior-not-root-m (m-inr D)       = map⁺ (universal (λ _ → ≡-refl) (paths-m D))
+interior-not-root-m (m-pair D₁ D₂)  = ++⁺ (map⁺ (universal (λ _ → ≡-refl) (paths-m D₁))) (map⁺ (universal (λ _ → ≡-refl) (paths-m D₂)))
+interior-not-root-m (m-mu D)        = map⁺ (universal (λ _ → ≡-refl) (paths-m D))
+
+-- Casts along width equalities, and their interaction with the matrix algebra. Each is proved by
+-- matching the equality, so they apply at neutral width proofs.
+ccast-∘ : ∀ {m k n n'} (e : n ≡ n') (X : M.Matrix m k) (Y : M.Matrix k n) →
+          (X M.∘ ccast e Y) M.≈ₘ ccast e (X M.∘ Y)
+ccast-∘ ≡-refl X Y = ≈-refl
+
++ₘ-ccast : ∀ {m n n'} (e : n ≡ n') (X Y : M.Matrix m n) →
+           (ccast e X M.+ₘ ccast e Y) M.≈ₘ ccast e (X M.+ₘ Y)
++ₘ-ccast ≡-refl X Y = ≈-refl
+
+rcast-∘ : ∀ {m m' k n} (e : m ≡ m') (X : M.Matrix m k) (Y : M.Matrix k n) →
+          (rcast e X M.∘ Y) M.≈ₘ rcast e (X M.∘ Y)
+rcast-∘ ≡-refl X Y = ≈-refl
+
+ccast-rcast-∘ : ∀ {m n n' k} (e : n ≡ n') (X : M.Matrix m n) (Y : M.Matrix n k) →
+                (ccast e X M.∘ rcast e Y) M.≈ₘ (X M.∘ Y)
+ccast-rcast-∘ ≡-refl X Y = ≈-refl
+
+rcast-cong : ∀ {m m' n} (e : m ≡ m') {X Y : M.Matrix m n} → X M.≈ₘ Y → rcast e X M.≈ₘ rcast e Y
+rcast-cong ≡-refl h = h
+
++ₘ-rcast : ∀ {m m' n} (e : m ≡ m') (X Y : M.Matrix m n) →
+           (rcast e X M.+ₘ rcast e Y) M.≈ₘ rcast e (X M.+ₘ Y)
++ₘ-rcast ≡-refl X Y = ≈-refl
+
+ccast-step : ∀ {m k n n'} (e : n ≡ n') {G₁ : M.Matrix m n'} {X : M.Matrix m n}
+             {G₂ Y : M.Matrix m k} {G₃ : M.Matrix k n'} {Z : M.Matrix k n} →
+             G₁ M.≈ₘ ccast e X → G₂ M.≈ₘ Y → G₃ M.≈ₘ ccast e Z →
+             (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ ccast e (X M.+ₘ (Y M.∘ Z))
+ccast-step e {X = X} {Y = Y} {Z = Z} a b c =
+  ≈-trans (+ₘ-cong a (≈-trans (∘-cong b c) (ccast-∘ e Y Z))) (+ₘ-ccast e X (Y M.∘ Z))
+
+
+ccast-cong : ∀ {m n n'} (e : n ≡ n') {X Y : M.Matrix m n} → X M.≈ₘ Y → ccast e X M.≈ₘ ccast e Y
+ccast-cong ≡-refl h = h
+
+root-step-cast : ∀ {m l g n n'} (e : n ≡ n') (P : M.Matrix m l)
+                 {G₁ : M.Matrix m n'} {X : M.Matrix l n} {G₂ : M.Matrix m g} {Y : M.Matrix l g}
+                 {G₃ : M.Matrix g n'} {Z : M.Matrix g n} →
+                 G₁ M.≈ₘ (P M.∘ ccast e X) → G₂ M.≈ₘ (P M.∘ Y) → G₃ M.≈ₘ ccast e Z →
+                 (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ (P M.∘ ccast e (X M.+ₘ (Y M.∘ Z)))
+root-step-cast e P {X = X} {Y = Y} {Z = Z} a b c =
+  ≈-trans (+ₘ-cong a (∘-cong b c))
+  (≈-trans (+ₘ-cong ≈-refl (≈-trans (assoc P Y (ccast e Z)) (∘-cong₂ (ccast-∘ e Y Z))))
+  (≈-trans (≈-sym (M.comp-bilinear₂ P (ccast e X) (ccast e (Y M.∘ Z))))
+           (∘-cong₂ (+ₘ-ccast e X (Y M.∘ Z)))))
+
+
++ₘ-interchange : ∀ {m n} (A B C D : M.Matrix m n) →
+                 ((A M.+ₘ B) M.+ₘ (C M.+ₘ D)) M.≈ₘ ((A M.+ₘ C) M.+ₘ (B M.+ₘ D))
++ₘ-interchange A B C D i j = +-interchange {w = A i j} {x = B i j} {y = C i j} {z = D i j}
+
+hide-all-m-++ : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                {D : Map γ s σ' v R v' R'}
+                (G : GraphM D) (xs ys : List (VertexM D)) →
+                hide-all-m G (xs ++ ys) ≡ hide-all-m (hide-all-m G xs) ys
+hide-all-m-++ G []       ys = ≡-refl
+hide-all-m-++ G (x ∷ xs) ys = hide-all-m-++ (hide-m G x) xs ys
+
+-- One hide step where the root columns carry both a pre-composition P and a post-composition W.
+root-under : ∀ {m l g g' n} (P : M.Matrix m l) {W : M.Matrix g g'}
+             {G₁ : M.Matrix m g'} {X : M.Matrix l g} {G₂ : M.Matrix m n} {Y : M.Matrix l n}
+             {G₃ : M.Matrix n g'} {Z : M.Matrix n g} →
+             G₁ M.≈ₘ ((P M.∘ X) M.∘ W) → G₂ M.≈ₘ (P M.∘ Y) → G₃ M.≈ₘ (Z M.∘ W) →
+             (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ ((P M.∘ (X M.+ₘ (Y M.∘ Z))) M.∘ W)
+root-under P {W} {X = X} {Y = Y} {Z = Z} a b c =
+  ≈-trans (+ₘ-cong a (∘-cong b c))
+  (≈-trans (+ₘ-cong (≈-refl {f = (P M.∘ X) M.∘ W}) (≈-sym (assoc (P M.∘ Y) Z W)))
+  (≈-trans (≈-sym (M.comp-bilinear₁ (P M.∘ X) ((P M.∘ Y) M.∘ Z) W))
+           (∘-cong₁ (distrib-root P X Y Z))))
+
+offset-under : ∀ {m l g g' n} (P : M.Matrix m l) {W : M.Matrix g g'} {K : M.Matrix m g'}
+               {G₁ : M.Matrix m g'} {X : M.Matrix l g} {G₂ : M.Matrix m n} {Y : M.Matrix l n}
+               {G₃ : M.Matrix n g'} {Z : M.Matrix n g} →
+               G₁ M.≈ₘ (K M.+ₘ ((P M.∘ X) M.∘ W)) → G₂ M.≈ₘ (P M.∘ Y) → G₃ M.≈ₘ (Z M.∘ W) →
+               (G₁ M.+ₘ (G₂ M.∘ G₃)) M.≈ₘ (K M.+ₘ ((P M.∘ (X M.+ₘ (Y M.∘ Z))) M.∘ W))
+offset-under P {W} {K} {X = X} {Y = Y} {Z = Z} a b c =
+  ≈-trans (+ₘ-cong a (∘-cong b c))
+  (≈-trans (+ₘ-assoc K ((P M.∘ X) M.∘ W) ((P M.∘ Y) M.∘ (Z M.∘ W)))
+           (+ₘ-cong (≈-refl {f = K})
+                    (root-under P {W} {X = X} {Y = Y} {Z = Z}
+                                (≈-refl {f = (P M.∘ X) M.∘ W}) (≈-refl {f = P M.∘ Y})
+                                (≈-refl {f = Z M.∘ W}))))
+
+-- One hide step on entries carrying an env part and an input part resolved through W.
+pair-source-step : ∀ {m n g g'} {W : M.Matrix g g'}
+                   {G₁ X : M.Matrix m g'} {X' : M.Matrix m g} {G₂ Y : M.Matrix m n}
+                   {G₃ Z : M.Matrix n g'} {Z' : M.Matrix n g} →
+                   G₁ M.≈ₘ (X M.+ₘ (X' M.∘ W)) → G₂ M.≈ₘ Y → G₃ M.≈ₘ (Z M.+ₘ (Z' M.∘ W)) →
+                   (G₁ M.+ₘ (G₂ M.∘ G₃))
+                   M.≈ₘ ((X M.+ₘ (Y M.∘ Z)) M.+ₘ ((X' M.+ₘ (Y M.∘ Z')) M.∘ W))
+pair-source-step {W = W} {X = X} {X' = X'} {Y = Y} {Z = Z} {Z' = Z'} a b c =
+  ≈-trans (+ₘ-cong a (∘-cong b c))
+  (≈-trans (+ₘ-cong (≈-refl {f = X M.+ₘ (X' M.∘ W)}) (M.comp-bilinear₂ Y Z (Z' M.∘ W)))
+  (≈-trans (+ₘ-interchange X (X' M.∘ W) (Y M.∘ Z) (Y M.∘ (Z' M.∘ W)))
+  (≈-trans (+ₘ-cong (≈-refl {f = X M.+ₘ (Y M.∘ Z)})
+                    (+ₘ-cong (≈-refl {f = X' M.∘ W}) (≈-sym (assoc Y Z' W))))
+           (+ₘ-cong (≈-refl {f = X M.+ₘ (Y M.∘ Z)})
+                    (≈-sym (M.comp-bilinear₁ X' (Y M.∘ Z') W))))))
+
+-- Leaf fold actions: the output is the input, so the collapse pair is (zero, identity).
+agree-m-unit : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+               {v : Val (unit [ μ τ₀ ])} {R : width-env γ ⇒ width v} →
+               (collapse-m-env (m-unit {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R})
+                M.+ₘ (collapse-m-in (m-unit {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) M.∘ R)) M.≈ₘ R
+agree-m-unit {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R} =
+  ≈-trans (+ₘ-cong (absorb M.εₘ (graphM (m-unit {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) env (at ε)))
+                   (∘-cong₁ (absorb M.I (graphM (m-unit {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) input (at ε)))))
+  (≈-trans (+ₘ-lunit (M.I M.∘ R)) id-left)
+
+agree-m-base : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+               {b} {v : Val (base b [ μ τ₀ ])} {R : width-env γ ⇒ width v} →
+               (collapse-m-env (m-base {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R})
+                M.+ₘ (collapse-m-in (m-base {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) M.∘ R)) M.≈ₘ R
+agree-m-base {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R} =
+  ≈-trans (+ₘ-cong (absorb M.εₘ (graphM (m-base {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) env (at ε)))
+                   (∘-cong₁ (absorb M.I (graphM (m-base {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) input (at ε)))))
+  (≈-trans (+ₘ-lunit (M.I M.∘ R)) id-left)
+
+agree-m-arrow : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                {σ₁ σ₂ : type 0} {v : Val ((σ₁ [→] σ₂) [ μ τ₀ ])} {R : width-env γ ⇒ width v} →
+                (collapse-m-env (m-arrow {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R})
+                 M.+ₘ (collapse-m-in (m-arrow {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) M.∘ R)) M.≈ₘ R
+agree-m-arrow {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R} =
+  ≈-trans (+ₘ-cong (absorb M.εₘ (graphM (m-arrow {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) env (at ε)))
+                   (∘-cong₁ (absorb M.I (graphM (m-arrow {γ = γ} {τ₀ = τ₀} {s = s} {v = v} {R = R}) input (at ε)))))
+  (≈-trans (+ₘ-lunit (M.I M.∘ R)) id-left)
+
+-- The m-inl action: one premise, both source rows embedding unchanged.
+module MInl {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {σ₁ σ₂ : type 1} {v : Val (σ₁ [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+            {v' : Val (σ₁ [ σr ])} {R' : width-env γ ⇒ width v'}
+            {D : Map γ s σ₁ v R v' R'} where
+
+  private
+    C : Map γ s (σ₁ [+] σ₂) _ R _ R'
+    C = m-inl {σ₁ = σ₁} {σ₂ = σ₂} D
+
+  record Embeds (G : GraphM C) (H : GraphM D)
+                (P : M.Matrix (width v') (width v')) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (m-inl q)) M.≈ₘ H env (at q)
+      input-embed : ∀ q → G input (at (m-inl q)) M.≈ₘ H input (at q)
+      embed-embed : ∀ p q → G (at (m-inl p)) (at (m-inl q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      input-root  : G input (at ε) M.≈ₘ (P M.∘ H input (at ε))
+      embed-root  : ∀ p → is-ε-m p ≡ Bool.false →
+                    G (at (m-inl p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : PathM D) → is-ε-m w ≡ Bool.false →
+                Embeds G H P → Embeds (hide-m G (at (m-inl w))) (hide-m H (at w)) P
+  embeds-hide w nw r .env-embed q   = +ₘ-cong (r .env-embed q) (∘-cong (r .embed-embed w q) (r .env-embed w))
+  embeds-hide w nw r .input-embed q = +ₘ-cong (r .input-embed q) (∘-cong (r .embed-embed w q) (r .input-embed w))
+  embeds-hide w nw r .embed-embed p q = +ₘ-cong (r .embed-embed p q) (∘-cong (r .embed-embed w q) (r .embed-embed p w))
+  embeds-hide {P = P} w nw r .env-root = root-step {P = P} (r .env-root) (r .embed-root w nw) (r .env-embed w)
+  embeds-hide {P = P} w nw r .input-root = root-step {P = P} (r .input-root) (r .embed-root w nw) (r .input-embed w)
+  embeds-hide {P = P} w nw r .embed-root p np =
+    root-step {P = P} (r .embed-root p np) (r .embed-root w nw) (r .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (PathM D)) → All (λ w → is-ε-m w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all-m G (map at (map m-inl ws))) (hide-all-m H (map at ws)) P
+  embeds-hide-all []       []         r = r
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) r = embeds-hide-all ws nws (embeds-hide w nw r)
+
+  private
+    embeds₀ : Embeds (hide-m (hide-m (graphM C) (at ε)) (at (m-inl ε)))
+                     (hide-m (graphM D) (at ε)) M.I
+    embeds₀ .env-embed q   = hide-hide-root-m C (at (m-inl ε)) env (at (m-inl q))
+    embeds₀ .input-embed q = hide-hide-root-m C (at (m-inl ε)) input (at (m-inl q))
+    embeds₀ .embed-embed p q = hide-hide-root-m C (at (m-inl ε)) (at (m-inl p)) (at (m-inl q))
+    embeds₀ .env-root   = ≈-trans (hide-hide-root-m C (at (m-inl ε)) env (at ε)) (into-hidden-m D M.I env)
+    embeds₀ .input-root = ≈-trans (hide-hide-root-m C (at (m-inl ε)) input (at ε)) (into-hidden-m D M.I input)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root-m C (at (m-inl ε)) (at (m-inl p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off-m M.I p np) ≈-refl) (into-hidden-m D M.I (at p)))
+
+    rfin = embeds-hide-all (interior-m D) (interior-not-root-m D) embeds₀
+
+  agree-env : collapse-m-env C M.≈ₘ collapse-m-env D
+  agree-env = ≈-trans (rfin .env-root) id-left
+
+  agree-in : collapse-m-in C M.≈ₘ collapse-m-in D
+  agree-in = ≈-trans (rfin .input-root) id-left
+
+-- The m-inr action: one premise, both source rows embedding unchanged.
+module MInr {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {σ₁ σ₂ : type 1} {v : Val (σ₂ [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+            {v' : Val (σ₂ [ σr ])} {R' : width-env γ ⇒ width v'}
+            {D : Map γ s σ₂ v R v' R'} where
+
+  private
+    C : Map γ s (σ₁ [+] σ₂) _ R _ R'
+    C = m-inr {σ₁ = σ₁} {σ₂ = σ₂} D
+
+  record Embeds (G : GraphM C) (H : GraphM D)
+                (P : M.Matrix (width v') (width v')) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (m-inr q)) M.≈ₘ H env (at q)
+      input-embed : ∀ q → G input (at (m-inr q)) M.≈ₘ H input (at q)
+      embed-embed : ∀ p q → G (at (m-inr p)) (at (m-inr q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      input-root  : G input (at ε) M.≈ₘ (P M.∘ H input (at ε))
+      embed-root  : ∀ p → is-ε-m p ≡ Bool.false →
+                    G (at (m-inr p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H P} (w : PathM D) → is-ε-m w ≡ Bool.false →
+                Embeds G H P → Embeds (hide-m G (at (m-inr w))) (hide-m H (at w)) P
+  embeds-hide w nw r .env-embed q   = +ₘ-cong (r .env-embed q) (∘-cong (r .embed-embed w q) (r .env-embed w))
+  embeds-hide w nw r .input-embed q = +ₘ-cong (r .input-embed q) (∘-cong (r .embed-embed w q) (r .input-embed w))
+  embeds-hide w nw r .embed-embed p q = +ₘ-cong (r .embed-embed p q) (∘-cong (r .embed-embed w q) (r .embed-embed p w))
+  embeds-hide {P = P} w nw r .env-root = root-step {P = P} (r .env-root) (r .embed-root w nw) (r .env-embed w)
+  embeds-hide {P = P} w nw r .input-root = root-step {P = P} (r .input-root) (r .embed-root w nw) (r .input-embed w)
+  embeds-hide {P = P} w nw r .embed-root p np =
+    root-step {P = P} (r .embed-root p np) (r .embed-root w nw) (r .embed-embed p w)
+
+  embeds-hide-all : ∀ {G H P} (ws : List (PathM D)) → All (λ w → is-ε-m w ≡ Bool.false) ws →
+                    Embeds G H P →
+                    Embeds (hide-all-m G (map at (map m-inr ws))) (hide-all-m H (map at ws)) P
+  embeds-hide-all []       []         r = r
+  embeds-hide-all (w ∷ ws) (nw ∷ nws) r = embeds-hide-all ws nws (embeds-hide w nw r)
+
+  private
+    embeds₀ : Embeds (hide-m (hide-m (graphM C) (at ε)) (at (m-inr ε)))
+                     (hide-m (graphM D) (at ε)) M.I
+    embeds₀ .env-embed q   = hide-hide-root-m C (at (m-inr ε)) env (at (m-inr q))
+    embeds₀ .input-embed q = hide-hide-root-m C (at (m-inr ε)) input (at (m-inr q))
+    embeds₀ .embed-embed p q = hide-hide-root-m C (at (m-inr ε)) (at (m-inr p)) (at (m-inr q))
+    embeds₀ .env-root   = ≈-trans (hide-hide-root-m C (at (m-inr ε)) env (at ε)) (into-hidden-m D M.I env)
+    embeds₀ .input-root = ≈-trans (hide-hide-root-m C (at (m-inr ε)) input (at ε)) (into-hidden-m D M.I input)
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root-m C (at (m-inr ε)) (at (m-inr p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off-m M.I p np) ≈-refl) (into-hidden-m D M.I (at p)))
+
+    rfin = embeds-hide-all (interior-m D) (interior-not-root-m D) embeds₀
+
+  agree-env : collapse-m-env C M.≈ₘ collapse-m-env D
+  agree-env = ≈-trans (rfin .env-root) id-left
+
+  agree-in : collapse-m-in C M.≈ₘ collapse-m-in D
+  agree-in = ≈-trans (rfin .input-root) id-left
+
+-- The mu action: one premise at the unfolded type, with width casts on the input row and the
+-- root edge.
+module MMu {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+           {τ' : type 2} {w : Val (unfold₁ τ' [ μ τ₀ ])} {R : width-env γ ⇒ width w}
+           {w' : Val (unfold₁ τ' [ σr ])} {R' : width-env γ ⇒ width w'}
+           {D : Map γ s (unfold₁ τ') w R w' R'} where
+
+  private
+    C = m-mu {τ' = τ'} D
+
+    eᵥ : width w ≡ width (subst Val (unfold₁-inst τ' (μ τ₀)) w)
+    eᵥ = ≡-sym (width-subst (unfold₁-inst τ' (μ τ₀)) w)
+
+    e' : width w' ≡ width (subst Val (unfold₁-inst τ' σr) w')
+    e' = ≡-sym (width-subst (unfold₁-inst τ' σr) w')
+
+    P : M.Matrix (width (subst Val (unfold₁-inst τ' σr) w')) (width w')
+    P = rcast e' M.I
+
+  record Embeds (G : GraphM C) (H : GraphM D) : Set ℓ where
+    field
+      env-embed   : ∀ q → G env (at (m-mu q)) M.≈ₘ H env (at q)
+      input-embed : ∀ q → G input (at (m-mu q)) M.≈ₘ ccast eᵥ (H input (at q))
+      embed-embed : ∀ p q → G (at (m-mu p)) (at (m-mu q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (P M.∘ H env (at ε))
+      input-root  : G input (at ε) M.≈ₘ (P M.∘ ccast eᵥ (H input (at ε)))
+      embed-root  : ∀ p → is-ε-m p ≡ Bool.false →
+                    G (at (m-mu p)) (at ε) M.≈ₘ (P M.∘ H (at p) (at ε))
+
+  open Embeds
+
+  embeds-hide : ∀ {G H} (v : PathM D) → is-ε-m v ≡ Bool.false →
+                Embeds G H → Embeds (hide-m G (at (m-mu v))) (hide-m H (at v))
+  embeds-hide v nw r .env-embed q   = +ₘ-cong (r .env-embed q) (∘-cong (r .embed-embed v q) (r .env-embed v))
+  embeds-hide v nw r .input-embed q =
+    ccast-step eᵥ (r .input-embed q) (r .embed-embed v q) (r .input-embed v)
+  embeds-hide v nw r .embed-embed p q = +ₘ-cong (r .embed-embed p q) (∘-cong (r .embed-embed v q) (r .embed-embed p v))
+  embeds-hide v nw r .env-root = root-step {P = P} (r .env-root) (r .embed-root v nw) (r .env-embed v)
+  embeds-hide v nw r .input-root =
+    root-step-cast eᵥ P (r .input-root) (r .embed-root v nw) (r .input-embed v)
+  embeds-hide v nw r .embed-root p np =
+    root-step {P = P} (r .embed-root p np) (r .embed-root v nw) (r .embed-embed p v)
+
+  embeds-hide-all : ∀ {G H} (ws : List (PathM D)) → All (λ v → is-ε-m v ≡ Bool.false) ws →
+                    Embeds G H →
+                    Embeds (hide-all-m G (map at (map m-mu ws))) (hide-all-m H (map at ws))
+  embeds-hide-all []       []         r = r
+  embeds-hide-all (v ∷ ws) (nw ∷ nws) r = embeds-hide-all ws nws (embeds-hide v nw r)
+
+  private
+    embeds₀ : Embeds (hide-m (hide-m (graphM C) (at ε)) (at (m-mu ε)))
+                     (hide-m (graphM D) (at ε))
+    embeds₀ .env-embed q   = hide-hide-root-m C (at (m-mu ε)) env (at (m-mu q))
+    embeds₀ .input-embed q =
+      ≈-trans (hide-hide-root-m C (at (m-mu ε)) input (at (m-mu q)))
+              (ccast-step eᵥ {X = graphM D input (at q)} {Z = graphM D input (at ε)}
+                          ≈-refl ≈-refl ≈-refl)
+    embeds₀ .embed-embed p q = hide-hide-root-m C (at (m-mu ε)) (at (m-mu p)) (at (m-mu q))
+    embeds₀ .env-root =
+      ≈-trans (hide-hide-root-m C (at (m-mu ε)) env (at ε)) (into-hidden-m D P env)
+    embeds₀ .input-root =
+      ≈-trans (hide-hide-root-m C (at (m-mu ε)) input (at ε))
+      (≈-trans (+ₘ-lunit (P M.∘ ccast eᵥ (graphM D input (at ε))))
+               (∘-cong₂ (ccast-cong eᵥ (≈-sym (hide-root-m D input (at ε))))))
+    embeds₀ .embed-root p np =
+      ≈-trans (hide-hide-root-m C (at (m-mu ε)) (at (m-mu p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off-m P p np) ≈-refl) (into-hidden-m D P (at p)))
+
+    rfin = embeds-hide-all (interior-m D) (interior-not-root-m D) embeds₀
+
+  agree-env : collapse-m-env C M.≈ₘ rcast e' (collapse-m-env D)
+  agree-env =
+    ≈-trans (rfin .env-root)
+    (≈-trans (rcast-∘ e' M.I (collapse-m-env D)) (rcast-cong e' id-left))
+
+  agree-in : collapse-m-in C M.≈ₘ rcast e' (ccast eᵥ (collapse-m-in D))
+  agree-in =
+    ≈-trans (rfin .input-root)
+    (≈-trans (rcast-∘ e' M.I (ccast eᵥ (collapse-m-in D))) (rcast-cong e' id-left))
+
+-- The pair action: two premises, the input row sliced through the projections.
+module MPair {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+             {σ₁ σ₂ : type 1} {v : Val (σ₁ [ μ τ₀ ])} {u : Val (σ₂ [ μ τ₀ ])}
+             {R : width-env γ ⇒ width (pair v u)}
+             {v' : Val (σ₁ [ σr ])} {S₁ : width-env γ ⇒ width v'}
+             {u' : Val (σ₂ [ σr ])} {T : width-env γ ⇒ width u'}
+             {D₁ : Map γ s σ₁ v (M.p₁ {width v} {width u} M.∘ R) v' S₁}
+             {D₂ : Map γ s σ₂ u (M.p₂ {width v} {width u} M.∘ R) u' T} where
+
+  private
+    C = m-pair D₁ D₂
+
+    pˡ = M.p₁ {width v} {width u}
+    pʳ = M.p₂ {width v} {width u}
+    i₁ = M.in₁ {width v'} {width u'}
+    i₂ = M.in₂ {width v'} {width u'}
+
+  record Phase₁ (G : GraphM C) (H : GraphM D₁) : Set ℓ where
+    field
+      env-left    : ∀ q → G env (at (m-pair₁ q)) M.≈ₘ H env (at q)
+      input-left  : ∀ q → G input (at (m-pair₁ q)) M.≈ₘ (H input (at q) M.∘ pˡ)
+      left-left   : ∀ p q → G (at (m-pair₁ p)) (at (m-pair₁ q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (i₁ M.∘ H env (at ε))
+      input-root  : G input (at ε) M.≈ₘ ((i₁ M.∘ H input (at ε)) M.∘ pˡ)
+      left-root   : ∀ p → is-ε-m p ≡ Bool.false →
+                    G (at (m-pair₁ p)) (at ε) M.≈ₘ (i₁ M.∘ H (at p) (at ε))
+      env-right   : ∀ q → G env (at (m-pair₂ q)) M.≈ₘ graphM D₂ env (at q)
+      input-right : ∀ q → G input (at (m-pair₂ q)) M.≈ₘ (graphM D₂ input (at q) M.∘ pʳ)
+      right-right : ∀ p q → G (at (m-pair₂ p)) (at (m-pair₂ q)) M.≈ₘ graphM D₂ (at p) (at q)
+      right-root  : ∀ p → G (at (m-pair₂ p)) (at ε) M.≈ₘ edge-m i₂ p
+      left-right  : ∀ p q → G (at (m-pair₁ p)) (at (m-pair₂ q)) M.≈ₘ M.εₘ
+      right-left  : ∀ p q → G (at (m-pair₂ p)) (at (m-pair₁ q)) M.≈ₘ M.εₘ
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (w : PathM D₁) → is-ε-m w ≡ Bool.false →
+           Phase₁ G H → Phase₁ (hide-m G (at (m-pair₁ w))) (hide-m H (at w))
+  step₁ w nw r .env-left q  = +ₘ-cong (r .env-left q) (∘-cong (r .left-left w q) (r .env-left w))
+  step₁ w nw r .input-left q = step-under {W = pˡ} (r .input-left q) (r .left-left w q) (r .input-left w)
+  step₁ w nw r .left-left p q = +ₘ-cong (r .left-left p q) (∘-cong (r .left-left w q) (r .left-left p w))
+  step₁ w nw r .env-root = root-step {P = i₁} (r .env-root) (r .left-root w nw) (r .env-left w)
+  step₁ w nw r .input-root = root-under i₁ {W = pˡ} (r .input-root) (r .left-root w nw) (r .input-left w)
+  step₁ w nw r .left-root p np = root-step {P = i₁} (r .left-root p np) (r .left-root w nw) (r .left-left p w)
+  step₁ w nw r .env-right q = keep-l (r .env-right q) (r .left-right w q)
+  step₁ w nw r .input-right q = keep-l (r .input-right q) (r .left-right w q)
+  step₁ w nw r .right-right p q = keep-l (r .right-right p q) (r .left-right w q)
+  step₁ w nw r .right-root p = keep-r (r .right-root p) (r .right-left p w)
+  step₁ w nw r .left-right p q = keep-l (r .left-right p q) (r .left-right w q)
+  step₁ w nw r .right-left p q = keep-r (r .right-left p q) (r .right-left p w)
+
+  steps₁ : ∀ {G H} (ws : List (PathM D₁)) → All (λ w → is-ε-m w ≡ Bool.false) ws →
+            Phase₁ G H → Phase₁ (hide-all-m G (map at (map m-pair₁ ws))) (hide-all-m H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (w ∷ ws) (nw ∷ nws) r = steps₁ ws nws (step₁ w nw r)
+
+  private
+    hh : ∀ x y → hide-m (hide-m (graphM C) (at ε)) (at (m-pair₁ ε)) x y
+         M.≈ₘ (graphM C x y M.+ₘ (graphM C (at (m-pair₁ ε)) y M.∘ graphM C x (at (m-pair₁ ε))))
+    hh = hide-hide-root-m C (at (m-pair₁ ε))
+
+    base₁ : Phase₁ (hide-m (hide-m (graphM C) (at ε)) (at (m-pair₁ ε))) (hide-m (graphM D₁) (at ε))
+    base₁ .env-left q  = hh env (at (m-pair₁ q))
+    base₁ .input-left q =
+      ≈-trans (hh input (at (m-pair₁ q)))
+              (step-under {W = pˡ} {X = graphM D₁ input (at q)} {Z = graphM D₁ input (at ε)}
+                          ≈-refl ≈-refl ≈-refl)
+    base₁ .left-left p q = hh (at (m-pair₁ p)) (at (m-pair₁ q))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (into-hidden-m D₁ i₁ env)
+    base₁ .input-root =
+      ≈-trans (hh input (at ε))
+      (≈-trans (+ₘ-lunit (i₁ M.∘ (graphM D₁ input (at ε) M.∘ pˡ)))
+      (≈-trans (≈-sym (assoc i₁ (graphM D₁ input (at ε)) pˡ))
+               (∘-cong₁ (∘-cong₂ (≈-sym (hide-root-m D₁ input (at ε)))))))
+    base₁ .left-root p np =
+      ≈-trans (hh (at (m-pair₁ p)) (at ε))
+      (≈-trans (+ₘ-cong (edge-off-m i₁ p np) ≈-refl) (into-hidden-m D₁ i₁ (at p)))
+    base₁ .env-right q =
+      ≈-trans (hh env (at (m-pair₂ q)))
+              (zap-l (graphM (m-pair D₁ D₂) env (at (m-pair₂ q))) (graphM (m-pair D₁ D₂) env (at (m-pair₁ ε))))
+    base₁ .input-right q =
+      ≈-trans (hh input (at (m-pair₂ q)))
+              (zap-l (graphM (m-pair D₁ D₂) input (at (m-pair₂ q))) (graphM (m-pair D₁ D₂) input (at (m-pair₁ ε))))
+    base₁ .right-right p q =
+      ≈-trans (hh (at (m-pair₂ p)) (at (m-pair₂ q)))
+              (zap-l (graphM (m-pair D₁ D₂) (at (m-pair₂ p)) (at (m-pair₂ q))) (graphM (m-pair D₁ D₂) (at (m-pair₂ p)) (at (m-pair₁ ε))))
+    base₁ .right-root p =
+      ≈-trans (hh (at (m-pair₂ p)) (at ε))
+              (zap-r (graphM (m-pair D₁ D₂) (at (m-pair₂ p)) (at ε)) (graphM (m-pair D₁ D₂) (at (m-pair₁ ε)) (at ε)))
+    base₁ .left-right p q =
+      ≈-trans (hh (at (m-pair₁ p)) (at (m-pair₂ q)))
+              (zap-l (graphM (m-pair D₁ D₂) (at (m-pair₁ p)) (at (m-pair₂ q))) (graphM (m-pair D₁ D₂) (at (m-pair₁ p)) (at (m-pair₁ ε))))
+    base₁ .right-left p q =
+      ≈-trans (hh (at (m-pair₂ p)) (at (m-pair₁ q)))
+              (zap-r (graphM (m-pair D₁ D₂) (at (m-pair₂ p)) (at (m-pair₁ q))) (graphM (m-pair D₁ D₂) (at (m-pair₁ ε)) (at (m-pair₁ q))))
+
+  record Phase₂ (G : GraphM C) (H : GraphM D₂)
+                (Kₑ : M.Matrix (width (pair v' u')) (width-env γ))
+                (Kᵢ : M.Matrix (width (pair v' u')) (width (pair v u))) : Set ℓ where
+    field
+      env-right   : ∀ q → G env (at (m-pair₂ q)) M.≈ₘ H env (at q)
+      input-right : ∀ q → G input (at (m-pair₂ q)) M.≈ₘ (H input (at q) M.∘ pʳ)
+      right-right : ∀ p q → G (at (m-pair₂ p)) (at (m-pair₂ q)) M.≈ₘ H (at p) (at q)
+      env-root    : G env (at ε) M.≈ₘ (Kₑ M.+ₘ (i₂ M.∘ H env (at ε)))
+      input-root  : G input (at ε) M.≈ₘ (Kᵢ M.+ₘ ((i₂ M.∘ H input (at ε)) M.∘ pʳ))
+      right-root  : ∀ p → is-ε-m p ≡ Bool.false →
+                    G (at (m-pair₂ p)) (at ε) M.≈ₘ (i₂ M.∘ H (at p) (at ε))
+
+  open Phase₂
+
+  step₂ : ∀ {G H Kₑ Kᵢ} (w : PathM D₂) → is-ε-m w ≡ Bool.false →
+           Phase₂ G H Kₑ Kᵢ → Phase₂ (hide-m G (at (m-pair₂ w))) (hide-m H (at w)) Kₑ Kᵢ
+  step₂ w nw r .env-right q  = +ₘ-cong (r .env-right q) (∘-cong (r .right-right w q) (r .env-right w))
+  step₂ w nw r .input-right q = step-under {W = pʳ} (r .input-right q) (r .right-right w q) (r .input-right w)
+  step₂ w nw r .right-right p q = +ₘ-cong (r .right-right p q) (∘-cong (r .right-right w q) (r .right-right p w))
+  step₂ {Kₑ = Kₑ} w nw r .env-root = offset-step {K = Kₑ} {P = i₂} (r .env-root) (r .right-root w nw) (r .env-right w)
+  step₂ {Kᵢ = Kᵢ} w nw r .input-root = offset-under i₂ {W = pʳ} {K = Kᵢ} (r .input-root) (r .right-root w nw) (r .input-right w)
+  step₂ w nw r .right-root p np = root-step {P = i₂} (r .right-root p np) (r .right-root w nw) (r .right-right p w)
+
+  steps₂ : ∀ {G H Kₑ Kᵢ} (ws : List (PathM D₂)) → All (λ w → is-ε-m w ≡ Bool.false) ws →
+            Phase₂ G H Kₑ Kᵢ →
+            Phase₂ (hide-all-m G (map at (map m-pair₂ ws))) (hide-all-m H (map at ws)) Kₑ Kᵢ
+  steps₂ []       []         r = r
+  steps₂ (w ∷ ws) (nw ∷ nws) r = steps₂ ws nws (step₂ w nw r)
+
+  private
+    r1 : Phase₁ (hide-all-m (hide-m (hide-m (graphM C) (at ε)) (at (m-pair₁ ε)))
+                            (map at (map m-pair₁ (interior-m D₁))))
+                (hide-all-m (hide-m (graphM D₁) (at ε)) (map at (interior-m D₁)))
+    r1 = steps₁ (interior-m D₁) (interior-not-root-m D₁) base₁
+
+    base₂ : Phase₂ (hide-m (hide-all-m (hide-m (hide-m (graphM C) (at ε)) (at (m-pair₁ ε)))
+                                       (map at (map m-pair₁ (interior-m D₁))))
+                           (at (m-pair₂ ε)))
+                   (hide-m (graphM D₂) (at ε))
+                   (i₁ M.∘ collapse-m-env D₁)
+                   ((i₁ M.∘ collapse-m-in D₁) M.∘ pˡ)
+    base₂ .env-right q = +ₘ-cong (r1 .env-right q) (∘-cong (r1 .right-right ε q) (r1 .env-right ε))
+    base₂ .input-right q = step-under {W = pʳ} (r1 .input-right q) (r1 .right-right ε q) (r1 .input-right ε)
+    base₂ .right-right p q = +ₘ-cong (r1 .right-right p q) (∘-cong (r1 .right-right ε q) (r1 .right-right p ε))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (r1 .env-root) (∘-cong (r1 .right-root ε) (r1 .env-right ε)))
+              (+ₘ-cong (≈-refl {f = i₁ M.∘ collapse-m-env D₁})
+                       (∘-cong₂ (≈-sym (hide-root-m D₂ env (at ε)))))
+    base₂ .input-root =
+      ≈-trans (+ₘ-cong (r1 .input-root) (∘-cong (r1 .right-root ε) (r1 .input-right ε)))
+              (+ₘ-cong (≈-refl {f = (i₁ M.∘ collapse-m-in D₁) M.∘ pˡ})
+                       (≈-trans (≈-sym (assoc i₂ (graphM D₂ input (at ε)) pʳ))
+                                (∘-cong₁ (∘-cong₂ (≈-sym (hide-root-m D₂ input (at ε)))))))
+    base₂ .right-root p np =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .right-root p) (edge-off-m i₂ p np))
+                       (∘-cong (r1 .right-root ε) (r1 .right-right p ε)))
+              (into-hidden-m D₂ i₂ (at p))
+
+    rfin = steps₂ (interior-m D₂) (interior-not-root-m D₂) base₂
+
+    plumbG : hide-all-m (hide-m (graphM C) (at ε))
+                        (map at (map m-pair₁ (paths-m D₁) ++ map m-pair₂ (paths-m D₂)))
+             ≡ hide-all-m (hide-all-m (hide-m (graphM C) (at ε))
+                                      (map at (map m-pair₁ (paths-m D₁))))
+                          (map at (map m-pair₂ (paths-m D₂)))
+    plumbG =
+      ≡-trans (≡-cong (hide-all-m (hide-m (graphM C) (at ε)))
+                      (map-++ at (map m-pair₁ (paths-m D₁)) (map m-pair₂ (paths-m D₂))))
+              (hide-all-m-++ (hide-m (graphM C) (at ε))
+                             (map at (map m-pair₁ (paths-m D₁)))
+                             (map at (map m-pair₂ (paths-m D₂))))
+
+  agree-env : collapse-m-env C M.≈ₘ ((i₁ M.∘ collapse-m-env D₁) M.+ₘ (i₂ M.∘ collapse-m-env D₂))
+  agree-env =
+    ≈-trans (≈-of-≡ (≡-cong (λ Gg → Gg env (at ε)) plumbG)) (rfin .env-root)
+
+  agree-in : collapse-m-in C M.≈ₘ (((i₁ M.∘ collapse-m-in D₁) M.∘ pˡ) M.+ₘ ((i₂ M.∘ collapse-m-in D₂) M.∘ pʳ))
+  agree-in =
+    ≈-trans (≈-of-≡ (≡-cong (λ Gg → Gg input (at ε)) plumbG)) (rfin .input-root)
+
+  combine : ∀ {Rp : width-env γ ⇒ width v'} {Tp : width-env γ ⇒ width u'} →
+            ((collapse-m-env D₁ M.+ₘ (collapse-m-in D₁ M.∘ (pˡ M.∘ R))) M.≈ₘ Rp) →
+            ((collapse-m-env D₂ M.+ₘ (collapse-m-in D₂ M.∘ (pʳ M.∘ R))) M.≈ₘ Tp) →
+            ((collapse-m-env C M.+ₘ (collapse-m-in C M.∘ R))
+             M.≈ₘ ((i₁ M.∘ Rp) M.+ₘ (i₂ M.∘ Tp)))
+  combine {Rp} {Tp} ihl ihr =
+    ≈-trans (+ₘ-cong agree-env (∘-cong₁ agree-in))
+    (≈-trans (+ₘ-cong (≈-refl {f = (i₁ M.∘ collapse-m-env D₁) M.+ₘ (i₂ M.∘ collapse-m-env D₂)})
+                      (M.comp-bilinear₁ ((i₁ M.∘ collapse-m-in D₁) M.∘ pˡ)
+                                        ((i₂ M.∘ collapse-m-in D₂) M.∘ pʳ) R))
+    (≈-trans (+ₘ-interchange (i₁ M.∘ collapse-m-env D₁) (i₂ M.∘ collapse-m-env D₂)
+                             (((i₁ M.∘ collapse-m-in D₁) M.∘ pˡ) M.∘ R)
+                             (((i₂ M.∘ collapse-m-in D₂) M.∘ pʳ) M.∘ R))
+             (+ₘ-cong (half i₁ pˡ ihl) (half i₂ pʳ ihr))))
+    where
+      half : ∀ {m wp} (i : M.Matrix (width (pair v' u')) m) (pr : M.Matrix wp (width (pair v u)))
+             {Cenv : M.Matrix m (width-env γ)} {Cin : M.Matrix m wp} {Out} →
+             ((Cenv M.+ₘ (Cin M.∘ (pr M.∘ R))) M.≈ₘ Out) →
+             (((i M.∘ Cenv) M.+ₘ (((i M.∘ Cin) M.∘ pr) M.∘ R)) M.≈ₘ (i M.∘ Out))
+      half i pr {Cenv} {Cin} {Out} ih =
+        ≈-trans (+ₘ-cong (≈-refl {f = i M.∘ Cenv})
+                         (≈-trans (assoc (i M.∘ Cin) pr R) (assoc i Cin (pr M.∘ R))))
+        (≈-trans (≈-sym (M.comp-bilinear₂ i Cenv (Cin M.∘ (pr M.∘ R)))) (∘-cong₂ ih))
+
+
+-- The recursion action: a fold-action premise, then the body evaluated under the extended
+-- environment, its rewired columns fed by both of the premise's collapses.
+module MRec {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {w : Val (τ₀ [ μ τ₀ ])} {R : width-env γ ⇒ width w}
+            {w' : Val (τ₀ [ σr ])} {R' : width-env γ ⇒ width w'}
+            {u : Val σr} {S : width-env (γ · w') ⇒ width u}
+            {D₁ : Map γ s τ₀ w R w' R'} {D₂ : γ · w' , s ⇓ u [ S ]} where
+
+  private
+    C = m-rec D₁ D₂
+
+    iₗ = M.in₁ {width-env γ} {width w'}
+    iᵣ = M.in₂ {width-env γ} {width w'}
+
+    B : (q : Path D₂) → M.Matrix (width-at q) (width-env (γ · w'))
+    B q = graph D₂ env (at q)
+
+    Wₑ : M.Matrix (width-env (γ · w')) (width-env γ)
+    Wₑ = iₗ M.+ₘ (iᵣ M.∘ collapse-m-env D₁)
+
+    Wᵢ : M.Matrix (width-env (γ · w')) (width w)
+    Wᵢ = iᵣ M.∘ collapse-m-in D₁
+
+  record Phase₁ (G : GraphM C) (H : GraphM D₁) : Set ℓ where
+    field
+      env-map    : ∀ q → G env (at (m-rec₁ q)) M.≈ₘ H env (at q)
+      input-map  : ∀ q → G input (at (m-rec₁ q)) M.≈ₘ H input (at q)
+      map-map    : ∀ p q → G (at (m-rec₁ p)) (at (m-rec₁ q)) M.≈ₘ H (at p) (at q)
+      env-body   : ∀ q → G env (at (m-rec₂ q))
+                   M.≈ₘ ((B q M.∘ iₗ) M.+ₘ ((B q M.∘ iᵣ) M.∘ H env (at ε)))
+      input-body : ∀ q → G input (at (m-rec₂ q)) M.≈ₘ ((B q M.∘ iᵣ) M.∘ H input (at ε))
+      map-body   : ∀ p → is-ε-m p ≡ Bool.false → ∀ q →
+                   G (at (m-rec₁ p)) (at (m-rec₂ q)) M.≈ₘ ((B q M.∘ iᵣ) M.∘ H (at p) (at ε))
+      body-body  : ∀ p q → G (at (m-rec₂ p)) (at (m-rec₂ q)) M.≈ₘ graph D₂ (at p) (at q)
+      body-map   : ∀ p q → G (at (m-rec₂ p)) (at (m-rec₁ q)) M.≈ₘ M.εₘ
+      env-root   : G env (at ε) M.≈ₘ M.εₘ
+      input-root : G input (at ε) M.≈ₘ M.εₘ
+      map-root   : ∀ p → G (at (m-rec₁ p)) (at ε) M.≈ₘ M.εₘ
+      body-root  : ∀ p → G (at (m-rec₂ p)) (at ε) M.≈ₘ edge M.I p
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (v : PathM D₁) → is-ε-m v ≡ Bool.false →
+          Phase₁ G H → Phase₁ (hide-m G (at (m-rec₁ v))) (hide-m H (at v))
+  step₁ v nv r .env-map q  = +ₘ-cong (r .env-map q) (∘-cong (r .map-map v q) (r .env-map v))
+  step₁ v nv r .input-map q = +ₘ-cong (r .input-map q) (∘-cong (r .map-map v q) (r .input-map v))
+  step₁ v nv r .map-map p q = +ₘ-cong (r .map-map p q) (∘-cong (r .map-map v q) (r .map-map p v))
+  step₁ v nv r .env-body q =
+    offset-step {K = B q M.∘ iₗ} {P = B q M.∘ iᵣ} (r .env-body q) (r .map-body v nv q) (r .env-map v)
+  step₁ v nv r .input-body q =
+    root-step {P = B q M.∘ iᵣ} (r .input-body q) (r .map-body v nv q) (r .input-map v)
+  step₁ v nv r .map-body p np q =
+    root-step {P = B q M.∘ iᵣ} (r .map-body p np q) (r .map-body v nv q) (r .map-map p v)
+  step₁ v nv r .body-body p q = keep-r (r .body-body p q) (r .body-map p v)
+  step₁ v nv r .body-map p q = keep-r (r .body-map p q) (r .body-map p v)
+  step₁ v nv r .env-root = keep-l (r .env-root) (r .map-root v)
+  step₁ v nv r .input-root = keep-l (r .input-root) (r .map-root v)
+  step₁ v nv r .map-root p = keep-l (r .map-root p) (r .map-root v)
+  step₁ v nv r .body-root p = keep-l (r .body-root p) (r .map-root v)
+
+  steps₁ : ∀ {G H} (ws : List (PathM D₁)) → All (λ v → is-ε-m v ≡ Bool.false) ws →
+           Phase₁ G H → Phase₁ (hide-all-m G (map at (map m-rec₁ ws))) (hide-all-m H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (v ∷ ws) (nv ∷ nws) r = steps₁ ws nws (step₁ v nv r)
+
+  private
+    hh : ∀ x y → hide-m (hide-m (graphM C) (at ε)) (at (m-rec₁ ε)) x y
+         M.≈ₘ (graphM C x y M.+ₘ (graphM C (at (m-rec₁ ε)) y M.∘ graphM C x (at (m-rec₁ ε))))
+    hh = hide-hide-root-m C (at (m-rec₁ ε))
+
+    base₁ : Phase₁ (hide-m (hide-m (graphM C) (at ε)) (at (m-rec₁ ε))) (hide-m (graphM D₁) (at ε))
+    base₁ .env-map q  = hh env (at (m-rec₁ q))
+    base₁ .input-map q = hh input (at (m-rec₁ q))
+    base₁ .map-map p q = hh (at (m-rec₁ p)) (at (m-rec₁ q))
+    base₁ .env-body q =
+      ≈-trans (hh env (at (m-rec₂ q)))
+              (+ₘ-cong (≈-refl {f = B q M.∘ iₗ}) (∘-cong₂ (≈-sym (hide-root-m D₁ env (at ε)))))
+    base₁ .input-body q =
+      ≈-trans (hh input (at (m-rec₂ q))) (into-hidden-m D₁ (B q M.∘ iᵣ) input)
+    base₁ .map-body p np q =
+      ≈-trans (hh (at (m-rec₁ p)) (at (m-rec₂ q)))
+      (≈-trans (+ₘ-cong (edge-off-m (B q M.∘ iᵣ) p np) ≈-refl) (into-hidden-m D₁ (B q M.∘ iᵣ) (at p)))
+    base₁ .body-body p q =
+      ≈-trans (hh (at (m-rec₂ p)) (at (m-rec₂ q)))
+              (zap-r (graph D₂ (at p) (at q)) (graphM C (at (m-rec₁ ε)) (at (m-rec₂ q))))
+    base₁ .body-map p q =
+      ≈-trans (hh (at (m-rec₂ p)) (at (m-rec₁ q))) (zap-r M.εₘ (graphM C (at (m-rec₁ ε)) (at (m-rec₁ q))))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (zap-l M.εₘ (graphM C env (at (m-rec₁ ε))))
+    base₁ .input-root = ≈-trans (hh input (at ε)) (zap-l M.εₘ (graphM C input (at (m-rec₁ ε))))
+    base₁ .map-root p =
+      ≈-trans (hh (at (m-rec₁ p)) (at ε)) (zap-l M.εₘ (graphM C (at (m-rec₁ p)) (at (m-rec₁ ε))))
+    base₁ .body-root p =
+      ≈-trans (hh (at (m-rec₂ p)) (at ε)) (zap-l (edge M.I p) (graphM C (at (m-rec₂ p)) (at (m-rec₁ ε))))
+
+  record Phase₂ (G : GraphM C) (H : Graph D₂) : Set ℓ where
+    field
+      env-body   : ∀ q → G env (at (m-rec₂ q)) M.≈ₘ (H env (at q) M.∘ Wₑ)
+      input-body : ∀ q → G input (at (m-rec₂ q)) M.≈ₘ (H env (at q) M.∘ Wᵢ)
+      body-body  : ∀ p q → G (at (m-rec₂ p)) (at (m-rec₂ q)) M.≈ₘ H (at p) (at q)
+      env-root   : G env (at ε) M.≈ₘ (H env (at ε) M.∘ Wₑ)
+      input-root : G input (at ε) M.≈ₘ (H env (at ε) M.∘ Wᵢ)
+      body-root  : ∀ p → is-ε p ≡ Bool.false → G (at (m-rec₂ p)) (at ε) M.≈ₘ H (at p) (at ε)
+
+  open Phase₂
+
+  step₂ : ∀ {G H} (v : Path D₂) → is-ε v ≡ Bool.false →
+          Phase₂ G H → Phase₂ (hide-m G (at (m-rec₂ v))) (hide H (at v))
+  step₂ v nv r .env-body q = step-under {W = Wₑ} (r .env-body q) (r .body-body v q) (r .env-body v)
+  step₂ v nv r .input-body q = step-under {W = Wᵢ} (r .input-body q) (r .body-body v q) (r .input-body v)
+  step₂ v nv r .body-body p q = +ₘ-cong (r .body-body p q) (∘-cong (r .body-body v q) (r .body-body p v))
+  step₂ v nv r .env-root = step-under {W = Wₑ} (r .env-root) (r .body-root v nv) (r .env-body v)
+  step₂ v nv r .input-root = step-under {W = Wᵢ} (r .input-root) (r .body-root v nv) (r .input-body v)
+  step₂ v nv r .body-root p np = +ₘ-cong (r .body-root p np) (∘-cong (r .body-root v nv) (r .body-body p v))
+
+  steps₂ : ∀ {G H} (ws : List (Path D₂)) → All (λ v → is-ε v ≡ Bool.false) ws →
+           Phase₂ G H → Phase₂ (hide-all-m G (map at (map m-rec₂ ws))) (hide-all H (map at ws))
+  steps₂ []       []         r = r
+  steps₂ (v ∷ ws) (nv ∷ nws) r = steps₂ ws nws (step₂ v nv r)
+
+  private
+    PA : GraphM C
+    PA = hide-all-m (hide-m (hide-m (graphM C) (at ε)) (at (m-rec₁ ε)))
+                    (map at (map m-rec₁ (interior-m D₁)))
+
+    r1 : Phase₁ PA (hide-all-m (hide-m (graphM D₁) (at ε)) (map at (interior-m D₁)))
+    r1 = steps₁ (interior-m D₁) (interior-not-root-m D₁) base₁
+
+    base₂ : Phase₂ (hide-m PA (at (m-rec₂ ε))) (hide (graph D₂) (at ε))
+    base₂ .env-body q =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .env-body q) (factor (B q) (collapse-m-env D₁)))
+                       (∘-cong₁ (≈-trans (r1 .body-body ε q) (root-sink D₂ (at q)))))
+      (≈-trans (absorb (B q M.∘ Wₑ) (PA env (at (m-rec₂ ε)))) (≈-sym (∘-cong₁ (hide-root D₂ env (at q)))))
+    base₂ .input-body q =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .input-body q) (assoc (B q) iᵣ (collapse-m-in D₁)))
+                       (∘-cong₁ (≈-trans (r1 .body-body ε q) (root-sink D₂ (at q)))))
+      (≈-trans (absorb (B q M.∘ Wᵢ) (PA input (at (m-rec₂ ε)))) (≈-sym (∘-cong₁ (hide-root D₂ env (at q)))))
+    base₂ .body-body p q =
+      +ₘ-cong (r1 .body-body p q) (∘-cong (r1 .body-body ε q) (r1 .body-body p ε))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (r1 .env-root)
+                       (∘-cong (r1 .body-root ε)
+                               (≈-trans (r1 .env-body ε) (factor (B ε) (collapse-m-env D₁)))))
+      (≈-trans (+ₘ-lunit (M.I M.∘ (B ε M.∘ Wₑ)))
+      (≈-trans id-left (≈-sym (∘-cong₁ (hide-root D₂ env (at ε))))))
+    base₂ .input-root =
+      ≈-trans (+ₘ-cong (r1 .input-root)
+                       (∘-cong (r1 .body-root ε)
+                               (≈-trans (r1 .input-body ε) (assoc (B ε) iᵣ (collapse-m-in D₁)))))
+      (≈-trans (+ₘ-lunit (M.I M.∘ (B ε M.∘ Wᵢ))) (≈-trans id-left (≈-sym (∘-cong₁ (hide-root D₂ env (at ε))))))
+    base₂ .body-root p np =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .body-root p) (edge-off M.I p np))
+                       (∘-cong (r1 .body-root ε) (r1 .body-body p ε)))
+      (≈-trans (into-hidden D₂ M.I (at p)) id-left)
+
+    rfin = steps₂ (interior D₂) (interior-not-root D₂) base₂
+
+    plumbG : hide-all-m (hide-m (graphM C) (at ε)) (map at (map m-rec₁ (paths-m D₁) ++ map m-rec₂ (paths D₂)))
+             ≡ hide-all-m (hide-all-m (hide-m (graphM C) (at ε)) (map at (map m-rec₁ (paths-m D₁))))
+                          (map at (map m-rec₂ (paths D₂)))
+    plumbG =
+      ≡-trans (≡-cong (hide-all-m (hide-m (graphM C) (at ε)))
+                      (map-++ at (map m-rec₁ (paths-m D₁)) (map m-rec₂ (paths D₂))))
+              (hide-all-m-++ (hide-m (graphM C) (at ε))
+                             (map at (map m-rec₁ (paths-m D₁)))
+                             (map at (map m-rec₂ (paths D₂))))
+
+  agree-env : collapse-m-env C M.≈ₘ (collapse D₂ M.∘ Wₑ)
+  agree-env =
+    ≈-trans (≈-of-≡ (≡-cong (λ Gg → Gg env (at ε)) plumbG)) (rfin .env-root)
+
+  agree-in : collapse-m-in C M.≈ₘ (collapse D₂ M.∘ Wᵢ)
+  agree-in =
+    ≈-trans (≈-of-≡ (≡-cong (λ Gg → Gg input (at ε)) plumbG)) (rfin .input-root)
+
+  combine : ∀ {Rp : width-env γ ⇒ width w'} {Sp : width-env (γ · w') ⇒ width u} →
+            ((collapse-m-env D₁ M.+ₘ (collapse-m-in D₁ M.∘ R)) M.≈ₘ Rp) →
+            (collapse D₂ M.≈ₘ Sp) →
+            ((collapse-m-env C M.+ₘ (collapse-m-in C M.∘ R))
+             M.≈ₘ (Sp M.∘ ((iₗ M.∘ M.I) M.+ₘ (iᵣ M.∘ Rp))))
+  combine {Rp} {Sp} ihm ihe =
+    ≈-trans (+ₘ-cong agree-env (∘-cong₁ agree-in))
+    (≈-trans (+ₘ-cong (≈-refl {f = collapse D₂ M.∘ Wₑ}) (assoc (collapse D₂) Wᵢ R))
+    (≈-trans (≈-sym (M.comp-bilinear₂ (collapse D₂) Wₑ (Wᵢ M.∘ R)))
+    (≈-trans (∘-cong ihe
+              (≈-trans (+ₘ-assoc iₗ (iᵣ M.∘ collapse-m-env D₁) ((iᵣ M.∘ collapse-m-in D₁) M.∘ R))
+              (≈-trans (+ₘ-cong (≈-refl {f = iₗ})
+                                (distrib-root iᵣ (collapse-m-env D₁) (collapse-m-in D₁) R))
+                       (+ₘ-cong (≈-refl {f = iₗ}) (∘-cong₂ ihm)))))
+             (∘-cong₂ (+ₘ-cong (≈-sym (id-right {f = iₗ})) (≈-refl {f = iᵣ M.∘ Rp}))))))
+
+
+-- The fold rule: the subject premise, then the fold action with its input wired to the subject's
+-- root, so the collapse resolves the action's input dependence through the subject's collapse.
+module Fold {Γ} {τ : type 1} {σ : type 0} {γ : Env Γ} {s : Γ ▸ τ [ σ ] ⊢ σ} {t : Γ ⊢ μ τ}
+            {v : Val (μ τ)} {R : width-env γ ⇒ width v} {u : Val σ}
+            {R' : width-env γ ⇒ width u}
+            {D₁ : γ , t ⇓ v [ R ]} {D₂ : Map γ {τ} {σ} s (var Fin.zero) v R u R'} where
+
+  private
+    C = ⇓-fold D₁ D₂
+
+  record Phase₁ (G : Graph C) (H : Graph D₁) : Set ℓ where
+    field
+      env-t     : ∀ q → G env (at (fold₁ q)) M.≈ₘ H env (at q)
+      t-t       : ∀ p q → G (at (fold₁ p)) (at (fold₁ q)) M.≈ₘ H (at p) (at q)
+      env-body  : ∀ q → G env (at (fold₂ q))
+                  M.≈ₘ (graphM D₂ env (at q) M.+ₘ (graphM D₂ input (at q) M.∘ H env (at ε)))
+      t-body    : ∀ p → is-ε p ≡ Bool.false → ∀ q →
+                  G (at (fold₁ p)) (at (fold₂ q)) M.≈ₘ (graphM D₂ input (at q) M.∘ H (at p) (at ε))
+      body-body : ∀ p q → G (at (fold₂ p)) (at (fold₂ q)) M.≈ₘ graphM D₂ (at p) (at q)
+      body-t    : ∀ p q → G (at (fold₂ p)) (at (fold₁ q)) M.≈ₘ M.εₘ
+      env-root  : G env (at ε) M.≈ₘ M.εₘ
+      t-root    : ∀ p → G (at (fold₁ p)) (at ε) M.≈ₘ M.εₘ
+      body-root : ∀ p → G (at (fold₂ p)) (at ε) M.≈ₘ edge-m M.I p
+
+  open Phase₁
+
+  step₁ : ∀ {G H} (w : Path D₁) → is-ε w ≡ Bool.false →
+            Phase₁ G H → Phase₁ (hide G (at (fold₁ w))) (hide H (at w))
+  step₁ w nw r .env-t q  = +ₘ-cong (r .env-t q) (∘-cong (r .t-t w q) (r .env-t w))
+  step₁ w nw r .t-t p q = +ₘ-cong (r .t-t p q) (∘-cong (r .t-t w q) (r .t-t p w))
+  step₁ w nw r .env-body q =
+    offset-step {K = graphM D₂ env (at q)} {P = graphM D₂ input (at q)}
+                (r .env-body q) (r .t-body w nw q) (r .env-t w)
+  step₁ w nw r .t-body p np q =
+    root-step {P = graphM D₂ input (at q)} (r .t-body p np q) (r .t-body w nw q) (r .t-t p w)
+  step₁ w nw r .body-body p q = keep-r (r .body-body p q) (r .body-t p w)
+  step₁ w nw r .body-t p q = keep-r (r .body-t p q) (r .body-t p w)
+  step₁ w nw r .env-root = keep-l (r .env-root) (r .t-root w)
+  step₁ w nw r .t-root p = keep-l (r .t-root p) (r .t-root w)
+  step₁ w nw r .body-root p = keep-l (r .body-root p) (r .t-root w)
+
+  steps₁ : ∀ {G H} (ws : List (Path D₁)) → All (λ w → is-ε w ≡ Bool.false) ws →
+             Phase₁ G H → Phase₁ (hide-all G (map at (map fold₁ ws))) (hide-all H (map at ws))
+  steps₁ []       []         r = r
+  steps₁ (w ∷ ws) (nw ∷ nws) r = steps₁ ws nws (step₁ w nw r)
+
+  private
+    hh : ∀ x y → hide (hide (graph C) (at ε)) (at (fold₁ ε)) x y
+         M.≈ₘ (graph C x y M.+ₘ (graph C (at (fold₁ ε)) y M.∘ graph C x (at (fold₁ ε))))
+    hh = hide-hide-root C (at (fold₁ ε))
+
+    base₁ : Phase₁ (hide (hide (graph C) (at ε)) (at (fold₁ ε))) (hide (graph D₁) (at ε))
+    base₁ .env-t q  = hh env (at (fold₁ q))
+    base₁ .t-t p q = hh (at (fold₁ p)) (at (fold₁ q))
+    base₁ .env-body q =
+      ≈-trans (hh env (at (fold₂ q)))
+              (+ₘ-cong (≈-refl {f = graphM D₂ env (at q)}) (∘-cong₂ (≈-sym (hide-root D₁ env (at ε)))))
+    base₁ .t-body p np q =
+      ≈-trans (hh (at (fold₁ p)) (at (fold₂ q)))
+      (≈-trans (+ₘ-cong (edge-off (graphM D₂ input (at q)) p np) ≈-refl)
+               (into-hidden D₁ (graphM D₂ input (at q)) (at p)))
+    base₁ .body-body p q =
+      ≈-trans (hh (at (fold₂ p)) (at (fold₂ q)))
+              (zap-r (graphM D₂ (at p) (at q)) (graph C (at (fold₁ ε)) (at (fold₂ q))))
+    base₁ .body-t p q =
+      ≈-trans (hh (at (fold₂ p)) (at (fold₁ q))) (zap-r M.εₘ (graph C (at (fold₁ ε)) (at (fold₁ q))))
+    base₁ .env-root = ≈-trans (hh env (at ε)) (zap-l M.εₘ (graph C env (at (fold₁ ε))))
+    base₁ .t-root p =
+      ≈-trans (hh (at (fold₁ p)) (at ε)) (zap-l M.εₘ (graph C (at (fold₁ p)) (at (fold₁ ε))))
+    base₁ .body-root p =
+      ≈-trans (hh (at (fold₂ p)) (at ε)) (zap-l (edge-m M.I p) (graph C (at (fold₂ p)) (at (fold₁ ε))))
+
+  record Phase₂ (G : Graph C) (H : GraphM D₂) : Set ℓ where
+    field
+      env-body  : ∀ q → G env (at (fold₂ q)) M.≈ₘ (H env (at q) M.+ₘ (H input (at q) M.∘ collapse D₁))
+      body-body : ∀ p q → G (at (fold₂ p)) (at (fold₂ q)) M.≈ₘ H (at p) (at q)
+      env-root  : G env (at ε) M.≈ₘ (H env (at ε) M.+ₘ (H input (at ε) M.∘ collapse D₁))
+      body-root : ∀ p → is-ε-m p ≡ Bool.false → G (at (fold₂ p)) (at ε) M.≈ₘ H (at p) (at ε)
+
+  open Phase₂
+
+  step₂ : ∀ {G H} (w : PathM D₂) → is-ε-m w ≡ Bool.false →
+            Phase₂ G H → Phase₂ (hide G (at (fold₂ w))) (hide-m H (at w))
+  step₂ w nw r .env-body q =
+    pair-source-step {W = collapse D₁} (r .env-body q) (r .body-body w q) (r .env-body w)
+  step₂ w nw r .body-body p q = +ₘ-cong (r .body-body p q) (∘-cong (r .body-body w q) (r .body-body p w))
+  step₂ w nw r .env-root =
+    pair-source-step {W = collapse D₁} (r .env-root) (r .body-root w nw) (r .env-body w)
+  step₂ w nw r .body-root p np = +ₘ-cong (r .body-root p np) (∘-cong (r .body-root w nw) (r .body-body p w))
+
+  steps₂ : ∀ {G H} (ws : List (PathM D₂)) → All (λ w → is-ε-m w ≡ Bool.false) ws →
+             Phase₂ G H → Phase₂ (hide-all G (map at (map fold₂ ws))) (hide-all-m H (map at ws))
+  steps₂ []       []         r = r
+  steps₂ (w ∷ ws) (nw ∷ nws) r = steps₂ ws nws (step₂ w nw r)
+
+  private
+    PA : Graph C
+    PA = hide-all (hide (hide (graph C) (at ε)) (at (fold₁ ε))) (map at (map fold₁ (interior D₁)))
+
+    r1 : Phase₁ PA (hide-all (hide (graph D₁) (at ε)) (map at (interior D₁)))
+    r1 = steps₁ (interior D₁) (interior-not-root D₁) base₁
+
+    base₂ : Phase₂ (hide PA (at (fold₂ ε))) (hide-m (graphM D₂) (at ε))
+    base₂ .env-body q =
+      pair-source-step {W = collapse D₁} (r1 .env-body q) (r1 .body-body ε q) (r1 .env-body ε)
+    base₂ .body-body p q =
+      +ₘ-cong (r1 .body-body p q) (∘-cong (r1 .body-body ε q) (r1 .body-body p ε))
+    base₂ .env-root =
+      ≈-trans (+ₘ-cong (r1 .env-root) (∘-cong (r1 .body-root ε) (r1 .env-body ε)))
+      (≈-trans (+ₘ-lunit (M.I M.∘ (graphM D₂ env (at ε)
+                                   M.+ₘ (graphM D₂ input (at ε) M.∘ collapse D₁))))
+      (≈-trans id-left
+               (+ₘ-cong (≈-sym (hide-root-m D₂ env (at ε)))
+                        (∘-cong₁ (≈-sym (hide-root-m D₂ input (at ε)))))))
+    base₂ .body-root p np =
+      ≈-trans (+ₘ-cong (≈-trans (r1 .body-root p) (edge-off-m M.I p np))
+                       (∘-cong (r1 .body-root ε) (r1 .body-body p ε)))
+      (≈-trans (into-hidden-m D₂ M.I (at p)) id-left)
+
+    rfin = steps₂ (interior-m D₂) (interior-not-root-m D₂) base₂
+
+    plumbG : hide-all (hide (graph C) (at ε)) (map at (map fold₁ (paths D₁) ++ map fold₂ (paths-m D₂)))
+             ≡ hide-all (hide-all (hide (graph C) (at ε)) (map at (map fold₁ (paths D₁))))
+                        (map at (map fold₂ (paths-m D₂)))
+    plumbG =
+      ≡-trans (≡-cong (hide-all (hide (graph C) (at ε)))
+                      (map-++ at (map fold₁ (paths D₁)) (map fold₂ (paths-m D₂))))
+              (hide-all-++ (hide (graph C) (at ε))
+                           (map at (map fold₁ (paths D₁)))
+                           (map at (map fold₂ (paths-m D₂))))
+
+  agree : collapse (⇓-fold D₁ D₂) M.≈ₘ (collapse-m-env D₂ M.+ₘ (collapse-m-in D₂ M.∘ collapse D₁))
+  agree =
+    ≈-trans (≈-of-≡ (≡-cong (λ Gg → Gg env (at ε)) plumbG)) (rfin .env-root)
+
+subst-rcast : ∀ {g m m'} (e : m ≡ m') (X : g ⇒ m) → subst (g ⇒_) e X ≡ rcast e X
+subst-rcast ≡-refl X = ≡-refl
+
+-- The trivial operand list.
+agree-s-nil : ∀ {Γ} {γ : Env Γ} → collapse-s ([] {γ = γ}) M.≈ₘ to-terminal
+agree-s-nil ()
+
+-- Agreement: collapsing a derivation's graph recovers its relation, mutually across the three
+-- judgement forms; the fold-action statement resolves the input dependence through R.
+mutual
+  agree : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → collapse D M.≈ₘ R
+  agree (⇓-var x)      = agree-var x
+  agree {γ = γ} ⇓-unit = agree-unit {γ = γ}
+  agree {γ = γ} (⇓-inl {τ₂ = τ₂} {t = ti} {v = v} {R = R} D) =
+    ≈-trans (Inl.agree {τ₂ = τ₂} {γ = γ} {t = ti} {v = v} {R = R} {D = D}) (agree D)
+  agree {γ = γ} (⇓-inr {τ₁ = τ₁} {t = ti} {v = v} {R = R} D) =
+    ≈-trans (Inr.agree {τ₁ = τ₁} {γ = γ} {t = ti} {v = v} {R = R} {D = D}) (agree D)
+  agree {γ = γ} (⇓-case-l {s = sc} {t₁ = t₁} {t₂ = t₂} {v = v} {u = u} {R = R} {S = S} D₁ D₂) =
+    ≈-trans (CaseL.agree {γ = γ} {ts = sc} {t₁ = t₁} {t₂ = t₂} {v = v} {u = u}
+                                {R = R} {S = S} {D₁ = D₁} {D₂ = D₂})
+            (∘-cong (agree D₂)
+                    (+ₘ-cong (≈-sym id-right) (∘-cong₂ (agree D₁))))
+  agree {γ = γ} (⇓-case-r {s = sc} {t₁ = t₁} {t₂ = t₂} {v = v} {u = u} {R = R} {S = S} D₁ D₂) =
+    ≈-trans (CaseR.agree {γ = γ} {ts = sc} {t₁ = t₁} {t₂ = t₂} {v = v} {u = u}
+                                {R = R} {S = S} {D₁ = D₁} {D₂ = D₂})
+            (∘-cong (agree D₂)
+                    (+ₘ-cong (≈-sym id-right) (∘-cong₂ (agree D₁))))
+  agree {γ = γ} (⇓-pair {s = sp} {t = tp} {v = v} {u = u} {R = R} {S = S} D₁ D₂) =
+    ≈-trans (Pair.agree {γ = γ} {ts = sp} {tt = tp} {v = v} {u = u} {R = R} {S = S}
+                             {D₁ = D₁} {D₂ = D₂})
+            (+ₘ-cong (∘-cong₂ (agree D₁)) (∘-cong₂ (agree D₂)))
+  agree {γ = γ} (⇓-fst {τ₁ = τ₁} {τ₂ = τ₂} {t = tp} {v = v} {u = u} {R = R} D) =
+    ≈-trans (Fst.agree {γ = γ} {t = tp} {v = v} {u = u} {R = R} {D = D}) (∘-cong₂ (agree D))
+  agree {γ = γ} (⇓-snd {τ₁ = τ₁} {τ₂ = τ₂} {t = tp} {v = v} {u = u} {R = R} D) =
+    ≈-trans (Snd.agree {γ = γ} {t = tp} {v = v} {u = u} {R = R} {D = D}) (∘-cong₂ (agree D))
+  agree {γ = γ} (⇓-lam {σ = σl} {τ = τl} {t = tλ}) =
+    agree-lam {σ = σl} {τ = τl} {γ = γ} {t = tλ}
+  agree {γ = γ} (⇓-app {Γ' = Γ'} {σ = σa} {τ = τa} {γ' = γ'} {s = sa} {t = ta} {t' = ta'}
+                       {v = v} {u = u} {R = R} {S = S} {T = T} D₁ D₂ D₃) =
+    ≈-trans (App.agree {Γ' = Γ'} {γ = γ} {γ' = γ'} {ts = sa} {tt = ta} {tb = ta'}
+                           {v = v} {u = u} {R = R} {S = S} {T = T}
+                           {D₁ = D₁} {D₂ = D₂} {D₃ = D₃})
+            (∘-cong (agree D₃) (+ₘ-cong (∘-cong₂ (agree D₁)) (∘-cong₂ (agree D₂))))
+  agree {γ = γ} (⇓-bop {ω = ω} {Ms = Ms} {vs = vs} {R = R} D) =
+    ≈-trans (Bop.agree {γ = γ} {ω = ω} {Ms = Ms} {vs = vs} {Rs = R} {D = D})
+            (∘-cong₂ (agree-s D))
+  agree {γ = γ} (⇓-brel {ω = ω} {Ms = Ms} {vs = vs} {R = R} D) =
+    agree-brel {γ = γ} {ω = ω} {Ms = Ms} {vs = vs} {Rs = R} {D = D}
+  agree {γ = γ} (⇓-roll {τ = τr} {t = tr} {v = v} {R = R} D) =
+    ≈-trans (Roll.agree {τ = τr} {γ = γ} {t = tr} {v = v} {R = R} {D = D}) (agree D)
+  agree {γ = γ} (⇓-fold {τ = τf} {σ = σf} {s = sf} {t = tf} {v = v} {u = u} {R = R} {R' = R'}
+                        D₁ D₂) =
+    ≈-trans (Fold.agree {γ = γ} {s = sf} {t = tf} {v = v} {R = R} {u = u} {R' = R'}
+                             {D₁ = D₁} {D₂ = D₂})
+    (≈-trans (+ₘ-cong (≈-refl {f = collapse-m-env D₂}) (∘-cong₂ (agree D₁)))
+             (agree-m D₂))
+
+  agree-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+            (D : γ , Ms ⇓s vs [ R ]) → collapse-s D M.≈ₘ R
+  agree-s {γ = γ} [] = agree-s-nil {γ = γ}
+  agree-s {γ = γ} (_∷_ {i = i} {is = is} {v = v} {vs = vs} {R = R} {Rs = Rs} {M = Mt} {Ms = Ms} D₁ D₂) =
+    ≈-trans (SCons.agree {γ = γ} {M = Mt} {Ms = Ms} {v = v} {vs = vs} {R = R} {Rs = Rs} {D₁ = D₁} {D₂ = D₂})
+            (+ₘ-cong (∘-cong₂ (agree D₁)) (∘-cong₂ (agree-s D₂)))
+
+  agree-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+            {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+            (D : Map γ s σ' v R v' R') →
+            (collapse-m-env D M.+ₘ (collapse-m-in D M.∘ R)) M.≈ₘ R'
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s}
+          (m-rec {w = w} {w' = w'} {u = u} {R = R} {R' = R'} {S = S} D₁ D₂) =
+    MRec.combine {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {w = w} {R = R} {w' = w'} {R' = R'}
+                 {u = u} {S = S} {D₁ = D₁} {D₂ = D₂} (agree-m D₁) (agree D₂)
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} (m-unit {v = v} {R = R}) =
+    agree-m-unit {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {v = v} {R = R}
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} (m-base {b = b} {v = v} {R = R}) =
+    agree-m-base {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {b = b} {v = v} {R = R}
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} (m-arrow {σ₁ = σ₁} {σ₂ = σ₂} {v = v} {R = R}) =
+    agree-m-arrow {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {σ₁ = σ₁} {σ₂ = σ₂} {v = v} {R = R}
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s}
+          (m-inl {σ₁ = σ₁} {σ₂ = σ₂} {v = v} {v' = v'} {R = R} {R' = R'} D) =
+    ≈-trans (+ₘ-cong (MInl.agree-env {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {σ₁ = σ₁}
+                                          {σ₂ = σ₂} {v = v} {R = R} {v' = v'} {R' = R'} {D = D})
+                     (∘-cong₁ (MInl.agree-in {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {σ₁ = σ₁}
+                                                  {σ₂ = σ₂} {v = v} {R = R} {v' = v'} {R' = R'}
+                                                  {D = D})))
+            (agree-m D)
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s}
+          (m-inr {σ₁ = σ₁} {σ₂ = σ₂} {v = v} {v' = v'} {R = R} {R' = R'} D) =
+    ≈-trans (+ₘ-cong (MInr.agree-env {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {σ₁ = σ₁}
+                                          {σ₂ = σ₂} {v = v} {R = R} {v' = v'} {R' = R'} {D = D})
+                     (∘-cong₁ (MInr.agree-in {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {σ₁ = σ₁}
+                                                  {σ₂ = σ₂} {v = v} {R = R} {v' = v'} {R' = R'}
+                                                  {D = D})))
+            (agree-m D)
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s}
+          (m-pair {σ₁ = σ₁} {σ₂ = σ₂} {v = v} {v' = v'} {u = u} {u' = u'} {R = R} {S = S} {T = T}
+                  D₁ D₂) =
+    MPair.combine {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {σ₁ = σ₁} {σ₂ = σ₂} {v = v} {u = u}
+                  {R = R} {v' = v'} {S₁ = S} {u' = u'} {T = T} {D₁ = D₁} {D₂ = D₂}
+                  (agree-m D₁) (agree-m D₂)
+  agree-m {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} (m-mu {τ' = τ'} {w = w} {w' = w'} {R = R₀} {R' = R₀'} D) =
+    ≈-trans (+ₘ-cong (MMu.agree-env {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {τ' = τ'}
+                                        {w = w} {R = R₀} {w' = w'} {R' = R₀'} {D = D})
+                     (∘-cong₁ (MMu.agree-in {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} {τ' = τ'}
+                                                {w = w} {R = R₀} {w' = w'} {R' = R₀'} {D = D})))
+    (≈-trans (≈-of-≡ (≡-cong
+               (λ Z → rcast e' (collapse-m-env D)
+                      M.+ₘ (rcast e' (ccast eᵥ (collapse-m-in D)) M.∘ Z))
+               (subst-rcast eᵥ R₀)))
+    (≈-trans (+ₘ-cong (≈-refl {f = rcast e' (collapse-m-env D)})
+                      (≈-trans (rcast-∘ e' (ccast eᵥ (collapse-m-in D)) (rcast eᵥ R₀))
+                               (rcast-cong e' (ccast-rcast-∘ eᵥ (collapse-m-in D) R₀))))
+    (≈-trans (+ₘ-rcast e' (collapse-m-env D) (collapse-m-in D M.∘ R₀))
+    (≈-trans (rcast-cong e' (agree-m D)) (≈-of-≡ (≡-sym (subst-rcast e' R₀')))))))
+    where
+      eᵥ = ≡-sym (width-subst (unfold₁-inst τ' (μ τ₀)) w)
+      e' = ≡-sym (width-subst (unfold₁-inst τ' σr) w')
diff --git a/agda/src/language-operational/evaluation.agda b/agda/src/language-operational/evaluation.agda
new file mode 100644
index 00000000..f8d0c7cd
--- /dev/null
+++ b/agda/src/language-operational/evaluation.agda
@@ -0,0 +1,161 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (0ℓ) renaming (_⊔_ to _⊔ℓ_)
+open import Data.Fin using (Fin; zero; suc)
+open import Data.List using (List; []; _∷_)
+open import Data.Nat using (ℕ; zero; suc; _+_)
+open import Data.Product using (_,_)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Data.Unit.Polymorphic using (⊤; tt)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; subst)
+open import prop-setoid using (Setoid)
+open import commutative-semiring using (CommutativeSemiring)
+open import every using (Every; []; _∷_)
+open import signature using (Signature)
+open import primitives using (Primitives)
+import matrix
+import cmon-enriched
+open import categories using (Category; HasProducts; HasTerminal)
+import two
+
+-- Values, environments, and big-step evaluation decorated with dependency relations.
+module language-operational.evaluation {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open prop-setoid._⇒_ using (func)
+open import language-syntax Sig renaming (_,_ to _▸_)
+open import type-substitution Sig using (unfold₁; unfold₁-inst)
+
+mutual
+  data Val : type 0 → Set ℓ where
+    unit  : Val unit
+    const : ∀ {s} → sort-val s → Val (base s)
+    inl   : ∀ {τ₁ τ₂} → Val τ₁ → Val (τ₁ [+] τ₂)
+    inr   : ∀ {τ₁ τ₂} → Val τ₂ → Val (τ₁ [+] τ₂)
+    pair  : ∀ {τ₁ τ₂} → Val τ₁ → Val τ₂ → Val (τ₁ [×] τ₂)
+    clo   : ∀ {Γ σ τ} → Env Γ → (Γ ▸ σ) ⊢ τ → Val (σ [→] τ)
+    roll  : ∀ {τ : type 1} → Val (τ [ μ τ ]) → Val (μ τ)
+
+  data Env : ctxt → Set ℓ where
+    emp : Env emp
+    _·_ : ∀ {Γ τ} → Env Γ → Val τ → Env (Γ ▸ τ)
+
+infixl 30 _·_
+
+lookup : ∀ {Γ τ} → Γ ∋ τ → Env Γ → Val τ
+lookup zero     (γ · v) = v
+lookup (succ x) (γ · _) = lookup x γ
+
+bool→val : ⊤ {0ℓ} ⊎ ⊤ {0ℓ} → Val (unit [+] unit)
+bool→val (inj₁ _) = inl unit
+bool→val (inj₂ _) = inr unit
+
+private
+  module M = matrix.Mat two.semiring
+
+open Category M.cat using (_⇒_; _∘_) renaming (id to idm)
+open HasTerminal M.terminal using (to-terminal)
+
+products : HasProducts M.cat
+products = cmon-enriched.biproducts→products M.cmon M.biproduct
+
+open HasProducts products using (p₁; p₂) renaming (pair to ⟨_,_⟩)
+
+mutual
+  width : ∀ {τ} → Val τ → ℕ
+  width unit        = 0
+  width (const {s} _) = sort-width s
+  width (inl v)     = width v
+  width (inr v)     = width v
+  width (pair v u)  = width v + width u
+  width (clo γ _)   = width-env γ
+  width (roll v)    = width v
+
+  width-env : ∀ {Γ} → Env Γ → ℕ
+  width-env emp     = 0
+  width-env (γ · v) = width-env γ + width v
+
+width-subst : ∀ {τ τ'} (e : τ ≡ τ') (v : Val τ) → width (subst Val e v) ≡ width v
+width-subst refl v = refl
+
+proj-var : ∀ {Γ τ} (x : Γ ∋ τ) (γ : Env Γ) → width-env γ ⇒ width (lookup x γ)
+proj-var zero     (γ · v) = p₂ {width-env γ} {width v}
+proj-var (succ x) (γ · v) = proj-var x γ ∘ p₁ {width-env γ} {width v}
+
+-- Case on the branch so that the width computes.
+brel-mat : ∀ {Γ} (γ : Env Γ) (b : ⊤ {0ℓ} ⊎ ⊤ {0ℓ}) → width-env γ ⇒ width (bool→val b)
+brel-mat γ (inj₁ _) = to-terminal {width-env γ}
+brel-mat γ (inj₂ _) = to-terminal {width-env γ}
+
+mutual
+  data _,_⇓_[_] : ∀ {Γ τ} (γ : Env Γ) (t : Γ ⊢ τ) (v : Val τ) →
+                   width-env γ ⇒ width v → Set ℓ where
+    ⇓-var    : ∀ {Γ τ} {γ : Env Γ} (x : Γ ∋ τ) → γ , var x ⇓ lookup x γ [ proj-var x γ ]
+    ⇓-unit   : ∀ {Γ} {γ : Env Γ} → γ , unit ⇓ unit [ to-terminal ]
+    ⇓-inl    : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁} {v R} →
+               γ , t ⇓ v [ R ] → γ , inl {τ₂ = τ₂} t ⇓ inl v [ R ]
+    ⇓-inr    : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₂} {v R} →
+               γ , t ⇓ v [ R ] → γ , inr {τ₁ = τ₁} t ⇓ inr v [ R ]
+    ⇓-case-l : ∀ {Γ τ₁ τ₂ τ} {γ : Env Γ} {s : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+               {v u R S} →
+               γ , s ⇓ inl v [ R ] → γ · v , t₁ ⇓ u [ S ] →
+               γ , case s t₁ t₂ ⇓ u [ S ∘ ⟨ idm _ , R ⟩ ]
+    ⇓-case-r : ∀ {Γ τ₁ τ₂ τ} {γ : Env Γ} {s : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+               {v u R S} →
+               γ , s ⇓ inr v [ R ] → γ · v , t₂ ⇓ u [ S ] →
+               γ , case s t₁ t₂ ⇓ u [ S ∘ ⟨ idm _ , R ⟩ ]
+    ⇓-pair   : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {s : Γ ⊢ τ₁} {t : Γ ⊢ τ₂} {v u R S} →
+               γ , s ⇓ v [ R ] → γ , t ⇓ u [ S ] → γ , pair s t ⇓ pair v u [ ⟨ R , S ⟩ ]
+    ⇓-fst    : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁ [×] τ₂} {v u R} →
+               γ , t ⇓ pair v u [ R ] → γ , fst t ⇓ v [ p₁ ∘ R ]
+    ⇓-snd    : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁ [×] τ₂} {v u R} →
+               γ , t ⇓ pair v u [ R ] → γ , snd t ⇓ u [ p₂ ∘ R ]
+    ⇓-lam    : ∀ {Γ σ τ} {γ : Env Γ} {t : Γ ▸ σ ⊢ τ} → γ , lam t ⇓ clo γ t [ idm _ ]
+    ⇓-app    : ∀ {Γ Γ' σ τ} {γ : Env Γ} {γ' : Env Γ'} {s : Γ ⊢ σ [→] τ} {t t' v u R S T} →
+               γ , s ⇓ clo {Γ'} γ' t' [ R ] → γ , t ⇓ v [ S ] → γ' · v , t' ⇓ u [ T ] →
+               γ , app s t ⇓ u [ T ∘ ⟨ R , S ⟩ ]
+    ⇓-bop    : ∀ {Γ is o'} {γ : Env Γ} {ω : op is o'} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R} →
+               γ , Ms ⇓s vs [ R ] → γ , bop ω Ms ⇓ const (op-fun ω .func vs) [ op-deps ω .func vs ∘ R ]
+    ⇓-brel   : ∀ {Γ is} {γ : Env Γ} {ω : rel is} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R} →
+               γ , Ms ⇓s vs [ R ] → γ , brel ω Ms ⇓ bool→val (rel-pred ω .func vs) [ brel-mat γ (rel-pred ω .func vs) ]
+    ⇓-roll   : ∀ {Γ} {τ : type 1} {γ : Env Γ} {t : Γ ⊢ τ [ μ τ ]} {v R} →
+               γ , t ⇓ v [ R ] → γ , roll {τ = τ} t ⇓ roll {τ} v [ R ]
+    ⇓-fold   : ∀ {Γ} {τ : type 1} {σ : type 0} {γ : Env Γ} {s : Γ ▸ τ [ σ ] ⊢ σ} {t : Γ ⊢ μ τ}
+               {v u R R'} →
+               γ , t ⇓ v [ R ] → Map γ {τ} {σ} s (var zero) v R u R' → γ , fold s t ⇓ u [ R' ]
+
+  data _,_⇓s_[_] {Γ} (γ : Env Γ) : ∀ {is} → Every (λ s → Γ ⊢ base s) is →
+                  sort-vals is → width-env γ ⇒ bases-width is →
+                  Set ℓ where
+    []  : γ , [] ⇓s tt [ to-terminal ]
+    _∷_ : ∀ {i is v vs R Rs} {M : Γ ⊢ base i} {Ms : Every (λ s → Γ ⊢ base s) is} →
+          γ , M ⇓ const v [ R ] → γ , Ms ⇓s vs [ Rs ] → γ , (M ∷ Ms) ⇓s (v , vs) [ ⟨ R , Rs ⟩ ]
+
+  -- Functorial action of σ' on the fold s, threading dependency matrices.
+  data Map {Γ} (γ : Env Γ) {τ₀ : type 1} {σr : type 0} (s : Γ ▸ τ₀ [ σr ] ⊢ σr) :
+           (σ' : type 1) (v : Val (σ' [ μ τ₀ ])) → width-env γ ⇒ width v →
+           (v' : Val (σ' [ σr ])) → width-env γ ⇒ width v' →
+           Set ℓ where
+    m-rec   : ∀ {w w' u R R' S} →
+              Map γ s τ₀ w R w' R' → γ · w' , s ⇓ u [ S ] →
+              Map γ s (var zero) (roll w) R u (S ∘ ⟨ idm _ , R' ⟩)
+    m-unit  : ∀ {v R} → Map γ s unit v R v R
+    m-base  : ∀ {b v R} → Map γ s (base b) v R v R
+    m-arrow : ∀ {σ₁ σ₂ v R} → Map γ s (σ₁ [→] σ₂) v R v R
+    m-inl   : ∀ {σ₁ σ₂ v v' R R'} →
+              Map γ s σ₁ v R v' R' → Map γ s (σ₁ [+] σ₂) (inl v) R (inl v') R'
+    m-inr   : ∀ {σ₁ σ₂ v v' R R'} →
+              Map γ s σ₂ v R v' R' → Map γ s (σ₁ [+] σ₂) (inr v) R (inr v') R'
+    m-pair  : ∀ {σ₁ σ₂ v v' u u' R S T} →
+              Map γ s σ₁ v (p₁ ∘ R) v' S → Map γ s σ₂ u (p₂ ∘ R) u' T →
+              Map γ s (σ₁ [×] σ₂) (pair v u) R (pair v' u') ⟨ S , T ⟩
+    m-mu    : ∀ {τ' : type 2} {w w' R R'} →
+              Map γ s (unfold₁ τ') w R w' R' →
+              Map γ s (μ τ')
+                  (roll (subst Val (unfold₁-inst τ' (μ τ₀)) w))
+                  (subst (width-env γ ⇒_) (sym (width-subst (unfold₁-inst τ' (μ τ₀)) w)) R)
+                  (roll (subst Val (unfold₁-inst τ' σr) w'))
+                  (subst (width-env γ ⇒_) (sym (width-subst (unfold₁-inst τ' σr) w')) R')
+
+infix 25 _,_⇓_[_] _,_⇓s_[_]
diff --git a/agda/src/language-operational/graph.agda b/agda/src/language-operational/graph.agda
new file mode 100644
index 00000000..a7f3b522
--- /dev/null
+++ b/agda/src/language-operational/graph.agda
@@ -0,0 +1,238 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Data.Fin using (zero)
+open import Data.Nat using (ℕ)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)
+open import every using (Every; []; _∷_)
+open import prop-setoid using () renaming (_⇒_ to _⇒ₛ_)
+open import signature using (Signature)
+open import primitives using (Primitives)
+import matrix
+import two
+
+-- Dependence graphs over a derivation: a graph is its entry function, giving for each pair of
+-- vertices a matrix between their widths, the zero matrix meaning no edge. The graph judgement is a
+-- function from derivations to graphs, one clause group per rule; unions are pointwise sums
+-- realised by a single final zero clause, prefixing is reindexing by path constructors, and
+-- rewiring redistributes a premise's env column through the biproduct injections.
+module language-operational.graph {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open _⇒ₛ_ using (func)
+open import language-syntax Sig renaming (_,_ to _▸_)
+open import type-substitution Sig using (unfold₁; unfold₁-inst)
+open import language-operational.evaluation Sig 𝒫
+open import language-operational.path Sig 𝒫
+
+private
+  module M = matrix.Mat two.semiring
+
+open import categories using (Category)
+open Category M.cat using (_⇒_)
+
+data Vertex {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v : Val τ} {R : _} (D : γ , t ⇓ v [ R ]) : Set ℓ where
+  env : Vertex D
+  at  : Path D → Vertex D
+
+data VertexS {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs} {R : _}
+             (D : γ , Ms ⇓s vs [ R ]) : Set ℓ where
+  env : VertexS D
+  at  : PathS D → VertexS D
+
+-- A fold-action derivation has a second source alongside env: the input value being folded over.
+-- The fold rule wires it to the root of its first premise, the way a case branch wires its
+-- environment extension to the scrutinee root.
+data VertexM {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+             {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+             {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+             (D : Map γ s σ' v R v' R') : Set ℓ where
+  env   : VertexM D
+  input : VertexM D
+  at    : PathM D → VertexM D
+
+vertex-width : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Vertex D → ℕ
+vertex-width {γ = γ} env = width-env γ
+vertex-width (at p)      = width-at p
+
+vertex-width-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+      {D : γ , Ms ⇓s vs [ R ]} → VertexS D → ℕ
+vertex-width-s {γ = γ} env = width-env γ
+vertex-width-s (at p)      = width-at-s p
+
+vertex-width-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+      {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+      {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+      {D : Map γ s σ' v R v' R'} → VertexM D → ℕ
+vertex-width-m {γ = γ} env     = width-env γ
+vertex-width-m {v = v} input   = width v
+vertex-width-m (at p)          = width-at-m p
+
+Graph : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} → γ , t ⇓ v [ R ] → Set ℓ
+Graph D = (x y : Vertex D) → M.Matrix (vertex-width y) (vertex-width x)
+
+GraphS : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R} →
+         γ , Ms ⇓s vs [ R ] → Set ℓ
+GraphS D = (x y : VertexS D) → M.Matrix (vertex-width-s y) (vertex-width-s x)
+
+GraphM : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+         {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+      {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'} →
+         Map γ s σ' v R v' R' → Set ℓ
+GraphM D = (x y : VertexM D) → M.Matrix (vertex-width-m y) (vertex-width-m x)
+
+-- Cast a matrix along equalities of its row and column dimensions.
+rcast : ∀ {m m' n} → m ≡ m' → M.Matrix m n → M.Matrix m' n
+rcast refl R = R
+
+ccast : ∀ {m n n'} → n ≡ n' → M.Matrix m n → M.Matrix m n'
+ccast refl R = R
+
+-- The single-edge graph out of a premise's root, read as its column of entries at each source
+-- path: the given relation at the root, zero elsewhere. Defined generically because case-splitting
+-- a premise's path type gets stuck when the premise's indices are function-headed (e.g. a scrutinee
+-- required to evaluate to inl v).
+edge : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} {m} →
+       M.Matrix m (width v) → (p : Path D) → M.Matrix m (width-at p)
+edge R ε = R
+edge R _ = M.εₘ
+
+edge-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+            {D : γ , Ms ⇓s vs [ R ]} {m} →
+            M.Matrix m (bases-width is) → (p : PathS D) → M.Matrix m (width-at-s p)
+edge-s R ε = R
+edge-s R _ = M.εₘ
+
+edge-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+            {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+            {D : Map γ s σ' v R v' R'} {m} →
+            M.Matrix m (width v') → (p : PathM D) → M.Matrix m (width-at-m p)
+edge-m R ε = R
+edge-m R _ = M.εₘ
+
+mutual
+  graph : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → Graph D
+  graph (⇓-var {γ = γ} x) env (at ε) = proj-var x γ
+
+  graph (⇓-inl D) env       (at (inl q)) = graph D env (at q)
+  graph (⇓-inl D) (at (inl p)) (at (inl q)) = graph D (at p) (at q)
+  graph (⇓-inl D) (at (inl p)) (at ε) = edge M.I p
+
+  graph (⇓-inr D) env       (at (inr q)) = graph D env (at q)
+  graph (⇓-inr D) (at (inr p)) (at (inr q)) = graph D (at p) (at q)
+  graph (⇓-inr D) (at (inr p)) (at ε) = edge M.I p
+
+  graph (⇓-case-l D₁ D₂) env (at (case-l₁ q)) = graph D₁ env (at q)
+  graph (⇓-case-l D₁ D₂) (at (case-l₁ p)) (at (case-l₁ q)) = graph D₁ (at p) (at q)
+  graph (⇓-case-l D₁ D₂) env (at (case-l₂ q)) = graph D₂ env (at q) M.∘ M.in₁
+  graph (⇓-case-l D₁ D₂) (at (case-l₁ p)) (at (case-l₂ q)) = edge (graph D₂ env (at q) M.∘ M.in₂) p
+  graph (⇓-case-l D₁ D₂) (at (case-l₂ p)) (at (case-l₂ q)) = graph D₂ (at p) (at q)
+  graph (⇓-case-l D₁ D₂) (at (case-l₂ p)) (at ε) = edge M.I p
+
+  graph (⇓-case-r D₁ D₂) env (at (case-r₁ q)) = graph D₁ env (at q)
+  graph (⇓-case-r D₁ D₂) (at (case-r₁ p)) (at (case-r₁ q)) = graph D₁ (at p) (at q)
+  graph (⇓-case-r D₁ D₂) env (at (case-r₂ q)) = graph D₂ env (at q) M.∘ M.in₁
+  graph (⇓-case-r D₁ D₂) (at (case-r₁ p)) (at (case-r₂ q)) = edge (graph D₂ env (at q) M.∘ M.in₂) p
+  graph (⇓-case-r D₁ D₂) (at (case-r₂ p)) (at (case-r₂ q)) = graph D₂ (at p) (at q)
+  graph (⇓-case-r D₁ D₂) (at (case-r₂ p)) (at ε) = edge M.I p
+
+  graph (⇓-pair D₁ D₂) env (at (pair₁ q)) = graph D₁ env (at q)
+  graph (⇓-pair D₁ D₂) (at (pair₁ p)) (at (pair₁ q)) = graph D₁ (at p) (at q)
+  graph (⇓-pair D₁ D₂) env (at (pair₂ q)) = graph D₂ env (at q)
+  graph (⇓-pair D₁ D₂) (at (pair₂ p)) (at (pair₂ q)) = graph D₂ (at p) (at q)
+  graph (⇓-pair D₁ D₂) (at (pair₁ p)) (at ε) = edge M.in₁ p
+  graph (⇓-pair D₁ D₂) (at (pair₂ p)) (at ε) = edge M.in₂ p
+
+  graph (⇓-fst D) env (at (fst q)) = graph D env (at q)
+  graph (⇓-fst D) (at (fst p)) (at (fst q)) = graph D (at p) (at q)
+  graph (⇓-fst D) (at (fst p)) (at ε) = edge M.p₁ p
+
+  graph (⇓-snd D) env (at (snd q)) = graph D env (at q)
+  graph (⇓-snd D) (at (snd p)) (at (snd q)) = graph D (at p) (at q)
+  graph (⇓-snd D) (at (snd p)) (at ε) = edge M.p₂ p
+
+  graph ⇓-lam env (at ε) = M.I
+
+  graph (⇓-app D₁ D₂ D₃) env (at (app₁ q)) = graph D₁ env (at q)
+  graph (⇓-app D₁ D₂ D₃) (at (app₁ p)) (at (app₁ q)) = graph D₁ (at p) (at q)
+  graph (⇓-app D₁ D₂ D₃) env (at (app₂ q)) = graph D₂ env (at q)
+  graph (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₂ q)) = graph D₂ (at p) (at q)
+  graph (⇓-app D₁ D₂ D₃) (at (app₁ p)) (at (app₃ q)) = edge (graph D₃ env (at q) M.∘ M.in₁) p
+  graph (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₃ q)) = edge (graph D₃ env (at q) M.∘ M.in₂) p
+  graph (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at (app₃ q)) = graph D₃ (at p) (at q)
+  graph (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at ε) = edge M.I p
+
+  graph (⇓-bop {ω = ω} {vs = vs} D) env (at (bop q)) = graphS D env (at q)
+  graph (⇓-bop D) (at (bop p)) (at (bop q)) = graphS D (at p) (at q)
+  graph (⇓-bop {ω = ω} {vs = vs} D) (at (bop p)) (at ε) = edge-s (op-deps ω .func vs) p
+
+  graph (⇓-brel D) env (at (brel q)) = graphS D env (at q)
+  graph (⇓-brel D) (at (brel p)) (at (brel q)) = graphS D (at p) (at q)
+
+  graph (⇓-roll D) env (at (roll q)) = graph D env (at q)
+  graph (⇓-roll D) (at (roll p)) (at (roll q)) = graph D (at p) (at q)
+  graph (⇓-roll D) (at (roll p)) (at ε) = edge M.I p
+
+  graph (⇓-fold D₁ D₂) env (at (fold₁ q)) = graph D₁ env (at q)
+  graph (⇓-fold D₁ D₂) (at (fold₁ p)) (at (fold₁ q)) = graph D₁ (at p) (at q)
+  graph (⇓-fold D₁ D₂) env (at (fold₂ q)) = graphM D₂ env (at q)
+  graph (⇓-fold D₁ D₂) (at (fold₁ p)) (at (fold₂ q)) = edge (graphM D₂ input (at q)) p
+  graph (⇓-fold D₁ D₂) (at (fold₂ p)) (at (fold₂ q)) = graphM D₂ (at p) (at q)
+  graph (⇓-fold D₁ D₂) (at (fold₂ p)) (at ε) = edge-m M.I p
+
+  graph D _ _ = M.εₘ
+
+  graphS : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+           (D : γ , Ms ⇓s vs [ R ]) → GraphS D
+  graphS (D₁ ∷ D₂) env (at (hd q)) = graph D₁ env (at q)
+  graphS (D₁ ∷ D₂) (at (hd p)) (at (hd q)) = graph D₁ (at p) (at q)
+  graphS (D₁ ∷ D₂) env (at (tl q)) = graphS D₂ env (at q)
+  graphS (D₁ ∷ D₂) (at (tl p)) (at (tl q)) = graphS D₂ (at p) (at q)
+  graphS (D₁ ∷ D₂) (at (hd p)) (at ε) = edge M.in₁ p
+  graphS (D₁ ∷ D₂) (at (tl p)) (at ε) = edge-s M.in₂ p
+  graphS D _ _ = M.εₘ
+
+  graphM : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+           {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+      {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+           (D : Map γ s σ' v R v' R') → GraphM D
+  graphM (m-rec D₁ D₂) env (at (m-rec₁ q)) = graphM D₁ env (at q)
+  graphM (m-rec D₁ D₂) input (at (m-rec₁ q)) = graphM D₁ input (at q)
+  graphM (m-rec D₁ D₂) (at (m-rec₁ p)) (at (m-rec₁ q)) = graphM D₁ (at p) (at q)
+  graphM (m-rec D₁ D₂) env (at (m-rec₂ q)) = graph D₂ env (at q) M.∘ M.in₁
+  graphM (m-rec D₁ D₂) (at (m-rec₁ p)) (at (m-rec₂ q)) = edge-m (graph D₂ env (at q) M.∘ M.in₂) p
+  graphM (m-rec D₁ D₂) (at (m-rec₂ p)) (at (m-rec₂ q)) = graph D₂ (at p) (at q)
+  graphM (m-rec D₁ D₂) (at (m-rec₂ p)) (at ε) = edge M.I p
+
+  graphM m-unit  input (at ε) = M.I
+  graphM m-base  input (at ε) = M.I
+  graphM m-arrow input (at ε) = M.I
+
+  graphM (m-inl D) env (at (m-inl q)) = graphM D env (at q)
+  graphM (m-inl D) input (at (m-inl q)) = graphM D input (at q)
+  graphM (m-inl D) (at (m-inl p)) (at (m-inl q)) = graphM D (at p) (at q)
+  graphM (m-inl D) (at (m-inl p)) (at ε) = edge-m M.I p
+
+  graphM (m-inr D) env (at (m-inr q)) = graphM D env (at q)
+  graphM (m-inr D) input (at (m-inr q)) = graphM D input (at q)
+  graphM (m-inr D) (at (m-inr p)) (at (m-inr q)) = graphM D (at p) (at q)
+  graphM (m-inr D) (at (m-inr p)) (at ε) = edge-m M.I p
+
+  graphM (m-pair D₁ D₂) env (at (m-pair₁ q)) = graphM D₁ env (at q)
+  graphM (m-pair D₁ D₂) input (at (m-pair₁ q)) = graphM D₁ input (at q) M.∘ M.p₁
+  graphM (m-pair D₁ D₂) (at (m-pair₁ p)) (at (m-pair₁ q)) = graphM D₁ (at p) (at q)
+  graphM (m-pair D₁ D₂) env (at (m-pair₂ q)) = graphM D₂ env (at q)
+  graphM (m-pair D₁ D₂) input (at (m-pair₂ q)) = graphM D₂ input (at q) M.∘ M.p₂
+  graphM (m-pair D₁ D₂) (at (m-pair₂ p)) (at (m-pair₂ q)) = graphM D₂ (at p) (at q)
+  graphM (m-pair D₁ D₂) (at (m-pair₁ p)) (at ε) = edge-m M.in₁ p
+  graphM (m-pair D₁ D₂) (at (m-pair₂ p)) (at ε) = edge-m M.in₂ p
+
+  graphM (m-mu {τ' = τ'} {w = w} D) env (at (m-mu q)) = graphM D env (at q)
+  graphM (m-mu {τ' = τ'} {w = w} D) input (at (m-mu q)) =
+    ccast (sym (width-subst (unfold₁-inst τ' _) w)) (graphM D input (at q))
+  graphM (m-mu D) (at (m-mu p)) (at (m-mu q)) = graphM D (at p) (at q)
+  graphM (m-mu {τ' = τ'} {w' = w'} D) (at (m-mu p)) (at ε) =
+    edge-m (rcast (sym (width-subst (unfold₁-inst τ' _) w')) M.I) p
+
+  graphM D _ _ = M.εₘ
diff --git a/agda/src/language-operational/hide.agda b/agda/src/language-operational/hide.agda
new file mode 100644
index 00000000..ab81adb6
--- /dev/null
+++ b/agda/src/language-operational/hide.agda
@@ -0,0 +1,203 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Data.Bool as Bool using (Bool; not; _∧_; _∨_; if_then_else_)
+open import Data.Bool.ListAction using (any)
+open import Data.List using (List; []; _∷_; allFin; map; filterᵇ; foldl; foldr; concat; partitionᵇ)
+open import Data.Product using (_×_; _,_; proj₁; proj₂)
+open import Relation.Binary.PropositionalEquality using (_≡_) renaming (refl to ≡-refl)
+open import every using (Every; []; _∷_)
+open import list using (any-tabulate-false)
+open import signature using (Signature)
+open import primitives using (Primitives)
+import matrix
+import two
+
+-- Hiding an intermediate: each remaining entry absorbs the dependence routed through the hidden
+-- vertex. Hidden vertices stay in the carrier, so hiding transforms the entry function and the
+-- caller tracks which vertices are live; entries at a hidden vertex are stale, never read.
+module language-operational.hide {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open import language-syntax Sig renaming (_,_ to _▸_) hiding (foldr; if_then_else_)
+open import type-substitution Sig using (unfold₁)
+open import language-operational.evaluation Sig 𝒫
+open import language-operational.path Sig 𝒫
+open import language-operational.graph Sig 𝒫
+
+private
+  module M = matrix.Mat two.semiring
+
+open import categories using (Category)
+open Category M.cat using (_⇒_)
+
+hide : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Graph D → Vertex D → Graph D
+hide G r x y = G x y M.+ₘ (G r y M.∘ G x r)
+
+-- Hide a list of vertices, first to last; on acyclic graphs the order is immaterial.
+hide-all : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Graph D → List (Vertex D) → Graph D
+hide-all = foldl hide
+
+-- The first-order dependence graph: the graph of the derivation with every intermediate whose
+-- value is not first-order hidden, so that its live vertices are env, the root, and FO D.
+fo-graph : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → Graph D
+fo-graph D =
+  hide-all (graph D) (map at (filterᵇ (λ p → not (is-ε p) ∧ not (fo-at p)) (paths D)))
+
+private
+  is-I : two.Two → Bool
+  is-I two.I = Bool.true
+  is-I two.O = Bool.false
+
+nonzero : ∀ {m n} → M.Matrix m n → Bool
+nonzero {m} {n} R = any (λ i → any (λ j → is-I (R i j)) (allFin n)) (allFin m)
+
+nonzero-O : ∀ {m n} (R : M.Matrix m n) → nonzero R ≡ Bool.false →
+            ∀ i j → R i j ≡ two.O
+nonzero-O {m} {n} R h i j
+  with R i j
+     | any-tabulate-false (λ j' → j') (λ j' → is-I (R i j'))
+         (any-tabulate-false (λ i' → i') (λ i' → any (λ j' → is-I (R i' j')) (allFin n)) h i) j
+... | two.O | _  = ≡-refl
+... | two.I | ()
+
+-- Vertices sharing an incident edge, in either direction.
+adjacent : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+           Graph D → Vertex D → Vertex D → Bool
+adjacent G x y = nonzero (G x y) ∨ nonzero (G y x)
+
+-- The regions of a list of paths: the weakly connected components of the subgraph induced by its
+-- members. Each vertex merges the components it is adjacent to, the hide move's merging specialised
+-- to singletons.
+regions : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+          Graph D → List (Path D) → List (List (Path D))
+regions G []       = []
+regions G (w ∷ ws) = (w ∷ concat (proj₁ tp)) ∷ proj₂ tp
+  where tp = partitionᵇ (any (λ q → adjacent G (at w) (at q))) (regions G ws)
+
+member-vertex : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+                Vertex D → List (Path D) → Bool
+member-vertex env    C = Bool.false
+member-vertex (at p) C = member p C
+
+when : ∀ {m n} → Bool → M.Matrix m n → M.Matrix m n
+when Bool.true  R = R
+when Bool.false R = M.εₘ
+
+-- The entries with an endpoint in the given region, zero elsewhere.
+restrict : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+           Graph D → List (Path D) → Graph D
+restrict G C x y = when (member-vertex x C ∨ member-vertex y C) (G x y)
+
+-- The summary of a hidden region: the dependence routed through it, as entries between the
+-- vertices adjacent to it. Restriction first, so direct edges between boundary vertices are not
+-- carried by the summary.
+summary : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+          List (Path D) → Graph D
+summary D C = hide-all (restrict (fo-graph D) C) (map at C)
+
+-- A configuration: the visible set, and one pair per hidden region of a set of vertices and a
+-- graph. No invariant is imposed; that the pairs are the regions of the hidden set with their
+-- summaries is a property the moves preserve.
+record Config {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) : Set ℓ where
+  field
+    visible : List (Path D)
+    hidden  : List (List (Path D) × Graph D)
+
+open Config public
+
+-- The initial configuration: everything hidden, one summary per region of FO D.
+initial : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → Config D
+initial D .visible = []
+initial D .hidden  = map (λ C → C , summary D C) (regions (fo-graph D) (FO D))
+
+-- The union of a configuration's hidden regions.
+hidden-set : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Config D → List (Path D)
+hidden-set K = concat (map proj₁ (K .hidden))
+
+-- The visible graph: the entries of the first-order graph with neither endpoint hidden, together
+-- with the entries of the region summaries, parallel contributions summed.
+visible-graph : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+                Config D → Graph D
+visible-graph D K x y =
+  foldr M._+ₘ_
+        (when (not (member-vertex x hs) ∧ not (member-vertex y hs)) (fo-graph D x y))
+        (map (λ CH → proj₂ CH x y) (K .hidden))
+  where hs = hidden-set K
+
+_+G_ : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+       Graph D → Graph D → Graph D
+(G +G H) x y = G x y M.+ₘ H x y
+
+-- The hide move: remove p from the visible set, merge the regions adjacent to p, and hide p in the
+-- graph assembling p's incident entries in the visible graph with the merged regions' summaries.
+hide-at : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+          Path D → Config D → Config D
+hide-at D p K .visible = filterᵇ (λ q → not (eq-path p q)) (K .visible)
+hide-at D p K .hidden  = (p ∷ concat (map proj₁ (proj₁ tp)) , hide assembled (at p)) ∷ proj₂ tp
+  where
+    tp = partitionᵇ (λ CH → any (λ q → adjacent (fo-graph D) (at p) (at q)) (proj₁ CH))
+                    (K .hidden)
+    assembled = foldr _+G_ (restrict (visible-graph D K) (p ∷ [])) (map proj₂ (proj₁ tp))
+
+-- Split a stored region at p: recompute regions and summaries with p removed if the region
+-- contains p, and leave it alone otherwise.
+split-region : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+               Path D → List (Path D) × Graph D → List (List (Path D) × Graph D)
+split-region D p (C , H) =
+  if member p C
+  then map (λ C' → C' , summary D C')
+           (regions (fo-graph D) (filterᵇ (λ q → not (eq-path p q)) C))
+  else (C , H) ∷ []
+
+-- The reveal move: return p to the visible set and split the region containing it, recomputing
+-- regions and summaries within that region alone.
+reveal-at : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+            Path D → Config D → Config D
+reveal-at D p K .visible = p ∷ K .visible
+reveal-at D p K .hidden  = concat (map (split-region D p) (K .hidden))
+
+-- Collapse: hide every path of the derivation and read the remaining dependence from env to the
+-- root. Hiding the root itself is a no-op, since the root has no outgoing edges, so the whole
+-- enumeration can be hidden.
+collapse : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+           M.Matrix (width v) (width-env γ)
+collapse D = hide-all (graph D) (map at (paths D)) env (at ε)
+
+hide-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+         {D : γ , Ms ⇓s vs [ R ]} → GraphS D → VertexS D → GraphS D
+hide-s G r x y = G x y M.+ₘ (G r y M.∘ G x r)
+
+hide-all-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+             {D : γ , Ms ⇓s vs [ R ]} → GraphS D → List (VertexS D) → GraphS D
+hide-all-s = foldl hide-s
+
+collapse-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+             (D : γ , Ms ⇓s vs [ R ]) → M.Matrix (bases-width is) (width-env γ)
+collapse-s D = hide-all-s (graphS D) (map at (paths-s D)) env (at ε)
+
+hide-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+         {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+         {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+         {D : Map γ s σ' v R v' R'} → GraphM D → VertexM D → GraphM D
+hide-m G r x y = G x y M.+ₘ (G r y M.∘ G x r)
+
+hide-all-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+             {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+             {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+             {D : Map γ s σ' v R v' R'} → GraphM D → List (VertexM D) → GraphM D
+hide-all-m = foldl hide-m
+
+-- The two collapses of a fold-action graph: the dependence of the result on the environment, and
+-- on the input value.
+collapse-m-env : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                 {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                 {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                 (D : Map γ s σ' v R v' R') → M.Matrix (width v') (width-env γ)
+collapse-m-env D = hide-all-m (graphM D) (map at (paths-m D)) env (at ε)
+
+collapse-m-in : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                (D : Map γ s σ' v R v' R') → M.Matrix (width v') (width v)
+collapse-m-in D = hide-all-m (graphM D) (map at (paths-m D)) input (at ε)
diff --git a/agda/src/language-operational/logical-relation.agda b/agda/src/language-operational/logical-relation.agda
new file mode 100644
index 00000000..62a3106a
--- /dev/null
+++ b/agda/src/language-operational/logical-relation.agda
@@ -0,0 +1,282 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (0ℓ)
+open import Data.Fin using (Fin)
+open import Data.Nat using (ℕ; zero; suc; _+_; _<_; s≤s)
+open import Data.List using (List; []; _∷_)
+open import Data.Nat.Properties using (≤-refl; m≤m+n; m≤n+m)
+open import Data.Nat.Induction using (<-wellFounded)
+open import Induction.WellFounded using (Acc; acc)
+open import Data.Product using (Σ; _×_; _,_)
+open import Data.Unit using () renaming (⊤ to ⊤ₛ)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym) renaming (subst to ≡-subst)
+open import prop using (Prf; ∃ₚ; _∧_)
+import matrix
+open import prop-setoid using (Setoid)
+open import commutative-semiring using (CommutativeSemiring)
+import two
+open import signature using (Signature; Model; PFPC[_,_,_,_])
+open import primitives using (Primitives; sort-vals-setoid; sorts-width)
+open import categories using (Category; HasProducts; HasTerminal; HasCoproducts; HasExponentials; strong-coproducts→coproducts)
+open import functor using (Functor)
+import matrix-embedding-semimod
+import ho-model-sd-semimod
+
+-- Logical relation between the operational semantics and the interpretation in Fam(SemiMod(𝟚)), in
+-- existential (computability) form. Defined by well-founded recursion on type size: at an inductive type the
+-- relation is an inductive family that consumes the value, taking the relation at smaller types as a
+-- parameter, with the size bound carried by the arrow-leaf constructor.
+module language-operational.logical-relation
+  (Sig : Signature 0ℓ)
+  (open ho-model-sd-semimod two.semiring)
+  (𝒫 : Primitives two.semiring Sig)
+  where
+
+open Signature Sig
+open Primitives 𝒫
+
+private
+  Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig
+  Impl = interp-primitives.model Sig 𝒫
+
+open import language-syntax Sig renaming (_,_ to _▸_)
+import language-operational.evaluation
+import cmon-enriched
+import indexed-family
+import polynomial-functor
+open import type-substitution Sig using (unfold₁; unfold₁-inst; size)
+
+open interp Sig Impl
+
+private
+  module FamCP = HasCoproducts (strong-coproducts→coproducts Fam⟨𝒟⟩-terminal Fam⟨𝒟⟩-strongCoproducts)
+  module FamP  = HasProducts Fam⟨𝒟⟩-products
+  module FamE  = HasExponentials Fam⟨𝒟⟩-exponentials
+
+private
+  module MES = matrix-embedding-semimod two.semiring
+  module SM = Category SemiMod.cat
+  module M = matrix.Mat two.semiring
+
+open MES using (X^; F)
+
+δ₀ : Fin 0 → Fam⟨𝒟⟩.Obj
+δ₀ = λ ()
+
+Index : type 0 → Set
+Index τ = Setoid.Carrier ((⟦ τ ⟧ty δ₀) .idx)
+
+Fibre : (τ : type 0) → Index τ → SM.obj
+Fibre τ a = Fam⟨𝒟⟩.fm ((⟦ τ ⟧ty δ₀) .fam) a
+
+idx-≈ : (τ : type 0) → Index τ → Index τ → Prop 0ℓ
+idx-≈ τ = Setoid._≈_ ((⟦ τ ⟧ty δ₀) .idx)
+
+fibre-subst : (τ : type 0) {a a' : Index τ} → idx-≈ τ a a' → SM._⇒_ (Fibre τ a) (Fibre τ a')
+fibre-subst τ e = Fam⟨𝒟⟩.subst ((⟦ τ ⟧ty δ₀) .fam) e
+
+-- The denotational roll: ⟦ τ [ μ τ ] ⟧ ⇒ ⟦ μ τ ⟧.
+roll-mor : (τ : type 1) → Category._⇒_ Fam⟨𝒟⟩.cat (⟦ τ [ μ τ ] ⟧ty δ₀) (⟦ μ τ ⟧ty δ₀)
+roll-mor τ =
+  Category._∘_ Fam⟨𝒟⟩.cat
+    (polynomial-functor.Interp.HasMu.inMap Fam⟨𝒟⟩-hasMu (as-poly τ δ₀) δ₀)
+    (sub-as-apply-fwd τ (μ τ))
+
+roll-ix : (τ : type 1) → Index (τ [ μ τ ]) → Index (μ τ)
+roll-ix τ a = roll-mor τ .idxf .prop-setoid._⇒_.func a
+
+roll-fib : (τ : type 1) (a : Index (τ [ μ τ ])) →
+           SM._⇒_ (Fibre (τ [ μ τ ]) a) (Fibre (μ τ) (roll-ix τ a))
+roll-fib τ a = roll-mor τ .famf .indexed-family._⇒f_.transf a
+
+private
+  _∘M_ = SM._∘_
+  _≈M_ = SM._≈_
+  infixr 30 _∘M_
+
+-- Coercions along propositional type equality.
+ix-coerce : ∀ {σ σ' : type 0} → σ ≡ σ' → Index σ → Index σ'
+ix-coerce e = ≡-subst Index e
+
+fib-coerce : ∀ {σ σ' : type 0} (e : σ ≡ σ') (a : Index σ) →
+             SM._⇒_ (Fibre σ a) (Fibre σ' (ix-coerce e a))
+fib-coerce refl a = SM.id _
+
+free-coerce : ∀ {m n : ℕ} → m ≡ n → SM._⇒_ (X^ m) (X^ n)
+free-coerce refl = SM.id _
+
+-- Structure maps at points and fibres.
+ix-in₁ : (σ τ : type 0) → Index σ → Index (σ [+] τ)
+ix-in₁ σ τ a = FamCP.in₁ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .idxf .prop-setoid._⇒_.func a
+
+ix-in₂ : (σ τ : type 0) → Index τ → Index (σ [+] τ)
+ix-in₂ σ τ a = FamCP.in₂ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .idxf .prop-setoid._⇒_.func a
+
+fib-in₁ : (σ τ : type 0) (a : Index σ) → SM._⇒_ (Fibre σ a) (Fibre (σ [+] τ) (ix-in₁ σ τ a))
+fib-in₁ σ τ a = FamCP.in₁ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .famf .indexed-family._⇒f_.transf a
+
+fib-in₂ : (σ τ : type 0) (a : Index τ) → SM._⇒_ (Fibre τ a) (Fibre (σ [+] τ) (ix-in₂ σ τ a))
+fib-in₂ σ τ a = FamCP.in₂ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .famf .indexed-family._⇒f_.transf a
+
+ix-p₁ : (σ τ : type 0) → Index (σ [×] τ) → Index σ
+ix-p₁ σ τ ab = FamP.p₁ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .idxf .prop-setoid._⇒_.func ab
+
+ix-p₂ : (σ τ : type 0) → Index (σ [×] τ) → Index τ
+ix-p₂ σ τ ab = FamP.p₂ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .idxf .prop-setoid._⇒_.func ab
+
+fib-p₁ : (σ τ : type 0) (ab : Index (σ [×] τ)) →
+         SM._⇒_ (Fibre (σ [×] τ) ab) (Fibre σ (ix-p₁ σ τ ab))
+fib-p₁ σ τ ab = FamP.p₁ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .famf .indexed-family._⇒f_.transf ab
+
+fib-p₂ : (σ τ : type 0) (ab : Index (σ [×] τ)) →
+         SM._⇒_ (Fibre (σ [×] τ) ab) (Fibre τ (ix-p₂ σ τ ab))
+fib-p₂ σ τ ab = FamP.p₂ {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .famf .indexed-family._⇒f_.transf ab
+
+-- Application at points and the evaluation fibre map.
+app-ix : (σ τ : type 0) → Index (σ [→] τ) → Index σ → Index τ
+app-ix σ τ f a = FamE.eval .idxf .prop-setoid._⇒_.func (f , a)
+
+∂ε : (σ τ : type 0) (f : Index (σ [→] τ)) (a : Index σ) →
+     SM._⇒_ (Fam⟨𝒟⟩.fm ((FamP.prod (⟦ σ [→] τ ⟧ty δ₀) (⟦ σ ⟧ty δ₀)) .fam) (f , a))
+            (Fibre τ (app-ix σ τ f a))
+∂ε σ τ f a = FamE.eval {⟦ σ ⟧ty δ₀} {⟦ τ ⟧ty δ₀} .famf .indexed-family._⇒f_.transf (f , a)
+
+i⊕₁ : ∀ {X Y} → SM._⇒_ X (SemiMod._⊕_ X Y)
+i⊕₁ {X} {Y} = cmon-enriched.Biproduct.in₁ (SemiMod.biproduct X Y)
+
+i⊕₂ : ∀ {X Y} → SM._⇒_ Y (SemiMod._⊕_ X Y)
+i⊕₂ {X} {Y} = cmon-enriched.Biproduct.in₂ (SemiMod.biproduct X Y)
+
+private
+  module EM = language-operational.evaluation Sig 𝒫
+open EM
+
+Realiser : (τ : type 0) → Val τ → Index τ → Set
+Realiser τ v a = SM._⇒_ (X^ (width v)) (Fibre τ a)
+
+RelSpec : type 0 → Set₁
+RelSpec τ = (v : Val τ) (a : Index τ) → Realiser τ v a → Set
+
+in-free₁ : (m n : ℕ) → SM._⇒_ (X^ m) (X^ (m + n))
+in-free₁ m n = Functor.fmor MES.mat→mor (M.in₁ {m} {n})
+
+in-free₂ : (m n : ℕ) → SM._⇒_ (X^ n) (X^ (m + n))
+in-free₂ m n = Functor.fmor MES.mat→mor (M.in₂ {m} {n})
+
+data MuRel (τ₀ : type 1)
+           (Rel< : (σ : type 0) → size σ < size (μ τ₀) → RelSpec σ) :
+           (σ' : type 1) (v : Val (σ' [ μ τ₀ ])) (a : Index (σ' [ μ τ₀ ])) →
+           Realiser (σ' [ μ τ₀ ]) v a → Set where
+  mrel-roll  : ∀ {w a' r' a r} →
+               MuRel τ₀ Rel< τ₀ w a' r' →
+               Prf (∃ₚ (idx-≈ (μ τ₀) (roll-ix τ₀ a') a) λ e →
+                    r ≈M (fibre-subst (μ τ₀) {roll-ix τ₀ a'} {a} e ∘M roll-fib τ₀ a' ∘M r')) →
+               MuRel τ₀ Rel< (var Fin.zero) (roll w) a r
+  mrel-unit  : ∀ {a r} → MuRel τ₀ Rel< unit unit a r
+  mrel-base  : ∀ {s c a r} →
+               Prf (∃ₚ (idx-≈ (base s) c a) λ e →
+                    r ≈M (fibre-subst (base s) {c} {a} e ∘M MES.X^≅S^ (sort-width s) .Category.Iso.fwd)) →
+               MuRel τ₀ Rel< (base s) (const c) a r
+  mrel-arrow : ∀ {σ₁ σ₂ : type 0} {v a r} →
+               (p : size {1} (σ₁ [→] σ₂) < size (μ τ₀)) →
+               Rel< (σ₁ [→] σ₂) p v a r →
+               MuRel τ₀ Rel< (σ₁ [→] σ₂) v a r
+  mrel-inl   : ∀ {σ₁ σ₂ : type 1} {v a' r' a r} →
+               MuRel τ₀ Rel< σ₁ v a' r' →
+               Prf (∃ₚ (idx-≈ ((σ₁ [+] σ₂) [ μ τ₀ ]) (ix-in₁ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a') a) λ e →
+                    r ≈M (fibre-subst ((σ₁ [+] σ₂) [ μ τ₀ ]) {ix-in₁ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a'} {a} e ∘M fib-in₁ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a' ∘M r')) →
+               MuRel τ₀ Rel< (σ₁ [+] σ₂) (inl v) a r
+  mrel-inr   : ∀ {σ₁ σ₂ : type 1} {v a' r' a r} →
+               MuRel τ₀ Rel< σ₂ v a' r' →
+               Prf (∃ₚ (idx-≈ ((σ₁ [+] σ₂) [ μ τ₀ ]) (ix-in₂ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a') a) λ e →
+                    r ≈M (fibre-subst ((σ₁ [+] σ₂) [ μ τ₀ ]) {ix-in₂ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a'} {a} e ∘M fib-in₂ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a' ∘M r')) →
+               MuRel τ₀ Rel< (σ₁ [+] σ₂) (inr v) a r
+  mrel-pair  : ∀ {σ₁ σ₂ : type 1} {v₁ v₂ a r} →
+               MuRel τ₀ Rel< σ₁ v₁ (ix-p₁ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a)
+                     (fib-p₁ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a ∘M r ∘M in-free₁ (width v₁) (width v₂)) →
+               MuRel τ₀ Rel< σ₂ v₂ (ix-p₂ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a)
+                     (fib-p₂ (σ₁ [ μ τ₀ ]) (σ₂ [ μ τ₀ ]) a ∘M r ∘M in-free₂ (width v₁) (width v₂)) →
+               MuRel τ₀ Rel< (σ₁ [×] σ₂) (pair v₁ v₂) a r
+  mrel-mu    : ∀ {τ' : type 2} {w} (a' : Index (unfold₁ τ' [ μ τ₀ ])) (r' : Realiser (unfold₁ τ' [ μ τ₀ ]) w a') → ∀ {a r} →
+               MuRel τ₀ Rel< (unfold₁ τ') w a' r' →
+               Prf (∃ₚ (idx-≈ ((μ τ') [ μ τ₀ ])
+                          (roll-ix (sub (sub-lift (push (μ τ₀))) τ')
+                                   (ix-coerce (unfold₁-inst τ' (μ τ₀)) a')) a) λ e →
+                    (r ∘M free-coerce (sym (width-subst (unfold₁-inst τ' (μ τ₀)) w))) ≈M
+                    (fibre-subst ((μ τ') [ μ τ₀ ])
+                       {roll-ix (sub (sub-lift (push (μ τ₀))) τ')
+                                (ix-coerce (unfold₁-inst τ' (μ τ₀)) a')} {a} e
+                       ∘M roll-fib (sub (sub-lift (push (μ τ₀))) τ')
+                                   (ix-coerce (unfold₁-inst τ' (μ τ₀)) a')
+                       ∘M fib-coerce (unfold₁-inst τ' (μ τ₀)) a' ∘M r')) →
+               MuRel τ₀ Rel< (μ τ') (roll (≡-subst Val (unfold₁-inst τ' (μ τ₀)) w)) a r
+
+Rel-acc : (τ : type 0) → Acc _<_ (size τ) → RelSpec τ
+Rel-acc (var ())
+Rel-acc unit _ v a r = ⊤ₛ
+Rel-acc (base s) _ (const c) a r =
+  Prf (∃ₚ (idx-≈ (base s) c a) λ e →
+       r ≈M (fibre-subst (base s) {c} {a} e ∘M MES.X^≅S^ (sort-width s) .Category.Iso.fwd))
+Rel-acc (σ [+] τ) (acc rs) (inl v) a r =
+  Σ (Index σ) λ a' → Σ (Realiser σ v a') λ r' →
+    Rel-acc σ (rs (s≤s (m≤m+n (size σ) (size τ)))) v a' r' ×
+    Prf (∃ₚ (idx-≈ (σ [+] τ) (ix-in₁ σ τ a') a) λ e →
+         r ≈M (fibre-subst (σ [+] τ) {ix-in₁ σ τ a'} {a} e ∘M fib-in₁ σ τ a' ∘M r'))
+Rel-acc (σ [+] τ) (acc rs) (inr v) a r =
+  Σ (Index τ) λ a' → Σ (Realiser τ v a') λ r' →
+    Rel-acc τ (rs (s≤s (m≤n+m (size τ) (size σ)))) v a' r' ×
+    Prf (∃ₚ (idx-≈ (σ [+] τ) (ix-in₂ σ τ a') a) λ e →
+         r ≈M (fibre-subst (σ [+] τ) {ix-in₂ σ τ a'} {a} e ∘M fib-in₂ σ τ a' ∘M r'))
+Rel-acc (σ [×] τ) (acc rs) (pair v u) a r =
+  Rel-acc σ (rs (s≤s (m≤m+n (size σ) (size τ)))) v (ix-p₁ σ τ a)
+          (fib-p₁ σ τ a ∘M r ∘M in-free₁ (width v) (width u)) ×
+  Rel-acc τ (rs (s≤s (m≤n+m (size τ) (size σ)))) u (ix-p₂ σ τ a)
+          (fib-p₂ σ τ a ∘M r ∘M in-free₂ (width v) (width u))
+Rel-acc (σ [→] τ) (acc rs) (clo {Γ'} γ' t) f r =
+  ∀ (v : Val σ) (a : Index σ) (rv : Realiser σ v a) →
+  Rel-acc σ (rs (s≤s (m≤m+n (size σ) (size τ)))) v a rv →
+  Σ (Val τ) λ u →
+  Σ (Category._⇒_ M.cat (width-env γ' + width v) (width u)) λ R →
+  Σ (γ' · v , t ⇓ u [ R ]) λ _ →
+  Σ (Realiser τ u (app-ix σ τ f a)) λ q →
+    Rel-acc τ (rs (s≤s (m≤n+m (size τ) (size σ)))) u (app-ix σ τ f a) q ×
+    Prf (((q ∘M Functor.fmor MES.mat→mor R ∘M in-free₁ (width-env γ') (width v)) ≈M
+            (∂ε σ τ f a ∘M i⊕₁ ∘M r))
+       ∧ ((q ∘M Functor.fmor MES.mat→mor R ∘M in-free₂ (width-env γ') (width v)) ≈M
+            (∂ε σ τ f a ∘M i⊕₂ ∘M rv)))
+Rel-acc (μ τ₀) (acc rs) v a r =
+  MuRel τ₀ (λ σ p → Rel-acc σ (rs p)) (var Fin.zero) v a r
+
+Rel : (τ : type 0) → RelSpec τ
+Rel τ = Rel-acc τ (<-wellFounded (size τ))
+
+IndexC : ctxt → Set
+IndexC Γ = Setoid.Carrier ((⟦ Γ ⟧ctxt) .idx)
+
+FibreC : (Γ : ctxt) → IndexC Γ → SM.obj
+FibreC Γ g = Fam⟨𝒟⟩.fm ((⟦ Γ ⟧ctxt) .fam) g
+
+EnvRel : (Γ : ctxt) (γ : Env Γ) (g : IndexC Γ) →
+         SM._⇒_ (X^ (width-env γ)) (FibreC Γ g) → Set
+EnvRel emp emp g r = ⊤ₛ
+EnvRel (Γ ▸ τ) (γ · v) g r =
+  EnvRel Γ γ (FamP.p₁ {⟦ Γ ⟧ctxt} {⟦ τ ⟧ty δ₀} .idxf .prop-setoid._⇒_.func g)
+         (FamP.p₁ {⟦ Γ ⟧ctxt} {⟦ τ ⟧ty δ₀} .famf .indexed-family._⇒f_.transf g
+            ∘M r ∘M in-free₁ (width-env γ) (width v)) ×
+  Rel τ v (FamP.p₂ {⟦ Γ ⟧ctxt} {⟦ τ ⟧ty δ₀} .idxf .prop-setoid._⇒_.func g)
+      (FamP.p₂ {⟦ Γ ⟧ctxt} {⟦ τ ⟧ty δ₀} .famf .indexed-family._⇒f_.transf g
+         ∘M r ∘M in-free₂ (width-env γ) (width v))
+
+-- Statement only; the proof is future work and yields eval (totality), soundness at first-order types, and
+-- the existence half of determinism.
+FundamentalProperty : Set
+FundamentalProperty =
+  ∀ {Γ τ} (t : Γ ⊢ τ) (γ : Env Γ) (g : IndexC Γ)
+    (rγ : SM._⇒_ (X^ (width-env γ)) (FibreC Γ g)) →
+  EnvRel Γ γ g rγ →
+  Σ (Val τ) λ v →
+  Σ (Category._⇒_ M.cat (width-env γ) (width v)) λ R →
+  Σ (γ , t ⇓ v [ R ]) λ _ →
+  Σ (Realiser τ v (⟦ t ⟧tm .idxf .prop-setoid._⇒_.func g)) λ q →
+    Rel τ v (⟦ t ⟧tm .idxf .prop-setoid._⇒_.func g) q ×
+    Prf ((q ∘M Functor.fmor MES.mat→mor R) ≈M (mor t g ∘M rγ))
diff --git a/agda/src/language-operational/moves.agda b/agda/src/language-operational/moves.agda
new file mode 100644
index 00000000..1a8bb8c3
--- /dev/null
+++ b/agda/src/language-operational/moves.agda
@@ -0,0 +1,1040 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Data.Bool as Bool using (Bool; _∨_)
+open import Data.Bool.ListAction using (any)
+open import Data.Bool.Properties using (∨-comm; ∨-identityʳ)
+open import Data.Fin using (Fin)
+open import Data.List using (List; []; _∷_; _++_; map; concat; filterᵇ; foldr; partitionᵇ)
+open import Data.List.Relation.Unary.All using (All; []; _∷_; universal) renaming (map to All-map)
+open import Data.List.Relation.Unary.AllPairs using (AllPairs; []; _∷_)
+open import Data.List.Relation.Unary.Any using (Any; here; there) renaming (map to Any-map)
+import Data.List.Relation.Unary.Any.Properties as AnyPr
+import Data.List.Relation.Unary.All.Properties as AllP
+import Data.List.Relation.Unary.AllPairs.Properties as AllPairsP
+open import Data.List.Properties using (++-identityʳ; concat-++; concat-map; foldl-++; map-++; map-∘)
+import Data.List.Relation.Binary.Permutation.Propositional as ↭
+open ↭ using (_↭_; ↭-refl; ↭-sym; ↭-trans; ↭-reflexive)
+open import Data.List.Relation.Binary.Permutation.Propositional.Properties using (map⁺; shift; ++⁺; drop-∷; Any-resp-↭)
+open import Data.Product using (_×_; _,_; proj₁; proj₂)
+open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_]′)
+open import Relation.Binary.PropositionalEquality using (_≡_; subst)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; cong to ≡-cong; cong₂ to ≡-cong₂)
+open import list
+open import signature using (Signature)
+open import primitives using (Primitives)
+import hide-algebra
+import matrix
+import two
+
+-- The moves preserve the invariant that the stored regions partition the hidden set into
+-- pairwise-apart pieces, each carrying its summary. The initial configuration satisfies the
+-- invariant, and the hide and reveal moves preserve it.
+module language-operational.moves {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open import language-syntax Sig renaming (_,_ to _▸_) hiding (foldr)
+open import language-operational.evaluation Sig 𝒫
+open import language-operational.path Sig 𝒫
+open import language-operational.graph Sig 𝒫
+open import language-operational.hide Sig 𝒫
+open import language-operational.topological-order Sig 𝒫
+
+private
+  module M = matrix.Mat two.semiring
+
+  module HA {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) =
+    hide-algebra.Hide (Vertex D) vertex-width
+
+member-perm : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+              (q : Path D) {C C' : List (Path D)} → C ↭ C' → member q C ≡ member q C'
+member-perm q = any-perm (eq-path q)
+
+member-vertex-perm : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                     (x : Vertex D) {C C' : List (Path D)} → C ↭ C' →
+                     member-vertex x C ≡ member-vertex x C'
+member-vertex-perm env    p = ≡-refl
+member-vertex-perm (at q) p = member-perm q p
+
+-- Restriction reads the region only through membership, so respects permutation.
+restrict-perm : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                (G : Graph D) {C C' : List (Path D)} → C ↭ C' →
+                ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                restrict G C x y i j ≡ restrict G C' x y i j
+restrict-perm G p x y i j =
+  ≡-cong (λ b → when b (G x y) i j)
+         (≡-cong₂ _∨_ (member-vertex-perm x p) (member-vertex-perm y p))
+
+-- Restriction only zeroes entries, so preserves the forward-edge property.
+restrict-forward : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                   {G : Graph D} (C : List (Path D)) → Forward G → Forward (restrict G C)
+restrict-forward C fwd x y i j with member-vertex x C ∨ member-vertex y C
+... | Bool.true  = fwd x y i j
+... | Bool.false = λ ()
+
+-- Summaries are stable under permutation of the region: restriction is membership-based, and the
+-- hiding order is immaterial on the restricted graph, which is forward.
+summary-perm : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+               {C C' : List (Path D)} → C ↭ C' →
+               ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+               summary D C x y i j ≡ summary D C' x y i j
+summary-perm D {C} {C'} p x y i j =
+  ≡-trans (HA.fold-cong D (map at C) (restrict-perm (fo-graph D) p) x y i j)
+          (hide-all-perm (restrict-forward C' (fo-forward D)) (map⁺ at p) x y i j)
+
+adjacent-sym : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+               (G : Graph D) (x y : Vertex D) → adjacent G x y ≡ adjacent G y x
+adjacent-sym G x y = ∨-comm (nonzero (G x y)) (nonzero (G y x))
+
+-- Regions with no edge between them; each reads the graph only through its own members, so hiding
+-- either leaves the other's summary alone.
+Apart : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+        Graph D → List (Path D) → List (Path D) → Set
+Apart G C C' = any (λ q → any (λ q' → adjacent G (at q) (at q')) C') C ≡ Bool.false
+
+apart-sym : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+            (G : Graph D) {C C' : List (Path D)} → Apart G C C' → Apart G C' C
+apart-sym G {C} {C'} h =
+  ≡-trans (any-comm (λ q q' → adjacent G (at q) (at q')) C' C)
+  (≡-trans (any-cong (λ q → any-cong (λ q' → adjacent-sym G (at q') (at q)) C') C) h)
+
+-- Adding a vertex and merging the regions adjacent to it preserves pairwise apartness: an
+-- untouched region fails the adjacency test for the vertex and was already apart from each of the
+-- merged regions.
+merge-separated : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                  (G : Graph D) (w : Path D) {rs : List (List (Path D))} →
+                  AllPairs (Apart G) rs →
+                  let tp = partitionᵇ (any (λ q → adjacent G (at w) (at q))) rs in
+                  AllPairs (Apart G) ((w ∷ concat (proj₁ tp)) ∷ proj₂ tp)
+merge-separated G w {rs} sep = apart-w ∷ proj₁ (proj₂ pa)
+  where
+  f = any (λ q → adjacent G (at w) (at q))
+  pa = partition-AllPairs {S = Apart G} f (λ {C} {C'} → apart-sym G {C} {C'}) sep
+  tp = partitionᵇ f rs
+  apart-w : All (Apart G (w ∷ concat (proj₁ tp))) (proj₂ tp)
+  apart-w =
+    All-zip (λ {C'} hf hc →
+              ≡-cong₂ _∨_ hf
+                (≡-trans (any-concat (λ q → any (λ q' → adjacent G (at q) (at q')) C') (proj₁ tp))
+                         (any-false hc)))
+            (part₂-false f rs) (proj₂ (proj₂ pa))
+
+-- The regions computation produces pairwise-apart regions.
+regions-separated : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                    (G : Graph D) (ws : List (Path D)) → AllPairs (Apart G) (regions G ws)
+regions-separated G []       = []
+regions-separated G (w ∷ ws) = merge-separated G w (regions-separated G ws)
+
+-- A correctly summarised configuration: the visible and hidden vertices partition the first-order
+-- paths, the stored regions are pairwise apart, and each carries its summary.
+record Summarised {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                  (K : Config D) : Set ℓ where
+  field
+    partition : (K .visible ++ hidden-set K) ↭ FO D
+    separated : AllPairs (Apart (fo-graph D)) (map proj₁ (K .hidden))
+    summaries : All (λ CH → ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                            proj₂ CH x y i j ≡ summary D (proj₁ CH) x y i j)
+                    (K .hidden)
+
+open Summarised public
+
+-- The regions of a list are made from exactly its members.
+regions-concat : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                 (G : Graph D) (ws : List (Path D)) → concat (regions G ws) ↭ ws
+regions-concat G []       = ↭.refl
+regions-concat G (w ∷ ws) =
+  ↭.prep w (↭-trans (↭-reflexive (concat-++ (proj₁ tp) (proj₂ tp)))
+           (↭-trans (concat-resp (↭↭-of-↭ (partition-↭ _ (regions G ws))))
+                    (regions-concat G ws)))
+  where tp = partitionᵇ (any (λ q → adjacent G (at w) (at q))) (regions G ws)
+
+private
+  stored≡ : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+            map proj₁ (initial D .hidden) ≡ regions (fo-graph D) (FO D)
+  stored≡ D = map-proj₁-pair (summary D) (regions (fo-graph D) (FO D))
+
+-- The initial configuration is correctly summarised.
+initial-summarised : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+                     Summarised (initial D)
+initial-summarised D .partition =
+  subst (λ z → concat z ↭ FO D) (≡-sym (stored≡ D)) (regions-concat (fo-graph D) (FO D))
+initial-summarised D .separated =
+  subst (AllPairs (Apart (fo-graph D))) (≡-sym (stored≡ D))
+        (regions-separated (fo-graph D) (FO D))
+initial-summarised D .summaries =
+  AllP.map⁺ (universal (λ C x y i j → ≡-refl) (regions (fo-graph D) (FO D)))
+
+-- Hiding a vertex adds it to the hidden set.
+hide-at-hidden-set : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                     (p : Path D) (K : Config D) →
+                     hidden-set (hide-at D p K) ↭ (p ∷ hidden-set K)
+hide-at-hidden-set D p K =
+  ↭.prep p
+    (↭-trans (↭-reflexive (concat-++ (map proj₁ (proj₁ tp)) (map proj₁ (proj₂ tp))))
+    (↭-trans (↭-reflexive (≡-cong concat (≡-sym (map-++ proj₁ (proj₁ tp) (proj₂ tp)))))
+             (concat-resp (↭↭-of-↭ (map⁺ proj₁ (partition-↭ _ (K .hidden)))))))
+  where tp = partitionᵇ (λ CH → any (λ q → adjacent (fo-graph D) (at p) (at q)) (proj₁ CH))
+                        (K .hidden)
+
+-- The merged region and the untouched regions remain pairwise apart.
+hide-at-separated : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                    (p : Path D) (K : Config D) → Summarised K →
+                    AllPairs (Apart (fo-graph D)) (map proj₁ (hide-at D p K .hidden))
+hide-at-separated D p K S =
+  subst (AllPairs (Apart (fo-graph D)))
+        (≡-cong₂ (λ z₁ z₂ → (p ∷ concat z₁) ∷ z₂)
+                 (map-partition₁ proj₁ g (K .hidden))
+                 (map-partition₂ proj₁ g (K .hidden)))
+        (merge-separated (fo-graph D) p (S .separated))
+  where g = any (λ q → adjacent (fo-graph D) (at p) (at q))
+
+private
+  mv-mono : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+            {C E : List (Path D)} →
+            (∀ q → member q C ≡ Bool.true → member q E ≡ Bool.true) →
+            ∀ z → member-vertex z C ≡ Bool.true → member-vertex z E ≡ Bool.true
+  mv-mono mono env    ()
+  mv-mono mono (at q) h = mono q h
+
+  when-O : ∀ (b : Bool) {m n} (R : M.Matrix m n) (i : Fin m) (j : Fin n) →
+           (b ≡ Bool.true → R i j ≡ two.O) → when b R i j ≡ two.O
+  when-O Bool.false R i j h = ≡-refl
+  when-O Bool.true  R i j h = h ≡-refl
+
+  when-sub : ∀ (b₁ b₂ : Bool) {m n} (R : M.Matrix m n) (i : Fin m) (j : Fin n) →
+             (b₁ ≡ Bool.true → b₂ ≡ Bool.true) →
+             (when b₁ R i j two.⊔ when b₂ R i j) ≡ when b₂ R i j
+  when-sub Bool.false b₂ R i j imp = ≡-refl
+  when-sub Bool.true  b₂ R i j imp with b₂ | imp ≡-refl
+  ... | Bool.true | _ = two.⊔-idem
+
+restrict-sub : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+               (G : Graph D) {C E : List (Path D)} →
+               (∀ q → member q C ≡ Bool.true → member q E ≡ Bool.true) →
+               ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+               (restrict G C x y i j two.⊔ restrict G E x y i j) ≡ restrict G E x y i j
+restrict-sub G {C} {E} mono x y i j =
+  when-sub (member-vertex x C ∨ member-vertex y C) (member-vertex x E ∨ member-vertex y E)
+           (G x y) i j imp
+  where
+  imp : (member-vertex x C ∨ member-vertex y C) ≡ Bool.true →
+        (member-vertex x E ∨ member-vertex y E) ≡ Bool.true
+  imp h with ∨-true-inv (member-vertex x C) (member-vertex y C) h
+  ... | inj₁ hx = ≡-cong (_∨ member-vertex y E) (mv-mono mono x hx)
+  ... | inj₂ hy = ≡-trans (≡-cong (member-vertex x E ∨_) (mv-mono mono y hy))
+                          (∨-true (member-vertex x E))
+
+restrict-agree : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                 (G : Graph D) {C E : List (Path D)} →
+                 (∀ q → member q C ≡ Bool.true → member q E ≡ Bool.true) →
+                 All (λ r → ((z : Vertex D) (i : Fin (vertex-width z)) (j : Fin (vertex-width r)) →
+                             restrict G E r z i j ≡ restrict G C r z i j)
+                          × ((z : Vertex D) (i : Fin (vertex-width r)) (j : Fin (vertex-width z)) →
+                             restrict G E z r i j ≡ restrict G C z r i j))
+                     (map at C)
+restrict-agree G {C} {E} mono =
+  AllP.map⁺ (All-map (λ {q} hq →
+    (λ z i j →
+      ≡-trans (≡-cong (λ b → when (b ∨ member-vertex z E) (G (at q) z) i j) (mono q hq))
+              (≡-sym (≡-cong (λ b → when (b ∨ member-vertex z C) (G (at q) z) i j) hq))) ,
+    (λ z i j →
+      ≡-trans (≡-cong (λ b → when (member-vertex z E ∨ b) (G z (at q)) i j) (mono q hq))
+      (≡-trans (≡-cong (λ b → when b (G z (at q)) i j) (∨-true (member-vertex z E)))
+      (≡-sym (≡-trans (≡-cong (λ b → when (member-vertex z C ∨ b) (G z (at q)) i j) hq)
+                      (≡-cong (λ b → when b (G z (at q)) i j) (∨-true (member-vertex z C))))))))
+    (any-self eq-path-refl C))
+
+localise : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+           {C E : List (Path D)} →
+           (∀ q → member q C ≡ Bool.true → member q E ≡ Bool.true) →
+           ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+           hide-all (restrict (fo-graph D) E) (map at C) x y i j ≡
+           (restrict (fo-graph D) E x y i j two.⊔ summary D C x y i j)
+localise D {C} {E} mono x y i j =
+  HA.agree-add D (map at C) (restrict-sub (fo-graph D) mono) (restrict-agree (fo-graph D) mono)
+               x y i j
+
+-- A region neither containing nor adjacent to a vertex has a summary with no entries at it.
+summary-zero : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+               {C : List (Path D)} (q : Path D) →
+               member q C ≡ Bool.false →
+               any (λ q' → adjacent (fo-graph D) (at q) (at q')) C ≡ Bool.false →
+               (((z : Vertex D) (i : Fin (vertex-width z)) (j : Fin (vertex-width (at q))) →
+                 summary D C (at q) z i j ≡ two.O) ×
+                ((z : Vertex D) (i : Fin (vertex-width (at q))) (j : Fin (vertex-width z)) →
+                 summary D C z (at q) i j ≡ two.O))
+summary-zero D {C} q hm hadj =
+  HA.zero-fold D (map at C) (at q) (base-row , base-col)
+  where
+  adjs : All (λ q' → adjacent (fo-graph D) (at q) (at q') ≡ Bool.false) C
+  adjs = any-false-All _ C hadj
+
+  entry-row : ∀ z → member-vertex z C ≡ Bool.true →
+              ∀ i j → fo-graph D (at q) z i j ≡ two.O
+  entry-row env     ()
+  entry-row (at q') hz i j =
+    nonzero-O (fo-graph D (at q) (at q'))
+              (proj₁ (∨-false (nonzero (fo-graph D (at q) (at q')))
+                              (nonzero (fo-graph D (at q') (at q)))
+                              (member-All {eq = eq-path} eq-path-≡ {x = q'} adjs hz))) i j
+
+  entry-col : ∀ z → member-vertex z C ≡ Bool.true →
+              ∀ i j → fo-graph D z (at q) i j ≡ two.O
+  entry-col env     ()
+  entry-col (at q') hz i j =
+    nonzero-O (fo-graph D (at q') (at q))
+              (proj₂ (∨-false (nonzero (fo-graph D (at q) (at q')))
+                              (nonzero (fo-graph D (at q') (at q)))
+                              (member-All {eq = eq-path} eq-path-≡ {x = q'} adjs hz))) i j
+
+  base-row : (z : Vertex D) (i : Fin (vertex-width z)) (j : Fin (vertex-width (at q))) →
+             restrict (fo-graph D) C (at q) z i j ≡ two.O
+  base-row z i j =
+    ≡-trans (≡-cong (λ b → when (b ∨ member-vertex z C) (fo-graph D (at q) z) i j) hm)
+            (when-O (member-vertex z C) (fo-graph D (at q) z) i j (λ hz → entry-row z hz i j))
+
+  base-col : (z : Vertex D) (i : Fin (vertex-width (at q))) (j : Fin (vertex-width z)) →
+             restrict (fo-graph D) C z (at q) i j ≡ two.O
+  base-col z i j =
+    ≡-trans (≡-cong (λ b → when (member-vertex z C ∨ b) (fo-graph D z (at q)) i j) hm)
+    (≡-trans (≡-cong (λ b → when b (fo-graph D z (at q)) i j) (∨-identityʳ (member-vertex z C)))
+             (when-O (member-vertex z C) (fo-graph D z (at q)) i j (λ hz → entry-col z hz i j)))
+
+-- Hiding pairwise-apart, pairwise-disjoint regions inside a common restriction adds exactly
+-- their summaries: each region contributes its summary via localisation, and stays inert while
+-- the remaining regions are hidden.
+assemble : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+           {E : List (Path D)} (Cs : List (List (Path D))) →
+           All (λ C → ∀ q → member q C ≡ Bool.true → member q E ≡ Bool.true) Cs →
+           AllPairs (λ C C' → Apart (fo-graph D) C' C
+                            × (any (λ q → member q C) C' ≡ Bool.false)) Cs →
+           ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+           hide-all (restrict (fo-graph D) E) (map at (concat Cs)) x y i j ≡
+           foldr two._⊔_ (restrict (fo-graph D) E x y i j)
+                         (map (λ C → summary D C x y i j) Cs)
+assemble D []       []             []              x y i j = ≡-refl
+assemble D {E} (C ∷ Cs) (mono ∷ monos) (shead ∷ stail) x y i j =
+  ≡-trans (≡-cong (λ ws → hide-all R-E ws x y i j) (map-++ at C (concat Cs)))
+  (≡-trans (≡-cong (λ H → H x y i j) (foldl-++ hide R-E (map at C) (map at (concat Cs))))
+  (≡-trans (HA.fold-cong D (map at (concat Cs)) (localise D {C = C} mono) x y i j)
+  (≡-trans (HA.add-inert D {G = R-E} {S = summary D C} (map at (concat Cs)) inert x y i j)
+  (≡-trans (≡-cong (two._⊔ summary D C x y i j) (assemble D Cs monos stail x y i j))
+           (two.⊔-comm _ (summary D C x y i j))))))
+  where
+  R-E = restrict (fo-graph D) E
+  inert = AllP.map⁺ (AllP.concat⁺ (All-map
+            (λ {C'} (ap , ds) →
+              All-zip (λ {q} ha hm → summary-zero D {C = C} q hm ha)
+                      (any-false-All _ C' ap) (any-false-All _ C' ds))
+            shead))
+
+private
+  foldr-entry : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                (B : Graph D) (Gs : List (Graph D)) →
+                ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                foldr _+G_ B Gs x y i j ≡
+                foldr two._⊔_ (B x y i j) (map (λ H → H x y i j) Gs)
+  foldr-entry B []       x y i j = ≡-refl
+  foldr-entry B (H ∷ Gs) x y i j = ≡-cong (H x y i j two.⊔_) (foldr-entry B Gs x y i j)
+
+blocks-⊆ : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+           (Css : List (List (Path D))) →
+           All (λ C → ∀ q → member q C ≡ Bool.true → member q (concat Css) ≡ Bool.true) Css
+blocks-⊆ []         = []
+blocks-⊆ (C ∷ Css) =
+  (λ q h → ≡-trans (any-++ (eq-path q) C (concat Css)) (≡-cong (_∨ member q (concat Css)) h)) ∷
+  All-map (λ {C'} g q h →
+            ≡-trans (any-++ (eq-path q) C (concat Css))
+            (≡-trans (≡-cong (member q C ∨_) (g q h)) (∨-true (member q C))))
+          (blocks-⊆ Css)
+
+summary-snoc : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+               (p : Path D) (C : List (Path D)) →
+               ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+               summary D (p ∷ C) x y i j ≡
+               hide (hide-all (restrict (fo-graph D) (p ∷ C)) (map at C)) (at p) x y i j
+summary-snoc D p C x y i j =
+  ≡-trans (hide-all-perm (restrict-forward (p ∷ C) (fo-forward D)) perm x y i j)
+          (≡-cong (λ H → H x y i j)
+                  (foldl-++ hide (restrict (fo-graph D) (p ∷ C)) (map at C) (at p ∷ [])))
+  where
+  perm : (at p ∷ map at C) ↭ (map at C ++ (at p ∷ []))
+  perm = ↭-sym (↭-trans (shift (at p) (map at C) [])
+                        (↭-reflexive (≡-cong (at p ∷_) (++-identityʳ (map at C)))))
+
+Distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+           List (Path D) → List (Path D) → Set
+Distinct C C' = (any (λ q → member q C) C' ≡ Bool.false) × (any (λ q → member q C') C ≡ Bool.false)
+
+distinct-sym : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+               {C C' : List (Path D)} → Distinct C C' → Distinct C' C
+distinct-sym (a , b) = (b , a)
+
+private
+  bool-case : ∀ {a} {A : Set a} (b : Bool) → (b ≡ Bool.true → A) → (b ≡ Bool.false → A) → A
+  bool-case Bool.true  t f = t ≡-refl
+  bool-case Bool.false t f = f ≡-refl
+
+  when-I : ∀ (b : Bool) {m n} (R : M.Matrix m n) (i : Fin m) (j : Fin n) →
+           when b R i j ≡ two.I → (b ≡ Bool.true) × (R i j ≡ two.I)
+  when-I Bool.true  R i j h = ≡-refl , h
+
+  ∧-intro : ∀ {a b : Bool} → a ≡ Bool.true → b ≡ Bool.true → (a Bool.∧ b) ≡ Bool.true
+  ∧-intro e₁ e₂ = ≡-cong₂ Bool._∧_ e₁ e₂
+
+  not-false : ∀ {b : Bool} → b ≡ Bool.false → Bool.not b ≡ Bool.true
+  not-false e = ≡-cong Bool.not e
+
+  or-introl : ∀ (a b : Bool) → a ≡ Bool.true → (a ∨ b) ≡ Bool.true
+  or-introl a b e = ≡-cong (_∨ b) e
+
+  or-intror : ∀ (a b : Bool) → b ≡ Bool.true → (a ∨ b) ≡ Bool.true
+  or-intror a b e = ≡-trans (≡-cong (a ∨_) e) (∨-true a)
+
+  foldr-entryₘ : ∀ {m n} (B : M.Matrix m n) (Rs : List (M.Matrix m n)) (i : Fin m) (j : Fin n) →
+                 foldr M._+ₘ_ B Rs i j ≡ foldr two._⊔_ (B i j) (map (λ R' → R' i j) Rs)
+  foldr-entryₘ B []        i j = ≡-refl
+  foldr-entryₘ B (R' ∷ Rs) i j = ≡-cong (R' i j two.⊔_) (foldr-entryₘ B Rs i j)
+
+  block-of : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+             (q : Path D) (Css : List (List (Path D))) →
+             member q (concat Css) ≡ Bool.true → Any (λ C → member q C ≡ Bool.true) Css
+  block-of q Css h =
+    any-Any (λ C → member q C) Css (≡-trans (≡-sym (any-concat (eq-path q) Css)) h)
+
+private
+  -- The base of the assembled graph agrees with the restriction of the first-order graph to the
+  -- merged region, modulo the joined summaries of the merged regions: an entry at p is either a
+  -- first-order edge whose other end is visible or in a merged region, or a stored summary entry;
+  -- an end in an unmerged region is ruled out by non-adjacency.
+  base-agree : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+           (p : Path D) (K : Config D) → Summarised K →
+           member p (hidden-set K) ≡ Bool.false →
+           let tp = partitionᵇ (λ CH → any (λ q → adjacent (fo-graph D) (at p) (at q)) (proj₁ CH))
+                               (K .hidden) in
+           ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+           (restrict (visible-graph D K) (p ∷ []) x y i j two.⊔
+             foldr two._⊔_ two.O (map (λ C → summary D C x y i j) (map proj₁ (proj₁ tp))))
+           ≡ (restrict (fo-graph D) (p ∷ concat (map proj₁ (proj₁ tp))) x y i j two.⊔
+             foldr two._⊔_ two.O (map (λ C → summary D C x y i j) (map proj₁ (proj₁ tp))))
+  base-agree D p K S hp x' y' i' j' =
+    two.I-antisym
+      (λ h → [ fwd-B x' y' i' j' , two.⊔-I-inr _ ]′
+               (two.⊔-I (B x' y' i' j') (foldr two._⊔_ two.O (sums-at x' y' i' j')) h))
+      (λ h → [ bwd-B x' y' i' j' , two.⊔-I-inr _ ]′
+               (two.⊔-I (restrict G C* x' y' i' j') (foldr two._⊔_ two.O (sums-at x' y' i' j')) h))
+    where
+    G  = fo-graph D
+    adj-p : List (Path D) × Graph D → Bool
+    adj-p CH = any (λ q → adjacent G (at p) (at q)) (proj₁ CH)
+    tp = partitionᵇ adj-p (K .hidden)
+    Mp = proj₁ tp
+    Up = proj₂ tp
+    Ms = map proj₁ Mp
+    CM = concat Ms
+    C* = p ∷ CM
+    hs = hidden-set K
+    Vis = visible-graph D K
+    B = restrict Vis (p ∷ [])
+
+    u-adj : All (λ CH → adj-p CH ≡ Bool.false) Up
+    u-adj = part₂-false adj-p (K .hidden)
+
+    u-szero : All (λ CH →
+                (((z : Vertex D) (i' : Fin (vertex-width z)) (j' : Fin (vertex-width (at p))) →
+                  summary D (proj₁ CH) (at p) z i' j' ≡ two.O)
+               × ((z : Vertex D) (i' : Fin (vertex-width (at p))) (j' : Fin (vertex-width z)) →
+                  summary D (proj₁ CH) z (at p) i' j' ≡ two.O))) Up
+    u-szero = All-zip (λ {CH} hadj hm → summary-zero D {C = proj₁ CH} p hm hadj) u-adj
+                (proj₂ (partition-All adj-p (any-false-All _ (K .hidden)
+                  (≡-trans (≡-sym (any-map (λ C → member p C) proj₁ (K .hidden)))
+                           (≡-trans (≡-sym (any-concat (eq-path p) (map proj₁ (K .hidden)))) hp)))))
+
+    edge-O : ∀ {C : List (Path D)} → any (λ q → adjacent G (at p) (at q)) C ≡ Bool.false →
+             ∀ q' → member q' C ≡ Bool.true →
+             ((∀ i' j' → G (at p) (at q') i' j' ≡ two.O) ×
+              (∀ i' j' → G (at q') (at p) i' j' ≡ two.O))
+    edge-O {C} hadj q' hq =
+      (λ i' j' → nonzero-O (G (at p) (at q')) (proj₁ spl) i' j') ,
+      (λ i' j' → nonzero-O (G (at q') (at p)) (proj₂ spl) i' j')
+      where
+      spl = ∨-false (nonzero (G (at p) (at q'))) (nonzero (G (at q') (at p)))
+                    (member-All {eq = eq-path} eq-path-≡ {x = q'} (any-false-All _ C hadj) hq)
+
+    hid-split : ∀ q → member q hs ≡ Bool.true →
+                Any (λ CH → member q (proj₁ CH) ≡ Bool.true) Mp
+                ⊎ Any (λ CH → member q (proj₁ CH) ≡ Bool.true) Up
+    hid-split q h
+      with ∨-true-inv (any (λ CH → member q (proj₁ CH)) Mp)
+                      (any (λ CH → member q (proj₁ CH)) Up)
+                      (≡-trans (≡-sym (any-++ (λ CH → member q (proj₁ CH)) Mp Up))
+                       (≡-trans (any-perm (λ CH → member q (proj₁ CH))
+                                          (partition-↭ adj-p (K .hidden)))
+                        (≡-trans (≡-sym (any-map (λ C → member q C) proj₁ (K .hidden)))
+                                 (≡-trans (≡-sym (any-concat (eq-path q) (map proj₁ (K .hidden)))) h))))
+    ... | inj₁ e = inj₁ (any-Any _ Mp e)
+    ... | inj₂ e = inj₂ (any-Any _ Up e)
+
+    summary-I : ∀ (C : List (Path D)) x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+           (member-vertex x' C ∨ member-vertex y' C) ≡ Bool.true →
+           G x' y' i' j' ≡ two.I → summary D C x' y' i' j' ≡ two.I
+    summary-I C x' y' i' j' gd ge =
+      ≡-trans (HA.increasing D (map at C) x' y' i' j')
+              (≡-cong (two._⊔ hide-all (restrict G C) (map at C) x' y' i' j')
+                      (≡-trans (≡-cong (λ b → when b (G x' y') i' j') gd) ge))
+
+    sums-I : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) (b : two.Two) →
+          Any (λ C → summary D C x' y' i' j' ≡ two.I) Ms →
+          foldr two._⊔_ b (map (λ C → summary D C x' y' i' j') Ms) ≡ two.I
+    sums-I x' y' i' j' b a = two.foldr-⊔-at b (AnyPr.map⁺ a)
+
+    mv-p-≡ : ∀ z → member-vertex z (p ∷ []) ≡ Bool.true → z ≡ at p
+    mv-p-≡ env ()
+    mv-p-≡ (at q) h with ∨-true-inv (eq-path q p) Bool.false h
+    ... | inj₁ e = ≡-cong at (eq-path-≡ e)
+    ... | inj₂ ()
+
+    pguard-≡ : ∀ x' y' → (member-vertex x' (p ∷ []) ∨ member-vertex y' (p ∷ [])) ≡ Bool.true →
+               (x' ≡ at p) ⊎ (y' ≡ at p)
+    pguard-≡ x' y' h with ∨-true-inv (member-vertex x' (p ∷ [])) (member-vertex y' (p ∷ [])) h
+    ... | inj₁ e = inj₁ (mv-p-≡ x' e)
+    ... | inj₂ e = inj₂ (mv-p-≡ y' e)
+
+    p∈C* : member p C* ≡ Bool.true
+    p∈C* = or-introl (eq-path p p) (member p CM) (eq-path-refl p)
+
+    vis-or : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+             (x' ≡ at p) ⊎ (y' ≡ at p) → G x' y' i' j' ≡ two.I →
+             restrict G C* x' y' i' j' ≡ two.I
+    vis-or .(at p) y' i' j' (inj₁ ≡-refl) ge =
+      ≡-trans (≡-cong (λ b → when b (G (at p) y') i' j')
+                      (or-introl (member p C*) (member-vertex y' C*) p∈C*)) ge
+    vis-or x' .(at p) i' j' (inj₂ ≡-refl) ge =
+      ≡-trans (≡-cong (λ b → when b (G x' (at p)) i' j')
+                      (or-intror (member-vertex x' C*) (member p C*) p∈C*)) ge
+
+    vis-entry : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+                Vis x' y' i' j' ≡
+                foldr two._⊔_
+                      (when (Bool.not (member-vertex x' hs) Bool.∧ Bool.not (member-vertex y' hs))
+                            (G x' y') i' j')
+                      (map (λ CH → proj₂ CH x' y' i' j') (K .hidden))
+    vis-entry x' y' i' j' =
+      ≡-trans (foldr-entryₘ _ (map (λ CH → proj₂ CH x' y') (K .hidden)) i' j')
+              (≡-cong (foldr two._⊔_ _)
+                      (≡-sym (map-∘ {g = λ R' → R' i' j'} {f = λ CH → proj₂ CH x' y'} (K .hidden))))
+
+    sums-at : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) → List two.Two
+    sums-at x' y' i' j' = map (λ C → summary D C x' y' i' j') Ms
+
+    stored-or : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+                (x' ≡ at p) ⊎ (y' ≡ at p) →
+                (Any (λ CH → summary D (proj₁ CH) x' y' i' j' ≡ two.I) Mp
+                 ⊎ Any (λ CH → summary D (proj₁ CH) x' y' i' j' ≡ two.I) Up) →
+                (restrict G C* x' y' i' j' two.⊔ foldr two._⊔_ two.O (sums-at x' y' i' j')) ≡ two.I
+    stored-or x'      y' i' j' _             (inj₁ aM) =
+      two.⊔-I-inr _ (sums-I x' y' i' j' two.O (AnyPr.map⁺ aM))
+    stored-or .(at p) y' i' j' (inj₁ ≡-refl) (inj₂ aU) =
+      Any-contra (λ { (sI , (zr , _)) → two.O≢I (≡-trans (≡-sym (zr y' i' j')) sI) })
+                 (Any-All aU u-szero)
+    stored-or x' .(at p) i' j' (inj₂ ≡-refl) (inj₂ aU) =
+      Any-contra (λ { (sI , (_ , zc)) → two.O≢I (≡-trans (≡-sym (zc x' i' j')) sI) })
+                 (Any-All aU u-szero)
+
+    fwd-B : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+            B x' y' i' j' ≡ two.I →
+            (restrict G C* x' y' i' j' two.⊔ foldr two._⊔_ two.O (sums-at x' y' i' j')) ≡ two.I
+    fwd-B x' y' i' j' h with when-I (member-vertex x' (p ∷ []) ∨ member-vertex y' (p ∷ []))
+                                    (Vis x' y') i' j' h
+    ... | (pgt , ve)
+      with two.foldr-⊔-I (when (Bool.not (member-vertex x' hs) Bool.∧ Bool.not (member-vertex y' hs))
+                           (G x' y') i' j')
+                     (map (λ CH → proj₂ CH x' y' i' j') (K .hidden))
+                     (≡-trans (≡-sym (vis-entry x' y' i' j')) ve)
+    ...   | inj₁ vb =
+      two.⊔-I-inl (vis-or x' y' i' j' (pguard-≡ x' y' pgt)
+                          (proj₂ (when-I (Bool.not (member-vertex x' hs) Bool.∧ Bool.not (member-vertex y' hs))
+                                     (G x' y') i' j' vb)))
+    ...   | inj₂ aS =
+      stored-or x' y' i' j' (pguard-≡ x' y' pgt)
+        (AnyPr.++⁻ Mp (Any-resp-↭ (↭-sym (partition-↭ adj-p (K .hidden)))
+          (Any-map (λ (eI , inv) → ≡-trans (≡-sym (inv x' y' i' j')) eI)
+                   (Any-All (AnyPr.map⁻ aS) (S .summaries)))))
+
+    B-visible-x : ∀ y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width (at p))) →
+                   member-vertex y' hs ≡ Bool.false → G (at p) y' i' j' ≡ two.I →
+                   B (at p) y' i' j' ≡ two.I
+    B-visible-x y' i' j' hy ge =
+      ≡-trans (≡-cong (λ b → when b (Vis (at p) y') i' j')
+                      (or-introl (member p (p ∷ [])) (member-vertex y' (p ∷ []))
+                                 (≡-cong (_∨ Bool.false) (eq-path-refl p))))
+      (≡-trans (vis-entry (at p) y' i' j')
+               (two.foldr-⊔-here (map (λ CH → proj₂ CH (at p) y' i' j') (K .hidden))
+                 (≡-trans (≡-cong (λ b → when b (G (at p) y') i' j')
+                                  (∧-intro (not-false hp) (not-false hy)))
+                          ge)))
+
+    B-visible-y : ∀ x' (i' : Fin (vertex-width (at p))) (j' : Fin (vertex-width x')) →
+                   member-vertex x' hs ≡ Bool.false → G x' (at p) i' j' ≡ two.I →
+                   B x' (at p) i' j' ≡ two.I
+    B-visible-y x' i' j' hx ge =
+      ≡-trans (≡-cong (λ b → when b (Vis x' (at p)) i' j')
+                      (or-intror (member-vertex x' (p ∷ [])) (member p (p ∷ []))
+                                 (≡-cong (_∨ Bool.false) (eq-path-refl p))))
+      (≡-trans (vis-entry x' (at p) i' j')
+               (two.foldr-⊔-here (map (λ CH → proj₂ CH x' (at p) i' j') (K .hidden))
+                 (≡-trans (≡-cong (λ b → when b (G x' (at p)) i' j')
+                                  (∧-intro (not-false hx) (not-false hp)))
+                          ge)))
+
+    bwd-px : ∀ y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width (at p))) →
+             G (at p) y' i' j' ≡ two.I →
+             (B (at p) y' i' j' two.⊔ foldr two._⊔_ two.O (sums-at (at p) y' i' j')) ≡ two.I
+    bwd-px env i' j' ge = two.⊔-I-inl (B-visible-x env i' j' ≡-refl ge)
+    bwd-px (at qy) i' j' ge =
+      bool-case (member qy hs)
+        (λ hy → [ (λ aM → two.⊔-I-inr _ (sums-I (at p) (at qy) i' j' two.O
+                    (AnyPr.map⁺ (Any-map (λ {CH} mem →
+                      summary-I (proj₁ CH) (at p) (at qy) i' j'
+                           (or-intror (member p (proj₁ CH)) (member qy (proj₁ CH)) mem) ge) aM))))
+                , (λ aU → Any-contra
+                            (λ { {CH} (mem , adj) →
+                                 two.O≢I (≡-trans (≡-sym (proj₁ (edge-O {C = proj₁ CH} adj qy mem) i' j'))
+                                         ge) })
+                            (Any-All aU u-adj)) ]′ (hid-split qy hy))
+        (λ hy → two.⊔-I-inl (B-visible-x (at qy) i' j' hy ge))
+
+    bwd-py : ∀ x' (i' : Fin (vertex-width (at p))) (j' : Fin (vertex-width x')) →
+             G x' (at p) i' j' ≡ two.I →
+             (B x' (at p) i' j' two.⊔ foldr two._⊔_ two.O (sums-at x' (at p) i' j')) ≡ two.I
+    bwd-py env i' j' ge = two.⊔-I-inl (B-visible-y env i' j' ≡-refl ge)
+    bwd-py (at qx) i' j' ge =
+      bool-case (member qx hs)
+        (λ hx → [ (λ aM → two.⊔-I-inr _ (sums-I (at qx) (at p) i' j' two.O
+                    (AnyPr.map⁺ (Any-map (λ {CH} mem →
+                      summary-I (proj₁ CH) (at qx) (at p) i' j'
+                           (or-introl (member qx (proj₁ CH)) (member p (proj₁ CH)) mem) ge) aM))))
+                , (λ aU → Any-contra
+                            (λ { {CH} (mem , adj) →
+                                 two.O≢I (≡-trans (≡-sym (proj₂ (edge-O {C = proj₁ CH} adj qx mem) i' j'))
+                                         ge) })
+                            (Any-All aU u-adj)) ]′ (hid-split qx hx))
+        (λ hx → two.⊔-I-inl (B-visible-y (at qx) i' j' hx ge))
+
+    bwd-l : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+            G x' y' i' j' ≡ two.I → member-vertex x' C* ≡ Bool.true →
+            (B x' y' i' j' two.⊔ foldr two._⊔_ two.O (sums-at x' y' i' j')) ≡ two.I
+    bwd-l env     y' i' j' ge ()
+    bwd-l (at qx) y' i' j' ge hx with ∨-true-inv (eq-path qx p) (member qx CM) hx
+    ... | inj₂ m =
+      two.⊔-I-inr _
+        (sums-I (at qx) y' i' j' two.O
+             (Any-map (λ {C} mem →
+                         summary-I C (at qx) y' i' j' (or-introl (member qx C) (member-vertex y' C) mem) ge)
+                      (block-of qx Ms m)))
+    ... | inj₁ ep with eq-path-≡ {p = qx} {q = p} ep
+    ...   | ≡-refl = bwd-px y' i' j' ge
+
+    bwd-r : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+            G x' y' i' j' ≡ two.I → member-vertex y' C* ≡ Bool.true →
+            (B x' y' i' j' two.⊔ foldr two._⊔_ two.O (sums-at x' y' i' j')) ≡ two.I
+    bwd-r x' env     i' j' ge ()
+    bwd-r x' (at qy) i' j' ge hy with ∨-true-inv (eq-path qy p) (member qy CM) hy
+    ... | inj₂ m =
+      two.⊔-I-inr _
+        (sums-I x' (at qy) i' j' two.O
+             (Any-map (λ {C} mem →
+                         summary-I C x' (at qy) i' j' (or-intror (member-vertex x' C) (member qy C) mem) ge)
+                      (block-of qy Ms m)))
+    ... | inj₁ ep with eq-path-≡ {p = qy} {q = p} ep
+    ...   | ≡-refl = bwd-py x' i' j' ge
+
+    bwd-B : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+            restrict G C* x' y' i' j' ≡ two.I →
+            (B x' y' i' j' two.⊔ foldr two._⊔_ two.O (sums-at x' y' i' j')) ≡ two.I
+    bwd-B x' y' i' j' h with when-I (member-vertex x' C* ∨ member-vertex y' C*) (G x' y') i' j' h
+    ... | (gd , ge) with ∨-true-inv (member-vertex x' C*) (member-vertex y' C*) gd
+    ...   | inj₁ hx = bwd-l x' y' i' j' ge hx
+    ...   | inj₂ hy = bwd-r x' y' i' j' ge hy
+
+-- The graph assembled by the hide move, hidden at p, is the summary of the merged region.
+merged-summary : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                 (p : Path D) (K : Config D) → Summarised K →
+                 member p (hidden-set K) ≡ Bool.false →
+                 AllPairs Distinct (map proj₁ (K .hidden)) →
+                 let tp = partitionᵇ (λ CH → any (λ q → adjacent (fo-graph D) (at p) (at q)) (proj₁ CH))
+                                     (K .hidden) in
+                 ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                 hide (foldr _+G_ (restrict (visible-graph D K) (p ∷ []))
+                                  (map proj₂ (proj₁ tp)))
+                      (at p) x y i j
+                 ≡ summary D (p ∷ concat (map proj₁ (proj₁ tp))) x y i j
+merged-summary D p K S hp dist x y i j =
+  ≡-trans (HA.h-cong D (at p) core x y i j) (≡-sym (summary-snoc D p CM x y i j))
+  where
+  G  = fo-graph D
+  adj-p : List (Path D) × Graph D → Bool
+  adj-p CH = any (λ q → adjacent G (at p) (at q)) (proj₁ CH)
+  tp = partitionᵇ adj-p (K .hidden)
+  Mp = proj₁ tp
+  Ms = map proj₁ Mp
+  CM = concat Ms
+  C* = p ∷ CM
+  B = restrict (visible-graph D K) (p ∷ [])
+
+  sums-at : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) → List two.Two
+  sums-at x' y' i' j' = map (λ C → summary D C x' y' i' j') Ms
+
+  base-swap : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+              foldr two._⊔_ (B x' y' i' j') (sums-at x' y' i' j') ≡
+              foldr two._⊔_ (restrict G C* x' y' i' j') (sums-at x' y' i' j')
+  base-swap x' y' i' j' =
+    ≡-trans (two.foldr-⊔-base (B x' y' i' j') (sums-at x' y' i' j'))
+    (≡-trans (base-agree D p K S hp x' y' i' j')
+             (≡-sym (two.foldr-⊔-base (restrict G C* x' y' i' j') (sums-at x' y' i' j'))))
+
+  maps≡ : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+          map (λ H → H x' y' i' j') (map proj₂ Mp) ≡ sums-at x' y' i' j'
+  maps≡ x' y' i' j' =
+    ≡-trans (≡-sym (map-∘ {g = λ H → H x' y' i' j'} {f = proj₂} Mp))
+    (≡-trans (map-All-cong (All-map (λ inv → inv x' y' i' j')
+                                    (proj₁ (partition-All adj-p (S .summaries)))))
+             (map-∘ {g = λ C → summary D C x' y' i' j'} {f = proj₁} Mp))
+
+  monosC* : All (λ C → ∀ q → member q C ≡ Bool.true → member q C* ≡ Bool.true) Ms
+  monosC* = All-map (λ g q h → or-intror (eq-path q p) (member q CM) (g q h)) (blocks-⊆ Ms)
+
+  sepsMs : AllPairs (λ C C' → Apart G C' C × (any (λ q → member q C) C' ≡ Bool.false)) Ms
+  sepsMs =
+    AllPairs-map (λ {C} {C'} (ap , d) → (apart-sym G {C} {C'} ap , proj₁ d))
+      (subst (AllPairs (λ C C' → Apart G C C' × Distinct C C'))
+             (map-partition₁ proj₁ (λ C → any (λ q → adjacent G (at p) (at q)) C) (K .hidden))
+             (proj₁ (partition-AllPairs {S = λ C C' → Apart G C C' × Distinct C C'}
+                      (λ C → any (λ q → adjacent G (at p) (at q)) C)
+                      (λ {C} {C'} (ap , d) → (apart-sym G {C} {C'} ap , distinct-sym {C = C} {C' = C'} d))
+                      (AllPairs-zip (S .separated) dist))))
+
+  core : ∀ x' y' (i' : Fin (vertex-width y')) (j' : Fin (vertex-width x')) →
+         foldr _+G_ B (map proj₂ Mp) x' y' i' j' ≡
+         hide-all (restrict G C*) (map at CM) x' y' i' j'
+  core x' y' i' j' =
+    ≡-trans (foldr-entry B (map proj₂ Mp) x' y' i' j')
+    (≡-trans (≡-cong (foldr two._⊔_ (B x' y' i' j')) (maps≡ x' y' i' j'))
+    (≡-trans (base-swap x' y' i' j')
+             (≡-sym (assemble D {C*} Ms monosC* sepsMs x' y' i' j'))))
+
+-- The first-order paths inherit distinctness from the path enumeration.
+FO-distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+              AllPairs (λ q q' → eq-path q q' ≡ Bool.false) (FO D)
+FO-distinct D = filter-AllPairs (λ p → Bool.not (is-ε p) Bool.∧ fo-at p) (paths-distinct D)
+
+private
+  partition-distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                       (K : Config D) → Summarised K →
+                       AllPairs (λ q q' → eq-path q q' ≡ Bool.false)
+                                (K .visible ++ hidden-set K)
+  partition-distinct {D = D} K S =
+    AllPairs-perm (λ {q} {q'} h → eq-path-false-sym {p = q} {q = q'} h)
+                  (↭-sym (S .partition)) (FO-distinct D)
+
+  concat-distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                    (Css : List (List (Path D))) →
+                    AllPairs (λ q q' → eq-path q q' ≡ Bool.false) (concat Css) →
+                    AllPairs Distinct Css
+  concat-distinct []        ps = []
+  concat-distinct (C ∷ Css) ps with AllPairs-++⁻ C (concat Css) ps
+  ... | (_ , aCss , cross) =
+    All-map
+      (λ {C'} a →
+        any-false (All-map (λ {q'} aq' →
+                              any-false (All-map (λ {q} hb → eq-path-false-sym {p = q} {q = q'} hb)
+                                                 aq'))
+                           (AllP.All-swap a)) ,
+        any-false (All-map (λ {q} aq → any-false aq) a))
+      (AllP.All-swap (All-map AllP.concat⁻ cross))
+    ∷ concat-distinct Css aCss
+
+  visible-not-hidden : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                       (K : Config D) → Summarised K → ∀ {p} →
+                       member p (K .visible) ≡ Bool.true →
+                       member p (hidden-set K) ≡ Bool.false
+  visible-not-hidden K S {p} pv =
+    any-false (member-All {eq = eq-path} eq-path-≡ {x = p}
+                (proj₂ (proj₂ (AllPairs-++⁻ (K .visible) (hidden-set K)
+                                            (partition-distinct K S))))
+                pv)
+
+-- A summarised configuration's stored regions are pairwise disjoint: the partition invariant
+-- places them inside the duplicate-free first-order paths.
+summarised-distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                      (K : Config D) → Summarised K →
+                      AllPairs Distinct (map proj₁ (K .hidden))
+summarised-distinct K S =
+  concat-distinct (map proj₁ (K .hidden))
+    (proj₁ (proj₂ (AllPairs-++⁻ (K .visible) (hidden-set K) (partition-distinct K S))))
+
+-- Hiding a visible vertex preserves correct summarisation.
+hide-at-summarised : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                     (p : Path D) (K : Config D) → Summarised K →
+                     member p (K .visible) ≡ Bool.true →
+                     Summarised (hide-at D p K)
+hide-at-summarised D p K S pv .partition =
+  ↭-trans (++⁺ ↭-refl (hide-at-hidden-set D p K))
+  (↭-trans (shift p (hide-at D p K .visible) (hidden-set K))
+  (↭-trans (++⁺ (filter-out-↭ {eq = eq-path} (λ {q} {q'} e → eq-path-≡ {p = q} {q = q'} e)
+                  (proj₁ (AllPairs-++⁻ (K .visible) (hidden-set K) (partition-distinct K S)))
+                  pv)
+                ↭-refl)
+           (S .partition)))
+hide-at-summarised D p K S pv .separated = hide-at-separated D p K S
+hide-at-summarised D p K S pv .summaries =
+  merged-summary D p K S (visible-not-hidden K S {p = p} pv) (summarised-distinct K S) ∷
+  proj₂ (partition-All (λ CH → any (λ q → adjacent (fo-graph D) (at p) (at q)) (proj₁ CH))
+                      (S .summaries))
+
+private
+  -- Apart in pointwise form, and its monotonicity under region inclusion.
+  Apart-All : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+              {G : Graph D} {C C' : List (Path D)} → Apart G C C' →
+              All (λ q → All (λ q' → adjacent G (at q) (at q') ≡ Bool.false) C') C
+  Apart-All {C = C} {C'} ap = All-map (λ h → any-false-All _ C' h) (any-false-All _ C ap)
+
+  Apart-mono : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+               {G : Graph D} {C₁ C₂ C₁' C₂' : List (Path D)} →
+               (∀ q → member q C₁ ≡ Bool.true → member q C₁' ≡ Bool.true) →
+               (∀ q → member q C₂ ≡ Bool.true → member q C₂' ≡ Bool.true) →
+               Apart G C₁' C₂' → Apart G C₁ C₂
+  Apart-mono {G = G} {C₁ = C₁} {C₂} {C₁'} {C₂'} m₁ m₂ ap =
+    any-false (All-map
+      (λ {q} mq → any-false (All-map
+        (λ {q'} mq' →
+          member-All {eq = eq-path} eq-path-≡ {x = q'}
+            (member-All {eq = eq-path} eq-path-≡ {x = q}
+               (Apart-All {G = G} {C = C₁'} {C' = C₂'} ap) (m₁ q mq))
+            (m₂ q' mq'))
+        (any-self eq-path-refl C₂)))
+      (any-self eq-path-refl C₁))
+
+  -- Each piece of a split region lies inside the region.
+  split-⊆ : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (p : Path D)
+            (CH : List (Path D) × Graph D) →
+            All (λ C₁ → ∀ q → member q C₁ ≡ Bool.true → member q (proj₁ CH) ≡ Bool.true)
+                (map proj₁ (split-region D p CH))
+  split-⊆ D p (C , H) with member p C
+  ... | Bool.false = (λ q h → h) ∷ []
+  ... | Bool.true  =
+    subst (All (λ C₁ → ∀ q → member q C₁ ≡ Bool.true → member q C ≡ Bool.true))
+          (≡-sym (map-proj₁-pair (summary D) (regions (fo-graph D) C∖p)))
+          (All-map (λ {C₁} inc q h →
+                      any-filterᵇ (eq-path q) (λ q' → Bool.not (eq-path p q')) C
+                        (≡-trans (≡-sym (member-perm q (regions-concat (fo-graph D) C∖p)))
+                                 (inc q h)))
+                   (blocks-⊆ (regions (fo-graph D) C∖p)))
+    where C∖p = filterᵇ (λ q → Bool.not (eq-path p q)) C
+
+  -- Splitting leaves a region without p alone.
+  split-none : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (p : Path D)
+               {CHs : List (List (Path D) × Graph D)} →
+               All (λ CH → member p (proj₁ CH) ≡ Bool.false) CHs →
+               concat (map (split-region D p) CHs) ≡ CHs
+  split-none D p []                     = ≡-refl
+  split-none D p (_∷_ {C , H} h hs) rewrite h = ≡-cong ((C , H) ∷_) (split-none D p hs)
+
+  -- Splitting at a hidden vertex removes exactly p from the hidden set.
+  reveal-set : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (p : Path D)
+               (CHs : List (List (Path D) × Graph D)) →
+               AllPairs (λ q q' → eq-path q q' ≡ Bool.false) (concat (map proj₁ CHs)) →
+               any (λ CH → member p (proj₁ CH)) CHs ≡ Bool.true →
+               (p ∷ concat (map proj₁ (concat (map (split-region D p) CHs))))
+               ↭ concat (map proj₁ CHs)
+  reveal-set D p ((C , H) ∷ CHs) ps h
+    with AllPairs-++⁻ C (concat (map proj₁ CHs)) ps
+  ... | (aC , aRest , cross) with member p C in e
+  ...   | Bool.false =
+    ↭-trans (↭-sym (shift p C (concat (map proj₁ (concat (map (split-region D p) CHs))))))
+            (++⁺ ↭-refl (reveal-set D p CHs aRest h))
+  ...   | Bool.true  =
+    ↭-trans (↭-reflexive (≡-cong (λ z → p ∷ concat z) (map-++ proj₁ X Z)))
+    (↭-trans (↭-reflexive (≡-cong (p ∷_) (≡-sym (concat-++ (map proj₁ X) (map proj₁ Z)))))
+    (↭-trans (↭-reflexive (≡-cong₂ (λ u v → p ∷ (concat u ++ concat (map proj₁ v)))
+                                   (map-proj₁-pair (summary D) Regs)
+                                   (split-none D p no-p-tail)))
+             (++⁺ head-perm ↭-refl)))
+    where
+    C∖p  = filterᵇ (λ q → Bool.not (eq-path p q)) C
+    Regs = regions (fo-graph D) C∖p
+    X    = map (λ C' → C' , summary D C') Regs
+    Z    = concat (map (split-region D p) CHs)
+
+    no-p-tail : All (λ CH → member p (proj₁ CH) ≡ Bool.false) CHs
+    no-p-tail =
+      any-false-All _ CHs
+        (≡-trans (≡-sym (any-map (λ C' → member p C') proj₁ CHs))
+          (≡-trans (≡-sym (any-concat (eq-path p) (map proj₁ CHs)))
+                   (any-false (member-All {eq = eq-path} eq-path-≡ {x = p} cross e))))
+
+    head-perm : (p ∷ concat Regs) ↭ C
+    head-perm =
+      ↭-trans (↭.prep p (regions-concat (fo-graph D) C∖p))
+              (filter-out-↭ {eq = eq-path} (λ {q} {q'} e' → eq-path-≡ {p = q} {q = q'} e')
+                            aC e)
+
+  -- The pieces of a split region are pairwise apart, and each pair equals its summary.
+  split-separated : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (p : Path D)
+                    (CH : List (Path D) × Graph D) →
+                    AllPairs (Apart (fo-graph D)) (map proj₁ (split-region D p CH))
+  split-separated D p (C , H) with member p C
+  ... | Bool.false = [] ∷ []
+  ... | Bool.true  =
+    subst (AllPairs (Apart (fo-graph D)))
+          (≡-sym (map-proj₁-pair (summary D) (regions (fo-graph D) C∖p)))
+          (regions-separated (fo-graph D) C∖p)
+    where C∖p = filterᵇ (λ q → Bool.not (eq-path p q)) C
+
+  split-summaries : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (p : Path D)
+                    (CH : List (Path D) × Graph D) →
+                    (∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                     proj₂ CH x y i j ≡ summary D (proj₁ CH) x y i j) →
+                    All (λ CH' → ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                                 proj₂ CH' x y i j ≡ summary D (proj₁ CH') x y i j)
+                        (split-region D p CH)
+  split-summaries D p (C , H) old with member p C
+  ... | Bool.false = old ∷ []
+  ... | Bool.true  =
+    AllP.map⁺ (universal (λ C' x y i j → ≡-refl)
+                         (regions (fo-graph D) (filterᵇ (λ q → Bool.not (eq-path p q)) C)))
+
+-- Revealing a hidden vertex preserves correct summarisation.
+reveal-at-summarised : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                       (p : Path D) (K : Config D) → Summarised K →
+                       member p (hidden-set K) ≡ Bool.true →
+                       Summarised (reveal-at D p K)
+reveal-at-summarised D p K S hp .partition =
+  ↭-trans (↭-sym (shift p (K .visible) (hidden-set (reveal-at D p K))))
+  (↭-trans (++⁺ ↭-refl
+              (reveal-set D p (K .hidden)
+                 (proj₁ (proj₂ (AllPairs-++⁻ (K .visible) (hidden-set K)
+                                             (partition-distinct K S))))
+                 (≡-trans (≡-sym (any-map (λ C → member p C) proj₁ (K .hidden)))
+                          (≡-trans (≡-sym (any-concat (eq-path p) (map proj₁ (K .hidden)))) hp))))
+           (S .partition))
+reveal-at-summarised D p K S hp .separated =
+  subst (AllPairs (Apart (fo-graph D)))
+        (≡-trans (≡-cong concat (map-∘ {g = map proj₁} {f = split-region D p} (K .hidden)))
+                 (concat-map {f = proj₁} (map (split-region D p) (K .hidden))))
+        (AllPairsP.concat⁺
+          (AllP.map⁺ (All-map (λ {CH} _ → split-separated D p CH)
+                              (S .summaries)))
+          (AllPairsP.map⁺
+            (AllPairs-map (λ {CH} {CH'} ap →
+                             All-map (λ {C₁} m₁ →
+                                        All-map (λ {C₂} m₂ →
+                                                   Apart-mono {G = fo-graph D}
+                                                     {C₁ = C₁} {C₂ = C₂}
+                                                     {C₁' = proj₁ CH} {C₂' = proj₁ CH'}
+                                                     m₁ m₂ ap)
+                                                (split-⊆ D p CH'))
+                                     (split-⊆ D p CH))
+                          (AllPairsP.map⁻ (S .separated)))))
+reveal-at-summarised D p K S hp .summaries =
+  AllP.concat⁺ (AllP.map⁺ (All-map (λ {CH} old → split-summaries D p CH old) (S .summaries)))
+
+private
+  visible-entry : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) (K : Config D) →
+                  ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                  visible-graph D K x y i j ≡
+                  foldr two._⊔_
+                        (when (Bool.not (member-vertex x (hidden-set K)) Bool.∧
+                               Bool.not (member-vertex y (hidden-set K)))
+                              (fo-graph D x y) i j)
+                        (map (λ CH → proj₂ CH x y i j) (K .hidden))
+  visible-entry D K x y i j =
+    ≡-trans (foldr-entryₘ _ (map (λ CH → proj₂ CH x y) (K .hidden)) i j)
+            (≡-cong (foldr two._⊔_ _)
+                    (≡-sym (map-∘ {g = λ R' → R' i j} {f = λ CH → proj₂ CH x y} (K .hidden))))
+
+-- At an entry with no hidden endpoint, the visible graph is the first-order entry joined with the
+-- summary of the whole hidden set: the stored summaries assemble to the single-region summary.
+visible-graph-summary : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                        (K : Config D) → Summarised K →
+                        ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                        member-vertex x (hidden-set K) ≡ Bool.false →
+                        member-vertex y (hidden-set K) ≡ Bool.false →
+                        visible-graph D K x y i j ≡
+                        (fo-graph D x y i j two.⊔ summary D (hidden-set K) x y i j)
+visible-graph-summary D K S x y i j hx hy =
+  ≡-trans (visible-entry D K x y i j)
+  (≡-trans (two.foldr-⊔-base _ (map (λ CH → proj₂ CH x y i j) (K .hidden)))
+           (≡-cong₂ two._⊔_ base-eq Σ-eq))
+  where
+  G  = fo-graph D
+  E  = hidden-set K
+  Cs = map proj₁ (K .hidden)
+
+  base-eq : when (Bool.not (member-vertex x E) Bool.∧ Bool.not (member-vertex y E)) (G x y) i j
+            ≡ G x y i j
+  base-eq = ≡-cong (λ b → when b (G x y) i j) (∧-intro (not-false hx) (not-false hy))
+
+  stored-eq : map (λ CH → proj₂ CH x y i j) (K .hidden) ≡ map (λ C → summary D C x y i j) Cs
+  stored-eq = ≡-trans (map-All-cong (All-map (λ inv → inv x y i j) (S .summaries)))
+                      (map-∘ {g = λ C → summary D C x y i j} {f = proj₁} (K .hidden))
+
+  seps : AllPairs (λ C C' → Apart G C' C × (any (λ q → member q C) C' ≡ Bool.false)) Cs
+  seps = AllPairs-map (λ {C} {C'} (ap , d) → (apart-sym G {C} {C'} ap , proj₁ d))
+                      (AllPairs-zip (S .separated) (summarised-distinct K S))
+
+  restrict-O : restrict G E x y i j ≡ two.O
+  restrict-O = ≡-cong (λ b → when b (G x y) i j) (≡-cong₂ _∨_ hx hy)
+
+  Σ-eq : foldr two._⊔_ two.O (map (λ CH → proj₂ CH x y i j) (K .hidden))
+         ≡ summary D E x y i j
+  Σ-eq =
+    ≡-trans (≡-cong (foldr two._⊔_ two.O) stored-eq)
+    (≡-sym (≡-trans (assemble D {E} Cs (blocks-⊆ Cs) seps x y i j)
+           (≡-trans (two.foldr-⊔-base (restrict G E x y i j)
+                                      (map (λ C → summary D C x y i j) Cs))
+                    (≡-cong (two._⊔ foldr two._⊔_ two.O (map (λ C → summary D C x y i j) Cs))
+                            restrict-O))))
+
+-- Reveal after hide at the same vertex restores the visible set and the hidden set, and hence the
+-- visible graph at entries with no hidden endpoint.
+hide-reveal-visible : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                      (p : Path D) (K : Config D) → Summarised K →
+                      member p (K .visible) ≡ Bool.true →
+                      reveal-at D p (hide-at D p K) .visible ↭ K .visible
+hide-reveal-visible D p K S pv =
+  filter-out-↭ {eq = eq-path} (λ {q} {q'} e → eq-path-≡ {p = q} {q = q'} e)
+               (proj₁ (AllPairs-++⁻ (K .visible) (hidden-set K) (partition-distinct K S))) pv
+
+hide-reveal-hidden-set : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                         (p : Path D) (K : Config D) → Summarised K →
+                         member p (K .visible) ≡ Bool.true →
+                         hidden-set (reveal-at D p (hide-at D p K)) ↭ hidden-set K
+hide-reveal-hidden-set D p K S pv =
+  drop-∷ (↭-trans (reveal-set D p (hide-at D p K .hidden)
+                    (proj₁ (proj₂ (AllPairs-++⁻ (hide-at D p K .visible)
+                                                (hidden-set (hide-at D p K))
+                                                (partition-distinct (hide-at D p K)
+                                                  (hide-at-summarised D p K S pv)))))
+                    (or-introl _ _ (or-introl (eq-path p p) _ (eq-path-refl p))))
+                  (hide-at-hidden-set D p K))
+
+hide-reveal-graph : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+                    (p : Path D) (K : Config D) → Summarised K →
+                    member p (K .visible) ≡ Bool.true →
+                    ∀ x y (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                    member-vertex x (hidden-set K) ≡ Bool.false →
+                    member-vertex y (hidden-set K) ≡ Bool.false →
+                    visible-graph D (reveal-at D p (hide-at D p K)) x y i j ≡
+                    visible-graph D K x y i j
+hide-reveal-graph D p K S pv x y i j hx hy =
+  ≡-trans (visible-graph-summary D (reveal-at D p (hide-at D p K))
+             (reveal-at-summarised D p (hide-at D p K) (hide-at-summarised D p K S pv)
+                (≡-trans (member-perm p (hide-at-hidden-set D p K))
+                         (or-introl (eq-path p p) (member p (hidden-set K)) (eq-path-refl p))))
+             x y i j
+             (≡-trans (member-vertex-perm x (hide-reveal-hidden-set D p K S pv)) hx)
+             (≡-trans (member-vertex-perm y (hide-reveal-hidden-set D p K S pv)) hy))
+  (≡-trans (≡-cong (fo-graph D x y i j two.⊔_)
+                   (summary-perm D (hide-reveal-hidden-set D p K S pv) x y i j))
+           (≡-sym (visible-graph-summary D K S x y i j hx hy)))
diff --git a/agda/src/language-operational/path.agda b/agda/src/language-operational/path.agda
new file mode 100644
index 00000000..36331fce
--- /dev/null
+++ b/agda/src/language-operational/path.agda
@@ -0,0 +1,759 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Data.Fin using (zero)
+open import Data.Bool as Bool using (Bool; not; _∧_)
+open import Data.Bool.ListAction using (any)
+open import Data.List using (List; []; _∷_; _++_; map; filterᵇ)
+open import Data.List.Relation.Unary.All using (All; []; _∷_; universal)
+open import Data.List.Relation.Unary.AllPairs using (AllPairs; []; _∷_)
+import Data.List.Relation.Unary.All.Properties as AllP
+import Data.List.Relation.Unary.AllPairs.Properties as AllPairsP
+open import Data.Nat using (ℕ; suc; _+_)
+open import every using (Every; []; _∷_)
+open import Relation.Binary.PropositionalEquality using (_≡_)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; cong to ≡-cong)
+open import Relation.Nullary.Decidable using (⌊_⌋)
+open import signature using (Signature)
+open import primitives using (Primitives)
+import matrix
+import two
+
+-- Paths of a derivation: ε addresses the derivation itself, and each step constructor addresses one
+-- premise, in evaluation order. One path type per judgement form, mutually with the judgements they
+-- index.
+module language-operational.path {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open import language-syntax Sig renaming (_,_ to _▸_)
+open import type-substitution Sig using (unfold₁)
+open import language-operational.evaluation Sig 𝒫
+
+private
+  module M = matrix.Mat two.semiring
+
+open import categories using (Category; HasProducts)
+open Category M.cat using (_⇒_; _∘_)
+open HasProducts products using (p₁; p₂)
+
+mutual
+  data Path : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v : Val τ} {R : width-env γ ⇒ width v} →
+              γ , t ⇓ v [ R ] → Set ℓ where
+    ε       : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Path D
+    inl     : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁} {v R} {D : γ , t ⇓ v [ R ]} →
+              Path D → Path (⇓-inl {τ₂ = τ₂} D)
+    inr     : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₂} {v R} {D : γ , t ⇓ v [ R ]} →
+              Path D → Path (⇓-inr {τ₁ = τ₁} D)
+    case-l₁ : ∀ {Γ τ₁ τ₂ τ} {γ : Env Γ} {s : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+              {v u R S} {D₁ : γ , s ⇓ inl v [ R ]} {D₂ : γ · v , t₁ ⇓ u [ S ]} →
+              Path D₁ → Path (⇓-case-l {t₂ = t₂} D₁ D₂)
+    case-l₂ : ∀ {Γ τ₁ τ₂ τ} {γ : Env Γ} {s : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+              {v u R S} {D₁ : γ , s ⇓ inl v [ R ]} {D₂ : γ · v , t₁ ⇓ u [ S ]} →
+              Path D₂ → Path (⇓-case-l {t₂ = t₂} D₁ D₂)
+    case-r₁ : ∀ {Γ τ₁ τ₂ τ} {γ : Env Γ} {s : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+              {v u R S} {D₁ : γ , s ⇓ inr v [ R ]} {D₂ : γ · v , t₂ ⇓ u [ S ]} →
+              Path D₁ → Path (⇓-case-r {t₁ = t₁} D₁ D₂)
+    case-r₂ : ∀ {Γ τ₁ τ₂ τ} {γ : Env Γ} {s : Γ ⊢ τ₁ [+] τ₂} {t₁ : Γ ▸ τ₁ ⊢ τ} {t₂ : Γ ▸ τ₂ ⊢ τ}
+              {v u R S} {D₁ : γ , s ⇓ inr v [ R ]} {D₂ : γ · v , t₂ ⇓ u [ S ]} →
+              Path D₂ → Path (⇓-case-r {t₁ = t₁} D₁ D₂)
+    pair₁   : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {s : Γ ⊢ τ₁} {t : Γ ⊢ τ₂} {v u R S}
+              {D₁ : γ , s ⇓ v [ R ]} {D₂ : γ , t ⇓ u [ S ]} →
+              Path D₁ → Path (⇓-pair D₁ D₂)
+    pair₂   : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {s : Γ ⊢ τ₁} {t : Γ ⊢ τ₂} {v u R S}
+              {D₁ : γ , s ⇓ v [ R ]} {D₂ : γ , t ⇓ u [ S ]} →
+              Path D₂ → Path (⇓-pair D₁ D₂)
+    fst     : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁ [×] τ₂} {v u R} {D : γ , t ⇓ pair v u [ R ]} →
+              Path D → Path (⇓-fst D)
+    snd     : ∀ {Γ τ₁ τ₂} {γ : Env Γ} {t : Γ ⊢ τ₁ [×] τ₂} {v u R} {D : γ , t ⇓ pair v u [ R ]} →
+              Path D → Path (⇓-snd D)
+    app₁    : ∀ {Γ Γ' σ τ} {γ : Env Γ} {γ' : Env Γ'} {s : Γ ⊢ σ [→] τ} {t t' v u R S T}
+              {D₁ : γ , s ⇓ clo {Γ'} γ' t' [ R ]} {D₂ : γ , t ⇓ v [ S ]} {D₃ : γ' · v , t' ⇓ u [ T ]} →
+              Path D₁ → Path (⇓-app D₁ D₂ D₃)
+    app₂    : ∀ {Γ Γ' σ τ} {γ : Env Γ} {γ' : Env Γ'} {s : Γ ⊢ σ [→] τ} {t t' v u R S T}
+              {D₁ : γ , s ⇓ clo {Γ'} γ' t' [ R ]} {D₂ : γ , t ⇓ v [ S ]} {D₃ : γ' · v , t' ⇓ u [ T ]} →
+              Path D₂ → Path (⇓-app D₁ D₂ D₃)
+    app₃    : ∀ {Γ Γ' σ τ} {γ : Env Γ} {γ' : Env Γ'} {s : Γ ⊢ σ [→] τ} {t t' v u R S T}
+              {D₁ : γ , s ⇓ clo {Γ'} γ' t' [ R ]} {D₂ : γ , t ⇓ v [ S ]} {D₃ : γ' · v , t' ⇓ u [ T ]} →
+              Path D₃ → Path (⇓-app D₁ D₂ D₃)
+    bop     : ∀ {Γ is o'} {γ : Env Γ} {ω : op is o'} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+              {D : γ , Ms ⇓s vs [ R ]} →
+              PathS D → Path (⇓-bop {ω = ω} D)
+    brel    : ∀ {Γ is} {γ : Env Γ} {ω : rel is} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+              {D : γ , Ms ⇓s vs [ R ]} →
+              PathS D → Path (⇓-brel {ω = ω} D)
+    roll    : ∀ {Γ} {τ : type 1} {γ : Env Γ} {t : Γ ⊢ τ [ μ τ ]} {v : Val (τ [ μ τ ])}
+              {R : width-env γ ⇒ width v} {D : γ , t ⇓ v [ R ]} →
+              Path D → Path (⇓-roll {τ = τ} D)
+    fold₁   : ∀ {Γ} {τ : type 1} {σ : type 0} {γ : Env Γ} {s : Γ ▸ τ [ σ ] ⊢ σ} {t : Γ ⊢ μ τ}
+              {v u R R'} {D₁ : γ , t ⇓ v [ R ]} {D₂ : Map γ {τ} {σ} s (var zero) v R u R'} →
+              Path D₁ → Path (⇓-fold D₁ D₂)
+    fold₂   : ∀ {Γ} {τ : type 1} {σ : type 0} {γ : Env Γ} {s : Γ ▸ τ [ σ ] ⊢ σ} {t : Γ ⊢ μ τ}
+              {v u R R'} {D₁ : γ , t ⇓ v [ R ]} {D₂ : Map γ {τ} {σ} s (var zero) v R u R'} →
+              PathM D₂ → Path (⇓-fold D₁ D₂)
+
+  data PathS : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs}
+               {R : width-env γ ⇒ bases-width is} → γ , Ms ⇓s vs [ R ] → Set ℓ where
+    ε  : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+         {D : γ , Ms ⇓s vs [ R ]} → PathS D
+    hd : ∀ {Γ i is} {γ : Env Γ} {v vs R Rs} {M : Γ ⊢ base i} {Ms : Every (λ s → Γ ⊢ base s) is}
+         {D₁ : γ , M ⇓ const v [ R ]} {D₂ : γ , Ms ⇓s vs [ Rs ]} →
+         Path D₁ → PathS (D₁ ∷ D₂)
+    tl : ∀ {Γ i is} {γ : Env Γ} {v vs R Rs} {M : Γ ⊢ base i} {Ms : Every (λ s → Γ ⊢ base s) is}
+         {D₁ : γ , M ⇓ const v [ R ]} {D₂ : γ , Ms ⇓s vs [ Rs ]} →
+         PathS D₂ → PathS (D₁ ∷ D₂)
+
+  data PathM : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+               {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R} {v' : Val (σ' [ σr ])} {R'} →
+               Map γ {τ₀} {σr} s σ' v R v' R' → Set ℓ where
+    ε       : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+              {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+              {D : Map γ s σ' v R v' R'} → PathM D
+    m-rec₁  : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {w : Val (τ₀ [ μ τ₀ ])} {R : width-env γ ⇒ width w}
+              {w' : Val (τ₀ [ σr ])} {R' : width-env γ ⇒ width w'}
+              {u : Val σr} {S : width-env (γ · w') ⇒ width u}
+              {D₁ : Map γ s τ₀ w R w' R'} {D₂ : γ · w' , s ⇓ u [ S ]} →
+              PathM D₁ → PathM (m-rec D₁ D₂)
+    m-rec₂  : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {w : Val (τ₀ [ μ τ₀ ])} {R : width-env γ ⇒ width w}
+              {w' : Val (τ₀ [ σr ])} {R' : width-env γ ⇒ width w'}
+              {u : Val σr} {S : width-env (γ · w') ⇒ width u}
+              {D₁ : Map γ s τ₀ w R w' R'} {D₂ : γ · w' , s ⇓ u [ S ]} →
+              Path D₂ → PathM (m-rec D₁ D₂)
+    m-inl   : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {σ₁ σ₂ : type 1} {v : Val (σ₁ [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+              {v' : Val (σ₁ [ σr ])} {R' : width-env γ ⇒ width v'}
+              {D : Map γ s σ₁ v R v' R'} →
+              PathM D → PathM (m-inl {σ₂ = σ₂} D)
+    m-inr   : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {σ₁ σ₂ : type 1} {v : Val (σ₂ [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+              {v' : Val (σ₂ [ σr ])} {R' : width-env γ ⇒ width v'}
+              {D : Map γ s σ₂ v R v' R'} →
+              PathM D → PathM (m-inr {σ₁ = σ₁} D)
+    m-pair₁ : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {σ₁ σ₂ : type 1} {v : Val (σ₁ [ μ τ₀ ])} {u : Val (σ₂ [ μ τ₀ ])}
+              {R : width-env γ ⇒ width (pair v u)}
+              {v' : Val (σ₁ [ σr ])} {S : width-env γ ⇒ width v'}
+              {u' : Val (σ₂ [ σr ])} {T : width-env γ ⇒ width u'}
+              {D₁ : Map γ s σ₁ v (p₁ ∘ R) v' S} {D₂ : Map γ s σ₂ u (p₂ ∘ R) u' T} →
+              PathM D₁ → PathM (m-pair D₁ D₂)
+    m-pair₂ : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {σ₁ σ₂ : type 1} {v : Val (σ₁ [ μ τ₀ ])} {u : Val (σ₂ [ μ τ₀ ])}
+              {R : width-env γ ⇒ width (pair v u)}
+              {v' : Val (σ₁ [ σr ])} {S : width-env γ ⇒ width v'}
+              {u' : Val (σ₂ [ σr ])} {T : width-env γ ⇒ width u'}
+              {D₁ : Map γ s σ₁ v (p₁ ∘ R) v' S} {D₂ : Map γ s σ₂ u (p₂ ∘ R) u' T} →
+              PathM D₂ → PathM (m-pair D₁ D₂)
+    m-mu    : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {τ' : type 2} {w : Val (unfold₁ τ' [ μ τ₀ ])} {R : width-env γ ⇒ width w}
+              {w' : Val (unfold₁ τ' [ σr ])} {R' : width-env γ ⇒ width w'}
+              {D : Map γ s (unfold₁ τ') w R w' R'} →
+              PathM D → PathM (m-mu {τ' = τ'} D)
+
+-- The width of the vertex a path addresses: the width of the value of the subderivation there.
+mutual
+  width-at : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Path D → ℕ
+  width-at (ε {v = v})  = width v
+  width-at (inl p)      = width-at p
+  width-at (inr p)      = width-at p
+  width-at (case-l₁ p)  = width-at p
+  width-at (case-l₂ p)  = width-at p
+  width-at (case-r₁ p)  = width-at p
+  width-at (case-r₂ p)  = width-at p
+  width-at (pair₁ p)    = width-at p
+  width-at (pair₂ p)    = width-at p
+  width-at (fst p)      = width-at p
+  width-at (snd p)      = width-at p
+  width-at (app₁ p)     = width-at p
+  width-at (app₂ p)     = width-at p
+  width-at (app₃ p)     = width-at p
+  width-at (bop p)      = width-at-s p
+  width-at (brel p)     = width-at-s p
+  width-at (roll p)     = width-at p
+  width-at (fold₁ p)    = width-at p
+  width-at (fold₂ p)    = width-at-m p
+
+  width-at-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+               {D : γ , Ms ⇓s vs [ R ]} → PathS D → ℕ
+  width-at-s (ε {is = is}) = bases-width is
+  width-at-s (hd p)        = width-at p
+  width-at-s (tl p)        = width-at-s p
+
+  width-at-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+               {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+               {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+               {D : Map γ s σ' v R v' R'} → PathM D → ℕ
+  width-at-m (ε {v' = v'}) = width v'
+  width-at-m (m-rec₁ p)    = width-at-m p
+  width-at-m (m-rec₂ p)    = width-at p
+  width-at-m (m-inl p)     = width-at-m p
+  width-at-m (m-inr p)     = width-at-m p
+  width-at-m (m-pair₁ p)   = width-at-m p
+  width-at-m (m-pair₂ p)   = width-at-m p
+  width-at-m (m-mu p)      = width-at-m p
+
+-- All paths of a derivation, root first, premises in evaluation order. Fixes the canonical order in
+-- which sets of vertices are enumerated and hidden.
+mutual
+  paths : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → List (Path D)
+  paths D = ε ∷ interior D
+
+  paths-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+            (D : γ , Ms ⇓s vs [ R ]) → List (PathS D)
+  paths-s D = ε ∷ interior-s D
+
+  paths-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+            {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+            (D : Map γ s σ' v R v' R') → List (PathM D)
+  paths-m D = ε ∷ interior-m D
+
+  interior : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → List (Path D)
+  interior (⇓-var x)        = []
+  interior ⇓-unit           = []
+  interior (⇓-inl D)        = map inl (paths D)
+  interior (⇓-inr D)        = map inr (paths D)
+  interior (⇓-case-l D₁ D₂) = map case-l₁ (paths D₁) ++ map case-l₂ (paths D₂)
+  interior (⇓-case-r D₁ D₂) = map case-r₁ (paths D₁) ++ map case-r₂ (paths D₂)
+  interior (⇓-pair D₁ D₂)   = map pair₁ (paths D₁) ++ map pair₂ (paths D₂)
+  interior (⇓-fst D)        = map fst (paths D)
+  interior (⇓-snd D)        = map snd (paths D)
+  interior ⇓-lam            = []
+  interior (⇓-app D₁ D₂ D₃) = map app₁ (paths D₁) ++ map app₂ (paths D₂) ++ map app₃ (paths D₃)
+  interior (⇓-bop D)       = map bop (paths-s D)
+  interior (⇓-brel D)      = map brel (paths-s D)
+  interior (⇓-roll D)       = map roll (paths D)
+  interior (⇓-fold D₁ D₂)   = map fold₁ (paths D₁) ++ map fold₂ (paths-m D₂)
+
+  interior-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+               (D : γ , Ms ⇓s vs [ R ]) → List (PathS D)
+  interior-s []       = []
+  interior-s (D₁ ∷ D₂) = map hd (paths D₁) ++ map tl (paths-s D₂)
+
+  interior-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+               {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+               {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+               (D : Map γ s σ' v R v' R') → List (PathM D)
+  interior-m (m-rec D₁ D₂)   = map m-rec₁ (paths-m D₁) ++ map m-rec₂ (paths D₂)
+  interior-m m-unit           = []
+  interior-m m-base           = []
+  interior-m m-arrow          = []
+  interior-m (m-inl D)       = map m-inl (paths-m D)
+  interior-m (m-inr D)       = map m-inr (paths-m D)
+  interior-m (m-pair D₁ D₂)  = map m-pair₁ (paths-m D₁) ++ map m-pair₂ (paths-m D₂)
+  interior-m (m-mu D)        = map m-mu (paths-m D)
+
+-- Whether the value at a path is first-order, by the type of the subderivation's conclusion.
+-- Operand-list vertices hold tuples of constants, so they are always first-order.
+mutual
+  fo-at : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Path D → Bool
+  fo-at (ε {τ = τ}) = ⌊ first-order? τ ⌋
+  fo-at (inl p)     = fo-at p
+  fo-at (inr p)     = fo-at p
+  fo-at (case-l₁ p) = fo-at p
+  fo-at (case-l₂ p) = fo-at p
+  fo-at (case-r₁ p) = fo-at p
+  fo-at (case-r₂ p) = fo-at p
+  fo-at (pair₁ p)   = fo-at p
+  fo-at (pair₂ p)   = fo-at p
+  fo-at (fst p)     = fo-at p
+  fo-at (snd p)     = fo-at p
+  fo-at (app₁ p)    = fo-at p
+  fo-at (app₂ p)    = fo-at p
+  fo-at (app₃ p)    = fo-at p
+  fo-at (bop p)     = fo-at-s p
+  fo-at (brel p)    = fo-at-s p
+  fo-at (roll p)    = fo-at p
+  fo-at (fold₁ p)   = fo-at p
+  fo-at (fold₂ p)   = fo-at-m p
+
+  fo-at-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+            {D : γ , Ms ⇓s vs [ R ]} → PathS D → Bool
+  fo-at-s _ = Bool.true
+
+  fo-at-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+            {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+            {D : Map γ s σ' v R v' R'} → PathM D → Bool
+  fo-at-m (ε {σr = σr} {σ' = σ'}) = ⌊ first-order? (σ' [ σr ]) ⌋
+  fo-at-m (m-rec₁ p)  = fo-at-m p
+  fo-at-m (m-rec₂ p)  = fo-at p
+  fo-at-m (m-inl p)   = fo-at-m p
+  fo-at-m (m-inr p)   = fo-at-m p
+  fo-at-m (m-pair₁ p) = fo-at-m p
+  fo-at-m (m-pair₂ p) = fo-at-m p
+  fo-at-m (m-mu p)    = fo-at-m p
+
+-- Whether a path is the root.
+is-ε : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Path D → Bool
+is-ε ε = Bool.true
+is-ε _ = Bool.false
+
+-- The non-empty paths whose values are first-order: the vertices an interaction may reveal.
+FO : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → List (Path D)
+FO D = filterᵇ (λ p → not (is-ε p) ∧ fo-at p) (paths D)
+
+-- Equality of paths of the same derivation.
+mutual
+  eq-path : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Path D → Path D → Bool
+  eq-path ε ε = Bool.true
+  eq-path (inl p)     (inl q)     = eq-path p q
+  eq-path (inr p)     (inr q)     = eq-path p q
+  eq-path (case-l₁ p) (case-l₁ q) = eq-path p q
+  eq-path (case-l₂ p) (case-l₂ q) = eq-path p q
+  eq-path (case-r₁ p) (case-r₁ q) = eq-path p q
+  eq-path (case-r₂ p) (case-r₂ q) = eq-path p q
+  eq-path (pair₁ p)   (pair₁ q)   = eq-path p q
+  eq-path (pair₂ p)   (pair₂ q)   = eq-path p q
+  eq-path (fst p)     (fst q)     = eq-path p q
+  eq-path (snd p)     (snd q)     = eq-path p q
+  eq-path (app₁ p)    (app₁ q)    = eq-path p q
+  eq-path (app₂ p)    (app₂ q)    = eq-path p q
+  eq-path (app₃ p)    (app₃ q)    = eq-path p q
+  eq-path (bop p)     (bop q)     = eq-path-s p q
+  eq-path (brel p)    (brel q)    = eq-path-s p q
+  eq-path (roll p)    (roll q)    = eq-path p q
+  eq-path (fold₁ p)   (fold₁ q)   = eq-path p q
+  eq-path (fold₂ p)   (fold₂ q)   = eq-path-m p q
+  eq-path _ _ = Bool.false
+
+  eq-path-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+              {D : γ , Ms ⇓s vs [ R ]} → PathS D → PathS D → Bool
+  eq-path-s ε ε = Bool.true
+  eq-path-s (hd p) (hd q) = eq-path p q
+  eq-path-s (tl p) (tl q) = eq-path-s p q
+  eq-path-s _ _ = Bool.false
+
+  eq-path-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+              {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+              {D : Map γ s σ' v R v' R'} → PathM D → PathM D → Bool
+  eq-path-m ε ε = Bool.true
+  eq-path-m (m-rec₁ p)  (m-rec₁ q)  = eq-path-m p q
+  eq-path-m (m-rec₂ p)  (m-rec₂ q)  = eq-path p q
+  eq-path-m (m-inl p)   (m-inl q)   = eq-path-m p q
+  eq-path-m (m-inr p)   (m-inr q)   = eq-path-m p q
+  eq-path-m (m-pair₁ p) (m-pair₁ q) = eq-path-m p q
+  eq-path-m (m-pair₂ p) (m-pair₂ q) = eq-path-m p q
+  eq-path-m (m-mu p)    (m-mu q)    = eq-path-m p q
+  eq-path-m _ _ = Bool.false
+
+mutual
+  eq-path-refl : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                 (p : Path D) → eq-path p p ≡ Bool.true
+  eq-path-refl ε           = ≡-refl
+  eq-path-refl (inl p)     = eq-path-refl p
+  eq-path-refl (inr p)     = eq-path-refl p
+  eq-path-refl (case-l₁ p) = eq-path-refl p
+  eq-path-refl (case-l₂ p) = eq-path-refl p
+  eq-path-refl (case-r₁ p) = eq-path-refl p
+  eq-path-refl (case-r₂ p) = eq-path-refl p
+  eq-path-refl (pair₁ p)   = eq-path-refl p
+  eq-path-refl (pair₂ p)   = eq-path-refl p
+  eq-path-refl (fst p)     = eq-path-refl p
+  eq-path-refl (snd p)     = eq-path-refl p
+  eq-path-refl (app₁ p)    = eq-path-refl p
+  eq-path-refl (app₂ p)    = eq-path-refl p
+  eq-path-refl (app₃ p)    = eq-path-refl p
+  eq-path-refl (bop p)     = eq-path-s-refl p
+  eq-path-refl (brel p)    = eq-path-s-refl p
+  eq-path-refl (roll p)    = eq-path-refl p
+  eq-path-refl (fold₁ p)   = eq-path-refl p
+  eq-path-refl (fold₂ p)   = eq-path-m-refl p
+
+  eq-path-s-refl : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                   {D : γ , Ms ⇓s vs [ R ]} (p : PathS D) → eq-path-s p p ≡ Bool.true
+  eq-path-s-refl ε      = ≡-refl
+  eq-path-s-refl (hd p) = eq-path-refl p
+  eq-path-s-refl (tl p) = eq-path-s-refl p
+
+  eq-path-m-refl : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                   {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                   {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                   {D : Map γ s σ' v R v' R'} (p : PathM D) → eq-path-m p p ≡ Bool.true
+  eq-path-m-refl ε           = ≡-refl
+  eq-path-m-refl (m-rec₁ p)  = eq-path-m-refl p
+  eq-path-m-refl (m-rec₂ p)  = eq-path-refl p
+  eq-path-m-refl (m-inl p)   = eq-path-m-refl p
+  eq-path-m-refl (m-inr p)   = eq-path-m-refl p
+  eq-path-m-refl (m-pair₁ p) = eq-path-m-refl p
+  eq-path-m-refl (m-pair₂ p) = eq-path-m-refl p
+  eq-path-m-refl (m-mu p)    = eq-path-m-refl p
+
+mutual
+  eq-path-≡ : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+              {p q : Path D} → eq-path p q ≡ Bool.true → p ≡ q
+  eq-path-≡ {p = ε}         {ε}         h = ≡-refl
+  eq-path-≡ {p = inl p}     {inl q}     h = ≡-cong inl (eq-path-≡ h)
+  eq-path-≡ {p = inr p}     {inr q}     h = ≡-cong inr (eq-path-≡ h)
+  eq-path-≡ {p = case-l₁ p} {case-l₁ q} h = ≡-cong case-l₁ (eq-path-≡ h)
+  eq-path-≡ {p = case-l₂ p} {case-l₂ q} h = ≡-cong case-l₂ (eq-path-≡ h)
+  eq-path-≡ {p = case-r₁ p} {case-r₁ q} h = ≡-cong case-r₁ (eq-path-≡ h)
+  eq-path-≡ {p = case-r₂ p} {case-r₂ q} h = ≡-cong case-r₂ (eq-path-≡ h)
+  eq-path-≡ {p = pair₁ p}   {pair₁ q}   h = ≡-cong pair₁ (eq-path-≡ h)
+  eq-path-≡ {p = pair₂ p}   {pair₂ q}   h = ≡-cong pair₂ (eq-path-≡ h)
+  eq-path-≡ {p = fst p}     {fst q}     h = ≡-cong fst (eq-path-≡ h)
+  eq-path-≡ {p = snd p}     {snd q}     h = ≡-cong snd (eq-path-≡ h)
+  eq-path-≡ {p = app₁ p}    {app₁ q}    h = ≡-cong app₁ (eq-path-≡ h)
+  eq-path-≡ {p = app₂ p}    {app₂ q}    h = ≡-cong app₂ (eq-path-≡ h)
+  eq-path-≡ {p = app₃ p}    {app₃ q}    h = ≡-cong app₃ (eq-path-≡ h)
+  eq-path-≡ {p = bop p}     {bop q}     h = ≡-cong bop (eq-path-s-≡ h)
+  eq-path-≡ {p = brel p}    {brel q}    h = ≡-cong brel (eq-path-s-≡ h)
+  eq-path-≡ {p = roll p}    {roll q}    h = ≡-cong roll (eq-path-≡ h)
+  eq-path-≡ {p = fold₁ p}   {fold₁ q}   h = ≡-cong fold₁ (eq-path-≡ h)
+  eq-path-≡ {p = fold₂ p}   {fold₂ q}   h = ≡-cong fold₂ (eq-path-m-≡ h)
+  eq-path-≡ {p = ε} {inl _} ()
+  eq-path-≡ {p = inl _} {ε} ()
+  eq-path-≡ {p = ε} {inr _} ()
+  eq-path-≡ {p = inr _} {ε} ()
+  eq-path-≡ {p = ε} {case-l₁ _} ()
+  eq-path-≡ {p = case-l₁ _} {ε} ()
+  eq-path-≡ {p = ε} {case-l₂ _} ()
+  eq-path-≡ {p = case-l₂ _} {ε} ()
+  eq-path-≡ {p = ε} {case-r₁ _} ()
+  eq-path-≡ {p = case-r₁ _} {ε} ()
+  eq-path-≡ {p = ε} {case-r₂ _} ()
+  eq-path-≡ {p = case-r₂ _} {ε} ()
+  eq-path-≡ {p = ε} {pair₁ _} ()
+  eq-path-≡ {p = pair₁ _} {ε} ()
+  eq-path-≡ {p = ε} {pair₂ _} ()
+  eq-path-≡ {p = pair₂ _} {ε} ()
+  eq-path-≡ {p = ε} {fst _} ()
+  eq-path-≡ {p = fst _} {ε} ()
+  eq-path-≡ {p = ε} {snd _} ()
+  eq-path-≡ {p = snd _} {ε} ()
+  eq-path-≡ {p = ε} {app₁ _} ()
+  eq-path-≡ {p = app₁ _} {ε} ()
+  eq-path-≡ {p = ε} {app₂ _} ()
+  eq-path-≡ {p = app₂ _} {ε} ()
+  eq-path-≡ {p = ε} {app₃ _} ()
+  eq-path-≡ {p = app₃ _} {ε} ()
+  eq-path-≡ {p = ε} {bop _} ()
+  eq-path-≡ {p = bop _} {ε} ()
+  eq-path-≡ {p = ε} {brel _} ()
+  eq-path-≡ {p = brel _} {ε} ()
+  eq-path-≡ {p = ε} {roll _} ()
+  eq-path-≡ {p = roll _} {ε} ()
+  eq-path-≡ {p = ε} {fold₁ _} ()
+  eq-path-≡ {p = fold₁ _} {ε} ()
+  eq-path-≡ {p = ε} {fold₂ _} ()
+  eq-path-≡ {p = fold₂ _} {ε} ()
+  eq-path-≡ {p = case-l₁ _} {case-l₂ _} ()
+  eq-path-≡ {p = case-l₂ _} {case-l₁ _} ()
+  eq-path-≡ {p = case-r₁ _} {case-r₂ _} ()
+  eq-path-≡ {p = case-r₂ _} {case-r₁ _} ()
+  eq-path-≡ {p = pair₁ _} {pair₂ _} ()
+  eq-path-≡ {p = pair₂ _} {pair₁ _} ()
+  eq-path-≡ {p = app₁ _} {app₂ _} ()
+  eq-path-≡ {p = app₂ _} {app₁ _} ()
+  eq-path-≡ {p = app₁ _} {app₃ _} ()
+  eq-path-≡ {p = app₃ _} {app₁ _} ()
+  eq-path-≡ {p = app₂ _} {app₃ _} ()
+  eq-path-≡ {p = app₃ _} {app₂ _} ()
+  eq-path-≡ {p = fold₁ _} {fold₂ _} ()
+  eq-path-≡ {p = fold₂ _} {fold₁ _} ()
+
+  eq-path-s-≡ : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                {D : γ , Ms ⇓s vs [ R ]} {p q : PathS D} → eq-path-s p q ≡ Bool.true → p ≡ q
+  eq-path-s-≡ {p = ε}    {ε}    h = ≡-refl
+  eq-path-s-≡ {p = hd p} {hd q} h = ≡-cong hd (eq-path-≡ h)
+  eq-path-s-≡ {p = tl p} {tl q} h = ≡-cong tl (eq-path-s-≡ h)
+  eq-path-s-≡ {p = ε} {hd _} ()
+  eq-path-s-≡ {p = hd _} {ε} ()
+  eq-path-s-≡ {p = ε} {tl _} ()
+  eq-path-s-≡ {p = tl _} {ε} ()
+  eq-path-s-≡ {p = hd _} {tl _} ()
+  eq-path-s-≡ {p = tl _} {hd _} ()
+
+  eq-path-m-≡ : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                {D : Map γ s σ' v R v' R'} {p q : PathM D} → eq-path-m p q ≡ Bool.true → p ≡ q
+  eq-path-m-≡ {p = ε}         {ε}         h = ≡-refl
+  eq-path-m-≡ {p = m-rec₁ p}  {m-rec₁ q}  h = ≡-cong m-rec₁ (eq-path-m-≡ h)
+  eq-path-m-≡ {p = m-rec₂ p}  {m-rec₂ q}  h = ≡-cong m-rec₂ (eq-path-≡ h)
+  eq-path-m-≡ {p = m-inl p}   {m-inl q}   h = ≡-cong m-inl (eq-path-m-≡ h)
+  eq-path-m-≡ {p = m-inr p}   {m-inr q}   h = ≡-cong m-inr (eq-path-m-≡ h)
+  eq-path-m-≡ {p = m-pair₁ p} {m-pair₁ q} h = ≡-cong m-pair₁ (eq-path-m-≡ h)
+  eq-path-m-≡ {p = m-pair₂ p} {m-pair₂ q} h = ≡-cong m-pair₂ (eq-path-m-≡ h)
+  eq-path-m-≡ {p = m-mu p}    {m-mu q}    h = ≡-cong m-mu (eq-path-m-≡ h)
+  eq-path-m-≡ {p = ε} {m-rec₁ _} ()
+  eq-path-m-≡ {p = m-rec₁ _} {ε} ()
+  eq-path-m-≡ {p = ε} {m-rec₂ _} ()
+  eq-path-m-≡ {p = m-rec₂ _} {ε} ()
+  eq-path-m-≡ {p = ε} {m-inl _} ()
+  eq-path-m-≡ {p = m-inl _} {ε} ()
+  eq-path-m-≡ {p = ε} {m-inr _} ()
+  eq-path-m-≡ {p = m-inr _} {ε} ()
+  eq-path-m-≡ {p = ε} {m-pair₁ _} ()
+  eq-path-m-≡ {p = m-pair₁ _} {ε} ()
+  eq-path-m-≡ {p = ε} {m-pair₂ _} ()
+  eq-path-m-≡ {p = m-pair₂ _} {ε} ()
+  eq-path-m-≡ {p = ε} {m-mu _} ()
+  eq-path-m-≡ {p = m-mu _} {ε} ()
+  eq-path-m-≡ {p = m-rec₁ _} {m-rec₂ _} ()
+  eq-path-m-≡ {p = m-rec₂ _} {m-rec₁ _} ()
+  eq-path-m-≡ {p = m-pair₁ _} {m-pair₂ _} ()
+  eq-path-m-≡ {p = m-pair₂ _} {m-pair₁ _} ()
+
+-- A failing equality test also fails in the flipped order: a successful flipped test would make
+-- the paths equal, contradicting reflexivity.
+eq-path-false-sym : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]}
+                    {p q : Path D} → eq-path p q ≡ Bool.false → eq-path q p ≡ Bool.false
+eq-path-false-sym {p = p} {q} h with eq-path q p in e
+... | Bool.false = ≡-refl
+... | Bool.true with eq-path-≡ {p = q} {q = p} e
+...   | ≡-refl with ≡-trans (≡-sym h) (eq-path-refl p)
+...     | ()
+
+private
+  cross-blocks : {A B C : Set ℓ} {S : C → C → Set} (f : A → C) (g : B → C) →
+                 (∀ p q → S (f p) (g q)) → (xs : List A) (ys : List B) →
+                 All (λ x → All (S x) (map g ys)) (map f xs)
+  cross-blocks f g h xs ys =
+    AllP.map⁺ (universal (λ p → AllP.map⁺ (universal (λ q → h p q) ys)) xs)
+
+-- Distinct positions have refuting equality tests: the root differs from every interior path and
+-- premise blocks differ by constructor, so distinctness reduces to the premises.
+mutual
+  paths-distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+                   AllPairs (λ q q' → eq-path q q' ≡ Bool.false) (paths D)
+  paths-distinct D = root-distinct D ∷ interior-distinct D
+
+  paths-s-distinct : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                     (D : γ , Ms ⇓s vs [ R ]) →
+                     AllPairs (λ q q' → eq-path-s q q' ≡ Bool.false) (paths-s D)
+  paths-s-distinct D = root-s-distinct D ∷ interior-s-distinct D
+
+  paths-m-distinct : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                     {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                     {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                     (D : Map γ s σ' v R v' R') →
+                     AllPairs (λ q q' → eq-path-m q q' ≡ Bool.false) (paths-m D)
+  paths-m-distinct D = root-m-distinct D ∷ interior-m-distinct D
+
+  root-distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+                  All (λ q → eq-path ε q ≡ Bool.false) (interior D)
+  root-distinct (⇓-var x)        = []
+  root-distinct ⇓-unit           = []
+  root-distinct ⇓-lam            = []
+  root-distinct (⇓-inl D)        = AllP.map⁺ (universal (λ q → ≡-refl) (paths D))
+  root-distinct (⇓-inr D)        = AllP.map⁺ (universal (λ q → ≡-refl) (paths D))
+  root-distinct (⇓-fst D)        = AllP.map⁺ (universal (λ q → ≡-refl) (paths D))
+  root-distinct (⇓-snd D)        = AllP.map⁺ (universal (λ q → ≡-refl) (paths D))
+  root-distinct (⇓-roll D)       = AllP.map⁺ (universal (λ q → ≡-refl) (paths D))
+  root-distinct (⇓-bop D)        = AllP.map⁺ (universal (λ q → ≡-refl) (paths-s D))
+  root-distinct (⇓-brel D)       = AllP.map⁺ (universal (λ q → ≡-refl) (paths-s D))
+  root-distinct (⇓-case-l D₁ D₂) =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₁)))
+             (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₂)))
+  root-distinct (⇓-case-r D₁ D₂) =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₁)))
+             (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₂)))
+  root-distinct (⇓-pair D₁ D₂)   =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₁)))
+             (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₂)))
+  root-distinct (⇓-fold D₁ D₂)   =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₁)))
+             (AllP.map⁺ (universal (λ q → ≡-refl) (paths-m D₂)))
+  root-distinct (⇓-app D₁ D₂ D₃) =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₁)))
+             (AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₂)))
+                       (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₃))))
+
+  root-s-distinct : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                    (D : γ , Ms ⇓s vs [ R ]) →
+                    All (λ q → eq-path-s ε q ≡ Bool.false) (interior-s D)
+  root-s-distinct []        = []
+  root-s-distinct (D₁ ∷ D₂) =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₁)))
+             (AllP.map⁺ (universal (λ q → ≡-refl) (paths-s D₂)))
+
+  root-m-distinct : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                    {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                    {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                    (D : Map γ s σ' v R v' R') →
+                    All (λ q → eq-path-m ε q ≡ Bool.false) (interior-m D)
+  root-m-distinct (m-rec D₁ D₂)  =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths-m D₁)))
+             (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₂)))
+  root-m-distinct m-unit         = []
+  root-m-distinct m-base         = []
+  root-m-distinct m-arrow        = []
+  root-m-distinct (m-inl D)      = AllP.map⁺ (universal (λ q → ≡-refl) (paths-m D))
+  root-m-distinct (m-inr D)      = AllP.map⁺ (universal (λ q → ≡-refl) (paths-m D))
+  root-m-distinct (m-mu D)       = AllP.map⁺ (universal (λ q → ≡-refl) (paths-m D))
+  root-m-distinct (m-pair D₁ D₂) =
+    AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths-m D₁)))
+             (AllP.map⁺ (universal (λ q → ≡-refl) (paths-m D₂)))
+
+  interior-distinct : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) →
+                      AllPairs (λ q q' → eq-path q q' ≡ Bool.false) (interior D)
+  interior-distinct (⇓-var x)        = []
+  interior-distinct ⇓-unit           = []
+  interior-distinct ⇓-lam            = []
+  interior-distinct (⇓-inl D)        = AllPairsP.map⁺ (paths-distinct D)
+  interior-distinct (⇓-inr D)        = AllPairsP.map⁺ (paths-distinct D)
+  interior-distinct (⇓-fst D)        = AllPairsP.map⁺ (paths-distinct D)
+  interior-distinct (⇓-snd D)        = AllPairsP.map⁺ (paths-distinct D)
+  interior-distinct (⇓-roll D)       = AllPairsP.map⁺ (paths-distinct D)
+  interior-distinct (⇓-bop D)        = AllPairsP.map⁺ (paths-s-distinct D)
+  interior-distinct (⇓-brel D)       = AllPairsP.map⁺ (paths-s-distinct D)
+  interior-distinct (⇓-case-l D₁ D₂) =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-distinct D₁)) (AllPairsP.map⁺ (paths-distinct D₂))
+                  (cross-blocks case-l₁ case-l₂ (λ p q → ≡-refl) (paths D₁) (paths D₂))
+  interior-distinct (⇓-case-r D₁ D₂) =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-distinct D₁)) (AllPairsP.map⁺ (paths-distinct D₂))
+                  (cross-blocks case-r₁ case-r₂ (λ p q → ≡-refl) (paths D₁) (paths D₂))
+  interior-distinct (⇓-pair D₁ D₂)   =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-distinct D₁)) (AllPairsP.map⁺ (paths-distinct D₂))
+                  (cross-blocks pair₁ pair₂ (λ p q → ≡-refl) (paths D₁) (paths D₂))
+  interior-distinct (⇓-fold D₁ D₂)   =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-distinct D₁)) (AllPairsP.map⁺ (paths-m-distinct D₂))
+                  (cross-blocks fold₁ fold₂ (λ p q → ≡-refl) (paths D₁) (paths-m D₂))
+  interior-distinct (⇓-app D₁ D₂ D₃) =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-distinct D₁))
+                  (AllPairsP.++⁺ (AllPairsP.map⁺ (paths-distinct D₂))
+                                 (AllPairsP.map⁺ (paths-distinct D₃))
+                                 (cross-blocks app₂ app₃ (λ p q → ≡-refl) (paths D₂) (paths D₃)))
+                  (AllP.map⁺ (universal
+                    (λ p → AllP.++⁺ (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₂)))
+                                    (AllP.map⁺ (universal (λ q → ≡-refl) (paths D₃))))
+                    (paths D₁)))
+
+  interior-s-distinct : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+                        (D : γ , Ms ⇓s vs [ R ]) →
+                        AllPairs (λ q q' → eq-path-s q q' ≡ Bool.false) (interior-s D)
+  interior-s-distinct []        = []
+  interior-s-distinct (D₁ ∷ D₂) =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-distinct D₁)) (AllPairsP.map⁺ (paths-s-distinct D₂))
+                  (cross-blocks hd tl (λ p q → ≡-refl) (paths D₁) (paths-s D₂))
+
+  interior-m-distinct : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+                        {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+                        {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+                        (D : Map γ s σ' v R v' R') →
+                        AllPairs (λ q q' → eq-path-m q q' ≡ Bool.false) (interior-m D)
+  interior-m-distinct (m-rec D₁ D₂)  =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-m-distinct D₁)) (AllPairsP.map⁺ (paths-distinct D₂))
+                  (cross-blocks m-rec₁ m-rec₂ (λ p q → ≡-refl) (paths-m D₁) (paths D₂))
+  interior-m-distinct m-unit         = []
+  interior-m-distinct m-base         = []
+  interior-m-distinct m-arrow        = []
+  interior-m-distinct (m-inl D)      = AllPairsP.map⁺ (paths-m-distinct D)
+  interior-m-distinct (m-inr D)      = AllPairsP.map⁺ (paths-m-distinct D)
+  interior-m-distinct (m-mu D)       = AllPairsP.map⁺ (paths-m-distinct D)
+  interior-m-distinct (m-pair D₁ D₂) =
+    AllPairsP.++⁺ (AllPairsP.map⁺ (paths-m-distinct D₁)) (AllPairsP.map⁺ (paths-m-distinct D₂))
+                  (cross-blocks m-pair₁ m-pair₂ (λ p q → ≡-refl) (paths-m D₁) (paths-m D₂))
+
+-- Membership of a path in a list of paths of the same derivation.
+member : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} →
+         Path D → List (Path D) → Bool
+member p = any (eq-path p)
+
+-- Completion rank: paths in a premise complete before paths in a later premise, and every path of
+-- a derivation completes before the derivation itself, whose rank is the sum of its premise sizes.
+-- The forward-edge lemma states that entries run strictly upward in rank, giving acyclicity.
+mutual
+  size : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → ℕ
+  size D = suc (psize D)
+
+  size-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+           (D : γ , Ms ⇓s vs [ R ]) → ℕ
+  size-s D = suc (psize-s D)
+
+  size-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+           {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+           {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+           (D : Map γ s σ' v R v' R') → ℕ
+  size-m D = suc (psize-m D)
+
+  psize : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → ℕ
+  psize (⇓-var x)        = 0
+  psize ⇓-unit           = 0
+  psize (⇓-inl D)        = size D
+  psize (⇓-inr D)        = size D
+  psize (⇓-case-l D₁ D₂) = size D₁ + size D₂
+  psize (⇓-case-r D₁ D₂) = size D₁ + size D₂
+  psize (⇓-pair D₁ D₂)   = size D₁ + size D₂
+  psize (⇓-fst D)        = size D
+  psize (⇓-snd D)        = size D
+  psize ⇓-lam            = 0
+  psize (⇓-app D₁ D₂ D₃) = size D₁ + size D₂ + size D₃
+  psize (⇓-bop D)       = size-s D
+  psize (⇓-brel D)      = size-s D
+  psize (⇓-roll D)       = size D
+  psize (⇓-fold D₁ D₂)   = size D₁ + size-m D₂
+
+  psize-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+            (D : γ , Ms ⇓s vs [ R ]) → ℕ
+  psize-s []       = 0
+  psize-s (D₁ ∷ D₂) = size D₁ + size-s D₂
+
+  psize-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+            {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+            {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+            (D : Map γ s σ' v R v' R') → ℕ
+  psize-m (m-rec D₁ D₂)  = size-m D₁ + size D₂
+  psize-m m-unit          = 0
+  psize-m m-base          = 0
+  psize-m m-arrow         = 0
+  psize-m (m-inl D)      = size-m D
+  psize-m (m-inr D)      = size-m D
+  psize-m (m-pair D₁ D₂) = size-m D₁ + size-m D₂
+  psize-m (m-mu D)       = size-m D
+
+mutual
+  rank : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Path D → ℕ
+  rank (ε {D = D})            = psize D
+  rank (inl p)                = rank p
+  rank (inr p)                = rank p
+  rank (case-l₁ p)            = rank p
+  rank (case-l₂ {D₁ = D₁} p)  = size D₁ + rank p
+  rank (case-r₁ p)            = rank p
+  rank (case-r₂ {D₁ = D₁} p)  = size D₁ + rank p
+  rank (pair₁ p)              = rank p
+  rank (pair₂ {D₁ = D₁} p)    = size D₁ + rank p
+  rank (fst p)                = rank p
+  rank (snd p)                = rank p
+  rank (app₁ p)               = rank p
+  rank (app₂ {D₁ = D₁} p)     = size D₁ + rank p
+  rank (app₃ {D₁ = D₁} {D₂ = D₂} p) = size D₁ + size D₂ + rank p
+  rank (bop p)                = rank-s p
+  rank (brel p)               = rank-s p
+  rank (roll p)               = rank p
+  rank (fold₁ p)              = rank p
+  rank (fold₂ {D₁ = D₁} p)    = size D₁ + rank-m p
+
+  rank-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+           {D : γ , Ms ⇓s vs [ R ]} → PathS D → ℕ
+  rank-s (ε {D = D})     = psize-s D
+  rank-s (hd p)          = rank p
+  rank-s (tl {D₁ = D₁} p) = size D₁ + rank-s p
+
+  rank-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+           {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+           {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+           {D : Map γ s σ' v R v' R'} → PathM D → ℕ
+  rank-m (ε {D = D})           = psize-m D
+  rank-m (m-rec₁ p)            = rank-m p
+  rank-m (m-rec₂ {D₁ = D₁} p)  = size-m D₁ + rank p
+  rank-m (m-inl p)             = rank-m p
+  rank-m (m-inr p)             = rank-m p
+  rank-m (m-pair₁ p)           = rank-m p
+  rank-m (m-pair₂ {D₁ = D₁} p) = size-m D₁ + rank-m p
+  rank-m (m-mu p)              = rank-m p
+
+is-ε-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+         {D : γ , Ms ⇓s vs [ R ]} → PathS D → Bool
+is-ε-s ε = Bool.true
+is-ε-s _ = Bool.false
+
+is-ε-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+         {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+         {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+         {D : Map γ s σ' v R v' R'} → PathM D → Bool
+is-ε-m ε = Bool.true
+is-ε-m _ = Bool.false
diff --git a/agda/src/language-operational/render.agda b/agda/src/language-operational/render.agda
new file mode 100644
index 00000000..22bd06ab
--- /dev/null
+++ b/agda/src/language-operational/render.agda
@@ -0,0 +1,69 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (0ℓ)
+
+open import Data.List using (List; []; _∷_)
+import Data.Fin
+open import Data.Nat using (ℕ; zero; suc; _+_)
+open import Data.Product using (_,_; _×_)
+open import Data.String using (String) renaming (_++_ to _++ˢ_)
+import Data.Nat.Show as ℕ-Show
+open import prop-setoid using (Setoid)
+import two
+open import signature using (Signature)
+open import primitives using (Primitives)
+
+-- Rendering of values and dependence graphs.
+module language-operational.render
+  {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig)
+  where
+
+open Signature Sig
+open Primitives 𝒫
+open prop-setoid._⇒_ using (func)
+open import language-syntax Sig renaming (_,_ to _▸_)
+open import language-operational.evaluation Sig 𝒫
+
+-- Values as strings, given a rendering of the constants. Roll is invisible, so inductive values
+-- read as their contents; values of list type render bracketed.
+module _ (show-const : ∀ {s} → sort-val s → String) where
+
+  mutual
+    show-val : ∀ {τ} → Val τ → String
+    show-val {μ (unit [+] (_ [×] var Data.Fin.zero))} v = "[" ++ˢ show-list v ++ˢ "]"
+    show-val unit       = "()"
+    show-val (const c)  = show-const c
+    show-val (inl v)    = "inl " ++ˢ show-val v
+    show-val (inr v)    = "inr " ++ˢ show-val v
+    show-val (pair v u) = "(" ++ˢ show-val v ++ˢ ", " ++ˢ show-flat u ++ˢ ")"
+    show-val (clo _ _)  = "<closure>"
+    show-val (roll v)   = show-val v
+
+    -- Right-nested pairs render as flat tuples, reading (a, b, c) as (a, (b, c)).
+    show-flat : ∀ {τ} → Val τ → String
+    show-flat (pair v u) = show-val v ++ˢ ", " ++ˢ show-flat u
+    show-flat v          = show-val v
+
+    show-list : ∀ {σ} → Val (μ (unit [+] (σ [×] var Data.Fin.zero))) → String
+    show-list (roll (inl unit))                       = ""
+    show-list (roll (inr (pair v (roll (inl unit))))) = show-val v
+    show-list (roll (inr (pair v rest)))              = show-val v ++ˢ ", " ++ˢ show-list rest
+
+-- Rendering for dependence graphs over intermediates: one vertex per label, declared so that
+-- isolated vertices are rendered. An edge with a label aggregates a relation bigger than
+-- Fin 1 → Fin 1, drawn dotted with the relation as its label.
+showDotPlain : List String → List (ℕ × ℕ × String) → String
+showDotPlain ls es = "digraph G {\n" ++ˢ vertices 0 ls ++ˢ go es ++ˢ "}\n"
+  where
+    vertices : ℕ → List String → String
+    vertices _ []       = ""
+    vertices i (l ∷ ls) =
+      "  " ++ˢ ℕ-Show.show i ++ˢ " [label=\"" ++ˢ l ++ˢ "\"];\n" ++ˢ vertices (suc i) ls
+    edge : ℕ × ℕ × String → String
+    edge (i , j , "") = "  " ++ˢ ℕ-Show.show i ++ˢ " -> " ++ˢ ℕ-Show.show j ++ˢ ";\n"
+    edge (i , j , l)  =
+      "  " ++ˢ ℕ-Show.show i ++ˢ " -> " ++ˢ ℕ-Show.show j ++ˢ
+      " [label=\"" ++ˢ l ++ˢ "\", style=dotted];\n"
+    go : List (ℕ × ℕ × String) → String
+    go []       = ""
+    go (e ∷ es) = edge e ++ˢ go es
diff --git a/agda/src/language-operational/topological-order.agda b/agda/src/language-operational/topological-order.agda
new file mode 100644
index 00000000..cb2dea31
--- /dev/null
+++ b/agda/src/language-operational/topological-order.agda
@@ -0,0 +1,643 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Data.Empty using (⊥; ⊥-elim)
+open import Data.List using (List; []; _∷_; map; filterᵇ; foldl)
+import Data.List.Relation.Binary.Permutation.Propositional as ↭
+open ↭ using (_↭_)
+open import Data.Product using (Σ; _×_; _,_)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Data.Fin using (Fin)
+import Data.Fin as F
+open import Data.Nat using (ℕ; zero; suc; _+_; _<_; _≤_; z≤n; s≤s)
+open import Data.Nat.Properties
+  using (≤-refl; ≤-trans; ≤-reflexive; m≤m+n; +-monoʳ-<; +-suc; <-trans; <-irrefl; <-asym)
+open import every using (Every; []; _∷_)
+open import Relation.Binary.PropositionalEquality using (_≡_)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; cong to ≡-cong; cong₂ to ≡-cong₂)
+open import signature using (Signature)
+open import primitives using (Primitives)
+import Data.Bool as Bool
+import hide-algebra
+import matrix
+import two
+
+-- Every edge of a rule-built graph runs strictly forward in completion rank, so the graphs the
+-- rules produce are acyclic.
+module language-operational.topological-order {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open import language-syntax Sig renaming (_,_ to _▸_)
+open import type-substitution Sig using (unfold₁)
+open import language-operational.evaluation Sig 𝒫
+open import language-operational.path Sig 𝒫
+open import language-operational.graph Sig 𝒫
+open import language-operational.hide Sig 𝒫
+
+private
+  module M = matrix.Mat two.semiring
+
+open import categories using (Category)
+open Category M.cat using (_⇒_)
+
+-- Vertex rank: env below every path, each path above its premise offsets.
+rank-v : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Vertex D → ℕ
+rank-v env    = zero
+rank-v (at p) = suc (rank p)
+
+rank-v-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+           {D : γ , Ms ⇓s vs [ R ]} → VertexS D → ℕ
+rank-v-s env    = zero
+rank-v-s (at p) = suc (rank-s p)
+
+rank-v-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+           {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+           {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+           {D : Map γ s σ' v R v' R'} → VertexM D → ℕ
+rank-v-m env    = zero
+rank-v-m input  = zero
+rank-v-m (at p) = suc (rank-m p)
+
+private
+  src< : ∀ {n} → zero < suc n
+  src< = s≤s z≤n
+
+  under : ∀ {m n} → suc m < suc n → m < n
+  under (s≤s h) = h
+
+  emb : ∀ k {m n} → suc m < suc n → suc (k + m) < suc (k + n)
+  emb k h = s≤s (+-monoʳ-< k (under h))
+
+  root₁ : ∀ a b → suc a < suc (suc a + b)
+  root₁ a b = s≤s (m≤m+n (suc a) b)
+
+  root₂ : ∀ a b → suc (a + b) < suc (a + suc b)
+  root₂ a b = s≤s (≤-reflexive (≡-sym (+-suc a b)))
+
+  root₀ : ∀ a → suc a < suc (suc a)
+  root₀ a = ≤-refl
+
+  root₁₃ : ∀ a b c → suc a < suc ((suc a + b) + c)
+  root₁₃ a b c = s≤s (≤-trans (m≤m+n (suc a) b) (m≤m+n (suc a + b) c))
+
+  root₂₃ : ∀ a b c → suc (a + b) < suc ((a + suc b) + c)
+  root₂₃ a b c = s≤s (≤-trans (≤-reflexive (≡-sym (+-suc a b))) (m≤m+n (a + suc b) c))
+
+-- A non-zero value of a root-edge family locates the premise root.
+private
+  edge-ε : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} {m}
+           {S : M.Matrix m (width v)} (p : Path D) (i : Fin m) (j : Fin (width-at p)) →
+           edge S p i j ≡ two.I → p ≡ ε
+  edge-ε ε i j h = ≡-refl
+  edge-ε (inl p) i j ()
+  edge-ε (inr p) i j ()
+  edge-ε (case-l₁ p) i j ()
+  edge-ε (case-l₂ p) i j ()
+  edge-ε (case-r₁ p) i j ()
+  edge-ε (case-r₂ p) i j ()
+  edge-ε (pair₁ p) i j ()
+  edge-ε (pair₂ p) i j ()
+  edge-ε (fst p) i j ()
+  edge-ε (snd p) i j ()
+  edge-ε (app₁ p) i j ()
+  edge-ε (app₂ p) i j ()
+  edge-ε (app₃ p) i j ()
+  edge-ε (bop p) i j ()
+  edge-ε (brel p) i j ()
+  edge-ε (roll p) i j ()
+  edge-ε (fold₁ p) i j ()
+  edge-ε (fold₂ p) i j ()
+
+  edge-ε-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+             {D : γ , Ms ⇓s vs [ R ]} {m}
+             {S : M.Matrix m (bases-width is)} (p : PathS D) (i : Fin m) (j : Fin (width-at-s p)) →
+             edge-s S p i j ≡ two.I → p ≡ ε
+  edge-ε-s ε i j h = ≡-refl
+  edge-ε-s (hd p) i j ()
+  edge-ε-s (tl p) i j ()
+
+  edge-ε-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+             {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+             {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+             {D : Map γ s σ' v R v' R'} {m}
+             {S : M.Matrix m (width v')} (p : PathM D) (i : Fin m) (j : Fin (width-at-m p)) →
+             edge-m S p i j ≡ two.I → p ≡ ε
+  edge-ε-m ε i j h = ≡-refl
+  edge-ε-m (m-rec₁ p) i j ()
+  edge-ε-m (m-rec₂ p) i j ()
+  edge-ε-m (m-inl p) i j ()
+  edge-ε-m (m-inr p) i j ()
+  edge-ε-m (m-pair₁ p) i j ()
+  edge-ε-m (m-pair₂ p) i j ()
+  edge-ε-m (m-mu p) i j ()
+
+-- Every edge runs strictly forward in rank.
+mutual
+  forward : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ])
+            (x y : Vertex D) (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+            graph D x y i j ≡ two.I → rank-v x < rank-v y
+  forward (⇓-var x) env env i j ()
+  forward (⇓-var x) env (at ε) i j _ = src<
+  forward (⇓-var x) (at ε) env i j ()
+  forward (⇓-var x) (at ε) (at ε) i j ()
+
+  forward ⇓-unit env env i j ()
+  forward ⇓-unit env (at ε) i j ()
+  forward ⇓-unit (at ε) env i j ()
+  forward ⇓-unit (at ε) (at ε) i j ()
+
+  forward ⇓-lam env env i j ()
+  forward ⇓-lam env (at ε) i j _ = src<
+  forward ⇓-lam (at ε) env i j ()
+  forward ⇓-lam (at ε) (at ε) i j ()
+
+  forward (⇓-inl D) env env i j ()
+  forward (⇓-inl D) env (at ε) i j ()
+  forward (⇓-inl D) env (at (inl q)) i j _ = src<
+  forward (⇓-inl D) (at ε) env i j ()
+  forward (⇓-inl D) (at ε) (at ε) i j ()
+  forward (⇓-inl D) (at ε) (at (inl q)) i j ()
+  forward (⇓-inl D) (at (inl p)) env i j ()
+  forward (⇓-inl D) (at (inl p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-inl D) (at (inl p)) (at ε) i j h | ≡-refl = root₀ (psize D)
+  forward (⇓-inl D) (at (inl p)) (at (inl q)) i j h = forward D (at p) (at q) i j h
+
+  forward (⇓-inr D) env env i j ()
+  forward (⇓-inr D) env (at ε) i j ()
+  forward (⇓-inr D) env (at (inr q)) i j _ = src<
+  forward (⇓-inr D) (at ε) env i j ()
+  forward (⇓-inr D) (at ε) (at ε) i j ()
+  forward (⇓-inr D) (at ε) (at (inr q)) i j ()
+  forward (⇓-inr D) (at (inr p)) env i j ()
+  forward (⇓-inr D) (at (inr p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-inr D) (at (inr p)) (at ε) i j h | ≡-refl = root₀ (psize D)
+  forward (⇓-inr D) (at (inr p)) (at (inr q)) i j h = forward D (at p) (at q) i j h
+
+  forward (⇓-fst D) env env i j ()
+  forward (⇓-fst D) env (at ε) i j ()
+  forward (⇓-fst D) env (at (fst q)) i j _ = src<
+  forward (⇓-fst D) (at ε) env i j ()
+  forward (⇓-fst D) (at ε) (at ε) i j ()
+  forward (⇓-fst D) (at ε) (at (fst q)) i j ()
+  forward (⇓-fst D) (at (fst p)) env i j ()
+  forward (⇓-fst D) (at (fst p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-fst D) (at (fst p)) (at ε) i j h | ≡-refl = root₀ (psize D)
+  forward (⇓-fst D) (at (fst p)) (at (fst q)) i j h = forward D (at p) (at q) i j h
+
+  forward (⇓-snd D) env env i j ()
+  forward (⇓-snd D) env (at ε) i j ()
+  forward (⇓-snd D) env (at (snd q)) i j _ = src<
+  forward (⇓-snd D) (at ε) env i j ()
+  forward (⇓-snd D) (at ε) (at ε) i j ()
+  forward (⇓-snd D) (at ε) (at (snd q)) i j ()
+  forward (⇓-snd D) (at (snd p)) env i j ()
+  forward (⇓-snd D) (at (snd p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-snd D) (at (snd p)) (at ε) i j h | ≡-refl = root₀ (psize D)
+  forward (⇓-snd D) (at (snd p)) (at (snd q)) i j h = forward D (at p) (at q) i j h
+
+  forward (⇓-roll D) env env i j ()
+  forward (⇓-roll D) env (at ε) i j ()
+  forward (⇓-roll D) env (at (roll q)) i j _ = src<
+  forward (⇓-roll D) (at ε) env i j ()
+  forward (⇓-roll D) (at ε) (at ε) i j ()
+  forward (⇓-roll D) (at ε) (at (roll q)) i j ()
+  forward (⇓-roll D) (at (roll p)) env i j ()
+  forward (⇓-roll D) (at (roll p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-roll D) (at (roll p)) (at ε) i j h | ≡-refl = root₀ (psize D)
+  forward (⇓-roll D) (at (roll p)) (at (roll q)) i j h = forward D (at p) (at q) i j h
+
+  forward (⇓-case-l D₁ D₂) env env i j ()
+  forward (⇓-case-l D₁ D₂) env (at ε) i j ()
+  forward (⇓-case-l D₁ D₂) env (at (case-l₁ q)) i j _ = src<
+  forward (⇓-case-l D₁ D₂) env (at (case-l₂ q)) i j _ = src<
+  forward (⇓-case-l D₁ D₂) (at ε) env i j ()
+  forward (⇓-case-l D₁ D₂) (at ε) (at ε) i j ()
+  forward (⇓-case-l D₁ D₂) (at ε) (at (case-l₁ q)) i j ()
+  forward (⇓-case-l D₁ D₂) (at ε) (at (case-l₂ q)) i j ()
+  forward (⇓-case-l D₁ D₂) (at (case-l₁ p)) env i j ()
+  forward (⇓-case-l D₁ D₂) (at (case-l₁ p)) (at ε) i j ()
+  forward (⇓-case-l D₁ D₂) (at (case-l₁ p)) (at (case-l₁ q)) i j h = forward D₁ (at p) (at q) i j h
+  forward (⇓-case-l D₁ D₂) (at (case-l₁ p)) (at (case-l₂ q)) i j h with edge-ε p i j h
+  forward (⇓-case-l D₁ D₂) (at (case-l₁ p)) (at (case-l₂ q)) i j h | ≡-refl = root₁ (psize D₁) (rank q)
+  forward (⇓-case-l D₁ D₂) (at (case-l₂ p)) env i j ()
+  forward (⇓-case-l D₁ D₂) (at (case-l₂ p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-case-l D₁ D₂) (at (case-l₂ p)) (at ε) i j h | ≡-refl = root₂ (size D₁) (psize D₂)
+  forward (⇓-case-l D₁ D₂) (at (case-l₂ p)) (at (case-l₁ q)) i j ()
+  forward (⇓-case-l D₁ D₂) (at (case-l₂ p)) (at (case-l₂ q)) i j h =
+    emb (size D₁) (forward D₂ (at p) (at q) i j h)
+
+  forward (⇓-case-r D₁ D₂) env env i j ()
+  forward (⇓-case-r D₁ D₂) env (at ε) i j ()
+  forward (⇓-case-r D₁ D₂) env (at (case-r₁ q)) i j _ = src<
+  forward (⇓-case-r D₁ D₂) env (at (case-r₂ q)) i j _ = src<
+  forward (⇓-case-r D₁ D₂) (at ε) env i j ()
+  forward (⇓-case-r D₁ D₂) (at ε) (at ε) i j ()
+  forward (⇓-case-r D₁ D₂) (at ε) (at (case-r₁ q)) i j ()
+  forward (⇓-case-r D₁ D₂) (at ε) (at (case-r₂ q)) i j ()
+  forward (⇓-case-r D₁ D₂) (at (case-r₁ p)) env i j ()
+  forward (⇓-case-r D₁ D₂) (at (case-r₁ p)) (at ε) i j ()
+  forward (⇓-case-r D₁ D₂) (at (case-r₁ p)) (at (case-r₁ q)) i j h = forward D₁ (at p) (at q) i j h
+  forward (⇓-case-r D₁ D₂) (at (case-r₁ p)) (at (case-r₂ q)) i j h with edge-ε p i j h
+  forward (⇓-case-r D₁ D₂) (at (case-r₁ p)) (at (case-r₂ q)) i j h | ≡-refl = root₁ (psize D₁) (rank q)
+  forward (⇓-case-r D₁ D₂) (at (case-r₂ p)) env i j ()
+  forward (⇓-case-r D₁ D₂) (at (case-r₂ p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-case-r D₁ D₂) (at (case-r₂ p)) (at ε) i j h | ≡-refl = root₂ (size D₁) (psize D₂)
+  forward (⇓-case-r D₁ D₂) (at (case-r₂ p)) (at (case-r₁ q)) i j ()
+  forward (⇓-case-r D₁ D₂) (at (case-r₂ p)) (at (case-r₂ q)) i j h =
+    emb (size D₁) (forward D₂ (at p) (at q) i j h)
+
+  forward (⇓-pair D₁ D₂) env env i j ()
+  forward (⇓-pair D₁ D₂) env (at ε) i j ()
+  forward (⇓-pair D₁ D₂) env (at (pair₁ q)) i j _ = src<
+  forward (⇓-pair D₁ D₂) env (at (pair₂ q)) i j _ = src<
+  forward (⇓-pair D₁ D₂) (at ε) env i j ()
+  forward (⇓-pair D₁ D₂) (at ε) (at ε) i j ()
+  forward (⇓-pair D₁ D₂) (at ε) (at (pair₁ q)) i j ()
+  forward (⇓-pair D₁ D₂) (at ε) (at (pair₂ q)) i j ()
+  forward (⇓-pair D₁ D₂) (at (pair₁ p)) env i j ()
+  forward (⇓-pair D₁ D₂) (at (pair₁ p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-pair D₁ D₂) (at (pair₁ p)) (at ε) i j h | ≡-refl = root₁ (psize D₁) (size D₂)
+  forward (⇓-pair D₁ D₂) (at (pair₁ p)) (at (pair₁ q)) i j h = forward D₁ (at p) (at q) i j h
+  forward (⇓-pair D₁ D₂) (at (pair₁ p)) (at (pair₂ q)) i j ()
+  forward (⇓-pair D₁ D₂) (at (pair₂ p)) env i j ()
+  forward (⇓-pair D₁ D₂) (at (pair₂ p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-pair D₁ D₂) (at (pair₂ p)) (at ε) i j h | ≡-refl = root₂ (size D₁) (psize D₂)
+  forward (⇓-pair D₁ D₂) (at (pair₂ p)) (at (pair₁ q)) i j ()
+  forward (⇓-pair D₁ D₂) (at (pair₂ p)) (at (pair₂ q)) i j h = emb (size D₁) (forward D₂ (at p) (at q) i j h)
+
+  forward (⇓-app D₁ D₂ D₃) env env i j ()
+  forward (⇓-app D₁ D₂ D₃) env (at ε) i j ()
+  forward (⇓-app D₁ D₂ D₃) env (at (app₁ q)) i j _ = src<
+  forward (⇓-app D₁ D₂ D₃) env (at (app₂ q)) i j _ = src<
+  forward (⇓-app D₁ D₂ D₃) env (at (app₃ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at ε) env i j ()
+  forward (⇓-app D₁ D₂ D₃) (at ε) (at ε) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at ε) (at (app₁ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at ε) (at (app₂ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at ε) (at (app₃ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₁ p)) env i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₁ p)) (at ε) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₁ p)) (at (app₁ q)) i j h = forward D₁ (at p) (at q) i j h
+  forward (⇓-app D₁ D₂ D₃) (at (app₁ p)) (at (app₂ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₁ p)) (at (app₃ q)) i j h with edge-ε p i j h
+  forward (⇓-app D₁ D₂ D₃) (at (app₁ p)) (at (app₃ q)) i j h | ≡-refl = root₁₃ (psize D₁) (size D₂) (rank q)
+  forward (⇓-app D₁ D₂ D₃) (at (app₂ p)) env i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at ε) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₁ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₂ q)) i j h = emb (size D₁) (forward D₂ (at p) (at q) i j h)
+  forward (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₃ q)) i j h with edge-ε p i j h
+  forward (⇓-app D₁ D₂ D₃) (at (app₂ p)) (at (app₃ q)) i j h | ≡-refl = root₂₃ (size D₁) (psize D₂) (rank q)
+  forward (⇓-app D₁ D₂ D₃) (at (app₃ p)) env i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at ε) i j h with edge-ε p i j h
+  forward (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at ε) i j h | ≡-refl = root₂ (size D₁ + size D₂) (psize D₃)
+  forward (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at (app₁ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at (app₂ q)) i j ()
+  forward (⇓-app D₁ D₂ D₃) (at (app₃ p)) (at (app₃ q)) i j h =
+    emb (size D₁ + size D₂) (forward D₃ (at p) (at q) i j h)
+
+  forward (⇓-bop D) env env i j ()
+  forward (⇓-bop D) env (at ε) i j ()
+  forward (⇓-bop D) env (at (bop q)) i j _ = src<
+  forward (⇓-bop D) (at ε) env i j ()
+  forward (⇓-bop D) (at ε) (at ε) i j ()
+  forward (⇓-bop D) (at ε) (at (bop q)) i j ()
+  forward (⇓-bop D) (at (bop p)) env i j ()
+  forward (⇓-bop D) (at (bop p)) (at ε) i j h with edge-ε-s p i j h
+  forward (⇓-bop D) (at (bop p)) (at ε) i j h | ≡-refl = root₀ (psize-s D)
+  forward (⇓-bop D) (at (bop p)) (at (bop q)) i j h = forward-s D (at p) (at q) i j h
+
+  forward (⇓-brel D) env env i j ()
+  forward (⇓-brel D) env (at ε) i j ()
+  forward (⇓-brel D) env (at (brel q)) i j _ = src<
+  forward (⇓-brel D) (at ε) env i j ()
+  forward (⇓-brel D) (at ε) (at ε) i j ()
+  forward (⇓-brel D) (at ε) (at (brel q)) i j ()
+  forward (⇓-brel D) (at (brel p)) env i j ()
+  forward (⇓-brel D) (at (brel p)) (at ε) i j ()
+  forward (⇓-brel D) (at (brel p)) (at (brel q)) i j h = forward-s D (at p) (at q) i j h
+
+  forward (⇓-fold D₁ D₂) env env i j ()
+  forward (⇓-fold D₁ D₂) env (at ε) i j ()
+  forward (⇓-fold D₁ D₂) env (at (fold₁ q)) i j _ = src<
+  forward (⇓-fold D₁ D₂) env (at (fold₂ q)) i j _ = src<
+  forward (⇓-fold D₁ D₂) (at ε) env i j ()
+  forward (⇓-fold D₁ D₂) (at ε) (at ε) i j ()
+  forward (⇓-fold D₁ D₂) (at ε) (at (fold₁ q)) i j ()
+  forward (⇓-fold D₁ D₂) (at ε) (at (fold₂ q)) i j ()
+  forward (⇓-fold D₁ D₂) (at (fold₁ p)) env i j ()
+  forward (⇓-fold D₁ D₂) (at (fold₁ p)) (at ε) i j ()
+  forward (⇓-fold D₁ D₂) (at (fold₁ p)) (at (fold₁ q)) i j h = forward D₁ (at p) (at q) i j h
+  forward (⇓-fold D₁ D₂) (at (fold₁ p)) (at (fold₂ q)) i j h with edge-ε p i j h
+  forward (⇓-fold D₁ D₂) (at (fold₁ p)) (at (fold₂ q)) i j h | ≡-refl = root₁ (psize D₁) (rank-m q)
+  forward (⇓-fold D₁ D₂) (at (fold₂ p)) env i j ()
+  forward (⇓-fold D₁ D₂) (at (fold₂ p)) (at ε) i j h with edge-ε-m p i j h
+  forward (⇓-fold D₁ D₂) (at (fold₂ p)) (at ε) i j h | ≡-refl = root₂ (size D₁) (psize-m D₂)
+  forward (⇓-fold D₁ D₂) (at (fold₂ p)) (at (fold₁ q)) i j ()
+  forward (⇓-fold D₁ D₂) (at (fold₂ p)) (at (fold₂ q)) i j h =
+    emb (size D₁) (forward-m D₂ (at p) (at q) i j h)
+
+  forward-s : ∀ {Γ is} {γ : Env Γ} {Ms : Every (λ s → Γ ⊢ base s) is} {vs R}
+              (D : γ , Ms ⇓s vs [ R ]) (x y : VertexS D)
+              (i : Fin (vertex-width-s y)) (j : Fin (vertex-width-s x)) →
+              graphS D x y i j ≡ two.I → rank-v-s x < rank-v-s y
+  forward-s [] env env i j ()
+  forward-s [] env (at ε) i j ()
+  forward-s [] (at ε) env i j ()
+  forward-s [] (at ε) (at ε) i j ()
+
+  forward-s (D₁ ∷ D₂) env env i j ()
+  forward-s (D₁ ∷ D₂) env (at ε) i j ()
+  forward-s (D₁ ∷ D₂) env (at (hd q)) i j _ = src<
+  forward-s (D₁ ∷ D₂) env (at (tl q)) i j _ = src<
+  forward-s (D₁ ∷ D₂) (at ε) env i j ()
+  forward-s (D₁ ∷ D₂) (at ε) (at ε) i j ()
+  forward-s (D₁ ∷ D₂) (at ε) (at (hd q)) i j ()
+  forward-s (D₁ ∷ D₂) (at ε) (at (tl q)) i j ()
+  forward-s (D₁ ∷ D₂) (at (hd p)) env i j ()
+  forward-s (D₁ ∷ D₂) (at (hd p)) (at ε) i j h with edge-ε p i j h
+  forward-s (D₁ ∷ D₂) (at (hd p)) (at ε) i j h | ≡-refl = root₁ (psize D₁) (size-s D₂)
+  forward-s (D₁ ∷ D₂) (at (hd p)) (at (hd q)) i j h = forward D₁ (at p) (at q) i j h
+  forward-s (D₁ ∷ D₂) (at (hd p)) (at (tl q)) i j ()
+  forward-s (D₁ ∷ D₂) (at (tl p)) env i j ()
+  forward-s (D₁ ∷ D₂) (at (tl p)) (at ε) i j h with edge-ε-s p i j h
+  forward-s (D₁ ∷ D₂) (at (tl p)) (at ε) i j h | ≡-refl = root₂ (size D₁) (psize-s D₂)
+  forward-s (D₁ ∷ D₂) (at (tl p)) (at (hd q)) i j ()
+  forward-s (D₁ ∷ D₂) (at (tl p)) (at (tl q)) i j h = emb (size D₁) (forward-s D₂ (at p) (at q) i j h)
+
+  forward-m : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : Γ ▸ τ₀ [ σr ] ⊢ σr}
+              {σ' : type 1} {v : Val (σ' [ μ τ₀ ])} {R : width-env γ ⇒ width v}
+              {v' : Val (σ' [ σr ])} {R' : width-env γ ⇒ width v'}
+              (D : Map γ s σ' v R v' R') (x y : VertexM D)
+              (i : Fin (vertex-width-m y)) (j : Fin (vertex-width-m x)) →
+              graphM D x y i j ≡ two.I → rank-v-m x < rank-v-m y
+  forward-m (m-rec D₁ D₂) env env i j ()
+  forward-m (m-rec D₁ D₂) env input i j ()
+  forward-m (m-rec D₁ D₂) env (at ε) i j ()
+  forward-m (m-rec D₁ D₂) env (at (m-rec₁ q)) i j _ = src<
+  forward-m (m-rec D₁ D₂) env (at (m-rec₂ q)) i j _ = src<
+  forward-m (m-rec D₁ D₂) input env i j ()
+  forward-m (m-rec D₁ D₂) input input i j ()
+  forward-m (m-rec D₁ D₂) input (at ε) i j ()
+  forward-m (m-rec D₁ D₂) input (at (m-rec₁ q)) i j _ = src<
+  forward-m (m-rec D₁ D₂) input (at (m-rec₂ q)) i j ()
+  forward-m (m-rec D₁ D₂) (at ε) env i j ()
+  forward-m (m-rec D₁ D₂) (at ε) input i j ()
+  forward-m (m-rec D₁ D₂) (at ε) (at ε) i j ()
+  forward-m (m-rec D₁ D₂) (at ε) (at (m-rec₁ q)) i j ()
+  forward-m (m-rec D₁ D₂) (at ε) (at (m-rec₂ q)) i j ()
+  forward-m (m-rec D₁ D₂) (at (m-rec₁ p)) env i j ()
+  forward-m (m-rec D₁ D₂) (at (m-rec₁ p)) input i j ()
+  forward-m (m-rec D₁ D₂) (at (m-rec₁ p)) (at ε) i j ()
+  forward-m (m-rec D₁ D₂) (at (m-rec₁ p)) (at (m-rec₁ q)) i j h = forward-m D₁ (at p) (at q) i j h
+  forward-m (m-rec D₁ D₂) (at (m-rec₁ p)) (at (m-rec₂ q)) i j h with edge-ε-m p i j h
+  forward-m (m-rec D₁ D₂) (at (m-rec₁ p)) (at (m-rec₂ q)) i j h | ≡-refl = root₁ (psize-m D₁) (rank q)
+  forward-m (m-rec D₁ D₂) (at (m-rec₂ p)) env i j ()
+  forward-m (m-rec D₁ D₂) (at (m-rec₂ p)) input i j ()
+  forward-m (m-rec D₁ D₂) (at (m-rec₂ p)) (at ε) i j h with edge-ε p i j h
+  forward-m (m-rec D₁ D₂) (at (m-rec₂ p)) (at ε) i j h | ≡-refl = root₂ (size-m D₁) (psize D₂)
+  forward-m (m-rec D₁ D₂) (at (m-rec₂ p)) (at (m-rec₁ q)) i j ()
+  forward-m (m-rec D₁ D₂) (at (m-rec₂ p)) (at (m-rec₂ q)) i j h =
+    emb (size-m D₁) (forward D₂ (at p) (at q) i j h)
+
+  forward-m m-unit env env i j ()
+  forward-m m-unit env input i j ()
+  forward-m m-unit env (at ε) i j ()
+  forward-m m-unit input env i j ()
+  forward-m m-unit input input i j ()
+  forward-m m-unit input (at ε) i j _ = src<
+  forward-m m-unit (at ε) env i j ()
+  forward-m m-unit (at ε) input i j ()
+  forward-m m-unit (at ε) (at ε) i j ()
+
+  forward-m m-base env env i j ()
+  forward-m m-base env input i j ()
+  forward-m m-base env (at ε) i j ()
+  forward-m m-base input env i j ()
+  forward-m m-base input input i j ()
+  forward-m m-base input (at ε) i j _ = src<
+  forward-m m-base (at ε) env i j ()
+  forward-m m-base (at ε) input i j ()
+  forward-m m-base (at ε) (at ε) i j ()
+
+  forward-m m-arrow env env i j ()
+  forward-m m-arrow env input i j ()
+  forward-m m-arrow env (at ε) i j ()
+  forward-m m-arrow input env i j ()
+  forward-m m-arrow input input i j ()
+  forward-m m-arrow input (at ε) i j _ = src<
+  forward-m m-arrow (at ε) env i j ()
+  forward-m m-arrow (at ε) input i j ()
+  forward-m m-arrow (at ε) (at ε) i j ()
+
+  forward-m (m-inl D) env env i j ()
+  forward-m (m-inl D) env input i j ()
+  forward-m (m-inl D) env (at ε) i j ()
+  forward-m (m-inl D) env (at (m-inl q)) i j _ = src<
+  forward-m (m-inl D) input env i j ()
+  forward-m (m-inl D) input input i j ()
+  forward-m (m-inl D) input (at ε) i j ()
+  forward-m (m-inl D) input (at (m-inl q)) i j _ = src<
+  forward-m (m-inl D) (at ε) env i j ()
+  forward-m (m-inl D) (at ε) input i j ()
+  forward-m (m-inl D) (at ε) (at ε) i j ()
+  forward-m (m-inl D) (at ε) (at (m-inl q)) i j ()
+  forward-m (m-inl D) (at (m-inl p)) env i j ()
+  forward-m (m-inl D) (at (m-inl p)) input i j ()
+  forward-m (m-inl D) (at (m-inl p)) (at ε) i j h with edge-ε-m p i j h
+  forward-m (m-inl D) (at (m-inl p)) (at ε) i j h | ≡-refl = root₀ (psize-m D)
+  forward-m (m-inl D) (at (m-inl p)) (at (m-inl q)) i j h = forward-m D (at p) (at q) i j h
+
+  forward-m (m-inr D) env env i j ()
+  forward-m (m-inr D) env input i j ()
+  forward-m (m-inr D) env (at ε) i j ()
+  forward-m (m-inr D) env (at (m-inr q)) i j _ = src<
+  forward-m (m-inr D) input env i j ()
+  forward-m (m-inr D) input input i j ()
+  forward-m (m-inr D) input (at ε) i j ()
+  forward-m (m-inr D) input (at (m-inr q)) i j _ = src<
+  forward-m (m-inr D) (at ε) env i j ()
+  forward-m (m-inr D) (at ε) input i j ()
+  forward-m (m-inr D) (at ε) (at ε) i j ()
+  forward-m (m-inr D) (at ε) (at (m-inr q)) i j ()
+  forward-m (m-inr D) (at (m-inr p)) env i j ()
+  forward-m (m-inr D) (at (m-inr p)) input i j ()
+  forward-m (m-inr D) (at (m-inr p)) (at ε) i j h with edge-ε-m p i j h
+  forward-m (m-inr D) (at (m-inr p)) (at ε) i j h | ≡-refl = root₀ (psize-m D)
+  forward-m (m-inr D) (at (m-inr p)) (at (m-inr q)) i j h = forward-m D (at p) (at q) i j h
+
+  forward-m (m-mu D) env env i j ()
+  forward-m (m-mu D) env input i j ()
+  forward-m (m-mu D) env (at ε) i j ()
+  forward-m (m-mu D) env (at (m-mu q)) i j _ = src<
+  forward-m (m-mu D) input env i j ()
+  forward-m (m-mu D) input input i j ()
+  forward-m (m-mu D) input (at ε) i j ()
+  forward-m (m-mu D) input (at (m-mu q)) i j _ = src<
+  forward-m (m-mu D) (at ε) env i j ()
+  forward-m (m-mu D) (at ε) input i j ()
+  forward-m (m-mu D) (at ε) (at ε) i j ()
+  forward-m (m-mu D) (at ε) (at (m-mu q)) i j ()
+  forward-m (m-mu D) (at (m-mu p)) env i j ()
+  forward-m (m-mu D) (at (m-mu p)) input i j ()
+  forward-m (m-mu D) (at (m-mu p)) (at ε) i j h with edge-ε-m p i j h
+  forward-m (m-mu D) (at (m-mu p)) (at ε) i j h | ≡-refl = root₀ (psize-m D)
+  forward-m (m-mu D) (at (m-mu p)) (at (m-mu q)) i j h = forward-m D (at p) (at q) i j h
+
+  forward-m (m-pair D₁ D₂) env env i j ()
+  forward-m (m-pair D₁ D₂) env input i j ()
+  forward-m (m-pair D₁ D₂) env (at ε) i j ()
+  forward-m (m-pair D₁ D₂) env (at (m-pair₁ q)) i j _ = src<
+  forward-m (m-pair D₁ D₂) env (at (m-pair₂ q)) i j _ = src<
+  forward-m (m-pair D₁ D₂) input env i j ()
+  forward-m (m-pair D₁ D₂) input input i j ()
+  forward-m (m-pair D₁ D₂) input (at ε) i j ()
+  forward-m (m-pair D₁ D₂) input (at (m-pair₁ q)) i j _ = src<
+  forward-m (m-pair D₁ D₂) input (at (m-pair₂ q)) i j _ = src<
+  forward-m (m-pair D₁ D₂) (at ε) env i j ()
+  forward-m (m-pair D₁ D₂) (at ε) input i j ()
+  forward-m (m-pair D₁ D₂) (at ε) (at ε) i j ()
+  forward-m (m-pair D₁ D₂) (at ε) (at (m-pair₁ q)) i j ()
+  forward-m (m-pair D₁ D₂) (at ε) (at (m-pair₂ q)) i j ()
+  forward-m (m-pair D₁ D₂) (at (m-pair₁ p)) env i j ()
+  forward-m (m-pair D₁ D₂) (at (m-pair₁ p)) input i j ()
+  forward-m (m-pair D₁ D₂) (at (m-pair₁ p)) (at ε) i j h with edge-ε-m p i j h
+  forward-m (m-pair D₁ D₂) (at (m-pair₁ p)) (at ε) i j h | ≡-refl = root₁ (psize-m D₁) (size-m D₂)
+  forward-m (m-pair D₁ D₂) (at (m-pair₁ p)) (at (m-pair₁ q)) i j h = forward-m D₁ (at p) (at q) i j h
+  forward-m (m-pair D₁ D₂) (at (m-pair₁ p)) (at (m-pair₂ q)) i j ()
+  forward-m (m-pair D₁ D₂) (at (m-pair₂ p)) env i j ()
+  forward-m (m-pair D₁ D₂) (at (m-pair₂ p)) input i j ()
+  forward-m (m-pair D₁ D₂) (at (m-pair₂ p)) (at ε) i j h with edge-ε-m p i j h
+  forward-m (m-pair D₁ D₂) (at (m-pair₂ p)) (at ε) i j h | ≡-refl = root₂ (size-m D₁) (psize-m D₂)
+  forward-m (m-pair D₁ D₂) (at (m-pair₂ p)) (at (m-pair₁ q)) i j ()
+  forward-m (m-pair D₁ D₂) (at (m-pair₂ p)) (at (m-pair₂ q)) i j h =
+    emb (size-m D₁) (forward-m D₂ (at p) (at q) i j h)
+
+
+-- A chain of one or more edges between vertices.
+data Chain {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} : Vertex D → Vertex D → Set ℓ where
+  step : ∀ {x y} (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+         graph D x y i j ≡ two.I → Chain x y
+  _∷_  : ∀ {x y z} → Chain x y → Chain y z → Chain x z
+
+-- Chains climb strictly in rank, so no chain returns to its start: the graph is acyclic.
+climb : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} {x y : Vertex D} →
+        Chain x y → rank-v x < rank-v y
+climb {D = D} {x} {y} (step i j h) = forward D x y i j h
+climb (c ∷ c') = <-trans (climb c) (climb c')
+
+acyclic : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} {x : Vertex D} →
+          Chain x x → ⊥
+acyclic c = <-irrefl ≡-refl (climb c)
+
+-- Witnesses for non-zero entries of sums and composites.
+private
+  Σ-I : ∀ {n} (f : Fin n → two.Two) → M.Σ f ≡ two.I → Σ (Fin n) (λ k → f k ≡ two.I)
+  Σ-I {suc n} f h with two.⊔-I (f F.zero) (M.Σ (λ k → f (F.suc k))) h
+  ... | inj₁ e = F.zero , e
+  ... | inj₂ e with Σ-I (λ k → f (F.suc k)) e
+  ...   | (k , e') = F.suc k , e'
+
+  ∘-I : ∀ {m n k} (A : M.Matrix m n) (B : M.Matrix n k) i l → (A M.∘ B) i l ≡ two.I →
+        Σ (Fin n) (λ j → (A i j ≡ two.I) × (B j l ≡ two.I))
+  ∘-I A B i l h with Σ-I (λ j → A i j two.⊓ B j l) h
+  ... | (j , e) with two.⊓-I (A i j) (B j l) e
+  ...   | (e₁ , e₂) = j , (e₁ , e₂)
+
+  Σ-I-at : ∀ {n} (f : Fin n → two.Two) (k : Fin n) → f k ≡ two.I → M.Σ f ≡ two.I
+  Σ-I-at f F.zero    h = two.⊔-I-inl h
+  Σ-I-at f (F.suc k) h = two.⊔-I-inr (f F.zero) (Σ-I-at (λ i → f (F.suc i)) k h)
+
+  ∘-I-at : ∀ {m n k} (A : M.Matrix m n) (B : M.Matrix n k) i l j →
+           A i j ≡ two.I → B j l ≡ two.I → (A M.∘ B) i l ≡ two.I
+  ∘-I-at A B i l j h₁ h₂ = Σ-I-at (λ j' → A i j' two.⊓ B j' l) j (two.⊓-I-pair h₁ h₂)
+
+-- The forward-edge property of an arbitrary graph over a derivation.
+Forward : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} → Graph D → Set ℓ
+Forward {D = D} G = ∀ (x y : Vertex D) (i : Fin (vertex-width y)) (j : Fin (vertex-width x)) →
+                    G x y i j ≡ two.I → rank-v x < rank-v y
+
+-- Consequences of forwardness for hiding, proved once over an abstract ranked vertex set and
+-- instantiated to the three graph families. Hiding preserves the property, since a new edge
+-- composes edges through the hidden vertex; hiding two vertices commutes, since an entry of one
+-- order decomposes into a term also present in the other order, except the residual routed
+-- through an edge in each direction between the two hidden vertices, which forwardness rules
+-- out; and hiding a list of vertices is therefore independent of the order, adjacent swaps being
+-- commutation pushed through the rest of the fold by congruence.
+private
+  module Ranked (V : Set ℓ) (w : V → ℕ) (rk : V → ℕ) where
+    open hide-algebra.Hide V w using (Gr; h; _≈g_; fold-cong)
+
+    private
+      Fwd : Gr → Set ℓ
+      Fwd G = ∀ x y (i : Fin (w y)) (j : Fin (w x)) → G x y i j ≡ two.I → rk x < rk y
+
+    fwd-h : ∀ {G} r → Fwd G → Fwd (h G r)
+    fwd-h {G} r fwd x y i j e with two.⊔-I (G x y i j) ((G r y M.∘ G x r) i j) e
+    ... | inj₁ a = fwd x y i j a
+    ... | inj₂ a with ∘-I (G r y) (G x r) i j a
+    ...   | (k , (e₁ , e₂)) = <-trans (fwd x r k j e₂) (fwd r y i k e₁)
+
+    fwd-fold : ∀ {G} rs → Fwd G → Fwd (foldl h G rs)
+    fwd-fold []       fwd = fwd
+    fwd-fold (r ∷ rs) fwd = fwd-fold rs (fwd-h r fwd)
+
+    into : ∀ {G} → Fwd G → ∀ r r' x y (i : Fin (w y)) (j : Fin (w x)) →
+           h (h G r) r' x y i j ≡ two.I → h (h G r') r x y i j ≡ two.I
+    into {G} fwd r r' x y i j e
+      with two.⊔-I (h G r x y i j) ((h G r r' y M.∘ h G r x r') i j) e
+    into {G} fwd r r' x y i j e | inj₁ a with two.⊔-I (G x y i j) ((G r y M.∘ G x r) i j) a
+    ... | inj₁ a₁ = two.⊔-I-inl (two.⊔-I-inl a₁)
+    ... | inj₂ a₂ with ∘-I (G r y) (G x r) i j a₂
+    ...   | (k , (e₁ , e₂)) =
+      two.⊔-I-inr (h G r' x y i j)
+        (∘-I-at (h G r' r y) (h G r' x r) i j k (two.⊔-I-inl e₁) (two.⊔-I-inl e₂))
+    into {G} fwd r r' x y i j e | inj₂ b with ∘-I (h G r r' y) (h G r x r') i j b
+    ... | (m , (c , d)) with two.⊔-I (G r' y i m) ((G r y M.∘ G r' r) i m) c
+                           | two.⊔-I (G x r' m j) ((G r r' M.∘ G x r) m j) d
+    ...   | inj₁ c₁ | inj₁ d₁ =
+      two.⊔-I-inl (two.⊔-I-inr (G x y i j) (∘-I-at (G r' y) (G x r') i j m c₁ d₁))
+    ...   | inj₁ c₁ | inj₂ d₂ with ∘-I (G r r') (G x r) m j d₂
+    ...     | (k , (d₁' , d₂')) =
+      two.⊔-I-inr (h G r' x y i j)
+        (∘-I-at (h G r' r y) (h G r' x r) i j k
+          (two.⊔-I-inr (G r y i k) (∘-I-at (G r' y) (G r r') i k m c₁ d₁'))
+          (two.⊔-I-inl d₂'))
+    into {G} fwd r r' x y i j e | inj₂ b | (m , (c , d)) | inj₂ c₂ | inj₁ d₁
+      with ∘-I (G r y) (G r' r) i m c₂
+    ...     | (k , (c₁' , c₂')) =
+      two.⊔-I-inr (h G r' x y i j)
+        (∘-I-at (h G r' r y) (h G r' x r) i j k
+          (two.⊔-I-inl c₁')
+          (two.⊔-I-inr (G x r k j) (∘-I-at (G r' r) (G x r') k j m c₂' d₁)))
+    into {G} fwd r r' x y i j e | inj₂ b | (m , (c , d)) | inj₂ c₂ | inj₂ d₂
+      with ∘-I (G r y) (G r' r) i m c₂ | ∘-I (G r r') (G x r) m j d₂
+    ...     | (k , (_ , c₂')) | (k' , (d₁' , _)) =
+      ⊥-elim (<-asym (fwd r' r k m c₂') (fwd r r' m k' d₁'))
+
+    comm : ∀ {G} → Fwd G → ∀ r r' x y (i : Fin (w y)) (j : Fin (w x)) →
+           h (h G r) r' x y i j ≡ h (h G r') r x y i j
+    comm fwd r r' x y i j = two.I-antisym (into fwd r r' x y i j) (into fwd r' r x y i j)
+
+    perm : ∀ {G rs rs'} → Fwd G → rs ↭ rs' → foldl h G rs ≈g foldl h G rs'
+    perm fwd ↭.refl x y i j = ≡-refl
+    perm fwd (↭.prep r p) = perm (fwd-h r fwd) p
+    perm fwd (↭.swap {xs = rs} a b p) x y i j =
+      ≡-trans (fold-cong rs (comm fwd a b) x y i j)
+              (perm (fwd-h a (fwd-h b fwd)) p x y i j)
+    perm fwd (↭.trans p q) x y i j = ≡-trans (perm fwd p x y i j) (perm fwd q x y i j)
+
+hide-all-forward : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} {G : Graph D}
+                   (rs : List (Vertex D)) → Forward G → Forward (hide-all G rs)
+hide-all-forward {D = D} = Ranked.fwd-fold (Vertex D) vertex-width rank-v
+
+-- The first-order dependence graph inherits the property.
+fo-forward : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} (D : γ , t ⇓ v [ R ]) → Forward (fo-graph D)
+fo-forward D =
+  hide-all-forward (map at (filterᵇ (λ p → Bool.not (is-ε p) Bool.∧ Bool.not (fo-at p)) (paths D)))
+                   (forward D)
+
+hide-all-perm : ∀ {Γ τ} {γ : Env Γ} {t : Γ ⊢ τ} {v R} {D : γ , t ⇓ v [ R ]} {G : Graph D} →
+                Forward G → ∀ {rs rs'} → rs ↭ rs' →
+                ∀ (x y : Vertex D) i j → hide-all G rs x y i j ≡ hide-all G rs' x y i j
+hide-all-perm {D = D} fwd = Ranked.perm (Vertex D) vertex-width rank-v fwd
+
diff --git a/agda/src/language-operational/totality.agda b/agda/src/language-operational/totality.agda
new file mode 100644
index 00000000..3fac960e
--- /dev/null
+++ b/agda/src/language-operational/totality.agda
@@ -0,0 +1,375 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (_⊔_) renaming (suc to lsuc)
+open import Data.Fin using (Fin)
+open import Data.Nat using (ℕ; suc; _+_; _<_; s≤s)
+open import Data.Nat.Properties using (m≤m+n; m≤n+m; n<1+n)
+open import Data.Nat.Induction using (<-wellFounded)
+open import Induction.WellFounded using (Acc; acc)
+open import Data.Product using (Σ; _×_; _,_; proj₁; proj₂)
+open import Data.Sum using (inj₁; inj₂)
+open import every using (Every; []; _∷_)
+open import Data.Unit.Polymorphic using (tt) renaming (⊤ to ⊤ₛ)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym) renaming (subst to ≡-subst)
+open import Relation.Binary.PropositionalEquality.Properties using (subst-subst-sym; subst-sym-subst)
+open import prop-setoid using (Setoid)
+open import commutative-semiring using (CommutativeSemiring)
+open import categories using (Category; HasProducts; HasTerminal)
+open import signature using (Signature)
+open import primitives using (Primitives)
+import matrix
+import two
+
+-- Computability (totality) predicate on values: the existence content of the logical relation, without the
+-- denotational component. Its fundamental lemma is normalisation, yielding a total evaluator.
+module language-operational.totality
+  {ℓ} (Sig : Signature ℓ) (𝒫 : Primitives two.semiring Sig) where
+
+open Signature Sig
+open Primitives 𝒫
+open prop-setoid._⇒_ using (func)
+open import language-syntax Sig renaming (_,_ to _▸_)
+open import type-substitution Sig using (unfold₁; unfold₁-inst; size; arr-bound; arr-self; unfold₁-arr)
+open import language-operational.evaluation Sig 𝒫
+
+private
+  module M = matrix.Mat two.semiring
+
+open Category M.cat using (_⇒_; _∘_) renaming (id to idm)
+open HasProducts products using (p₁; p₂) renaming (pair to ⟨_,_⟩)
+open HasTerminal M.terminal using (to-terminal)
+
+private
+  ℓT = ℓ
+
+TSpec : type 0 → Set (lsuc ℓT)
+TSpec τ = Val τ → Set ℓT
+
+data MuTotal (τ₀ : type 1)
+             (T< : (σ : type 0) → size σ < size (μ τ₀) → TSpec σ) :
+             (σ' : type 1) → Val (σ' [ μ τ₀ ]) → Set ℓT where
+  mt-roll  : ∀ {w} → MuTotal τ₀ T< τ₀ w → MuTotal τ₀ T< (var Fin.zero) (roll w)
+  mt-unit  : MuTotal τ₀ T< unit unit
+  mt-base  : ∀ {s c} → MuTotal τ₀ T< (base s) (const c)
+  mt-arrow : ∀ {σ₁ σ₂ : type 0} {v} →
+             (p : size {1} (σ₁ [→] σ₂) < size (μ τ₀)) →
+             T< (σ₁ [→] σ₂) p v →
+             MuTotal τ₀ T< (σ₁ [→] σ₂) v
+  mt-inl   : ∀ {σ₁ σ₂ : type 1} {v} →
+             MuTotal τ₀ T< σ₁ v → MuTotal τ₀ T< (σ₁ [+] σ₂) (inl v)
+  mt-inr   : ∀ {σ₁ σ₂ : type 1} {v} →
+             MuTotal τ₀ T< σ₂ v → MuTotal τ₀ T< (σ₁ [+] σ₂) (inr v)
+  mt-pair  : ∀ {σ₁ σ₂ : type 1} {v₁ v₂} →
+             MuTotal τ₀ T< σ₁ v₁ → MuTotal τ₀ T< σ₂ v₂ →
+             MuTotal τ₀ T< (σ₁ [×] σ₂) (pair v₁ v₂)
+  mt-mu    : ∀ {τ' : type 2} {w} →
+             MuTotal τ₀ T< (unfold₁ τ') w →
+             MuTotal τ₀ T< (μ τ') (roll (≡-subst Val (unfold₁-inst τ' (μ τ₀)) w))
+
+Total-acc : (τ : type 0) → Acc _<_ (size τ) → TSpec τ
+Total-acc (var ())
+Total-acc unit _ v = ⊤ₛ {ℓT}
+Total-acc (base s) _ v = ⊤ₛ {ℓT}
+Total-acc (σ [+] τ) (acc rs) (inl v) =
+  Total-acc σ (rs (s≤s (m≤m+n (size σ) (size τ)))) v
+Total-acc (σ [+] τ) (acc rs) (inr v) =
+  Total-acc τ (rs (s≤s (m≤n+m (size τ) (size σ)))) v
+Total-acc (σ [×] τ) (acc rs) (pair v u) =
+  Total-acc σ (rs (s≤s (m≤m+n (size σ) (size τ)))) v ×
+  Total-acc τ (rs (s≤s (m≤n+m (size τ) (size σ)))) u
+Total-acc (σ [→] τ) (acc rs) (clo {Γ'} γ' t) =
+  ∀ (v : Val σ) → Total-acc σ (rs (s≤s (m≤m+n (size σ) (size τ)))) v →
+  Σ (Val τ) λ u →
+  Σ (Category._⇒_ M.cat (width-env γ' + width v) (width u)) λ R →
+  (γ' · v , t ⇓ u [ R ]) ×
+  Total-acc τ (rs (s≤s (m≤n+m (size τ) (size σ)))) u
+Total-acc (μ τ₀) (acc rs) v =
+  MuTotal τ₀ (λ σ p → Total-acc σ (rs p)) (var Fin.zero) v
+
+Total : (τ : type 0) → TSpec τ
+Total τ = Total-acc τ (<-wellFounded (size τ))
+
+TotalEnv : (Γ : ctxt) → Env Γ → Set ℓT
+TotalEnv emp emp = ⊤ₛ {ℓT}
+TotalEnv (Γ ▸ τ) (γ · v) = TotalEnv Γ γ × Total τ v
+
+mu-total-map : ∀ {τ₀} {T< T<' : (σ : type 0) → size σ < size (μ τ₀) → TSpec σ} →
+               (∀ σ p {v} → T< σ p v → T<' σ p v) →
+               ∀ {σ' v} → MuTotal τ₀ T< σ' v → MuTotal τ₀ T<' σ' v
+mu-total-map f (mt-roll m)     = mt-roll (mu-total-map f m)
+mu-total-map f mt-unit         = mt-unit
+mu-total-map f mt-base         = mt-base
+mu-total-map f (mt-arrow p t)  = mt-arrow p (f _ p t)
+mu-total-map f (mt-inl m)      = mt-inl (mu-total-map f m)
+mu-total-map f (mt-inr m)      = mt-inr (mu-total-map f m)
+mu-total-map f (mt-pair m m')  = mt-pair (mu-total-map f m) (mu-total-map f m')
+mu-total-map f (mt-mu m)       = mt-mu (mu-total-map f m)
+
+-- Total-acc does not depend on the accessibility proof.
+total-irr-acc : ∀ τ → Acc _<_ (size τ) →
+                ∀ {ac ac' : Acc _<_ (size τ)} {v} →
+                Total-acc τ ac v → Total-acc τ ac' v
+total-irr-acc unit _ t = t
+total-irr-acc (base s) _ t = t
+total-irr-acc (σ [+] τ) (acc as) {acc rs} {acc rs'} {inl v} t =
+  total-irr-acc σ (as (s≤s (m≤m+n (size σ) (size τ)))) t
+total-irr-acc (σ [+] τ) (acc as) {acc rs} {acc rs'} {inr v} t =
+  total-irr-acc τ (as (s≤s (m≤n+m (size τ) (size σ)))) t
+total-irr-acc (σ [×] τ) (acc as) {acc rs} {acc rs'} {pair v u} (t , t') =
+  total-irr-acc σ (as (s≤s (m≤m+n (size σ) (size τ)))) t ,
+  total-irr-acc τ (as (s≤s (m≤n+m (size τ) (size σ)))) t'
+total-irr-acc (σ [→] τ) (acc as) {acc rs} {acc rs'} {clo γ' t₀} f = λ v tv →
+  let (u , R , D , tu) = f v (total-irr-acc σ (as (s≤s (m≤m+n (size σ) (size τ)))) tv)
+  in u , R , D , total-irr-acc τ (as (s≤s (m≤n+m (size τ) (size σ)))) tu
+total-irr-acc (μ τ₀) (acc as) {acc rs} {acc rs'} m =
+  mu-total-map (λ σ p t → total-irr-acc σ (as p) t) m
+
+total-irr : ∀ τ {ac ac' : Acc _<_ (size τ)} {v} →
+            Total-acc τ ac v → Total-acc τ ac' v
+total-irr τ = total-irr-acc τ (<-wellFounded (size τ))
+
+-- Canonical mu family, with the totality predicate itself at arrow leaves.
+MuT : (τ₀ : type 1) (σ' : type 1) → Val (σ' [ μ τ₀ ]) → Set ℓT
+MuT τ₀ = MuTotal τ₀ (λ σ p → Total σ)
+
+-- Introduction and elimination for Total at each connective.
+sum-out₁ : ∀ {σ τ v} → Total (σ [+] τ) (inl v) → Total σ v
+sum-out₁ {σ} t = total-irr σ t
+
+sum-out₂ : ∀ {σ τ v} → Total (σ [+] τ) (inr v) → Total τ v
+sum-out₂ {σ} {τ} t = total-irr τ t
+
+sum-in₁ : ∀ {σ τ v} → Total σ v → Total (σ [+] τ) (inl v)
+sum-in₁ {σ} t = total-irr σ t
+
+sum-in₂ : ∀ {σ τ v} → Total τ v → Total (σ [+] τ) (inr v)
+sum-in₂ {σ} {τ} t = total-irr τ t
+
+prod-out : ∀ {σ τ v u} → Total (σ [×] τ) (pair v u) → Total σ v × Total τ u
+prod-out {σ} {τ} (t , t') = total-irr σ t , total-irr τ t'
+
+prod-in : ∀ {σ τ v u} → Total σ v → Total τ u → Total (σ [×] τ) (pair v u)
+prod-in {σ} {τ} t t' = total-irr σ t , total-irr τ t'
+
+mu-out : ∀ {τ₀ v} → Total (μ τ₀) v → MuT τ₀ (var Fin.zero) v
+mu-out m = mu-total-map (λ σ p t → total-irr σ t) m
+
+mu-in : ∀ {τ₀ v} → MuT τ₀ (var Fin.zero) v → Total (μ τ₀) v
+mu-in m = mu-total-map (λ σ p t → total-irr σ t) m
+
+-- Value size, invariant under transport; drives the mutual recursion below.
+vsize : ∀ {τ : type 0} → Val τ → ℕ
+vsize unit       = 1
+vsize (const c)  = 1
+vsize (clo γ t)  = 1
+vsize (inl v)    = suc (vsize v)
+vsize (inr v)    = suc (vsize v)
+vsize (pair v u) = suc (vsize v + vsize u)
+vsize (roll v)   = suc (vsize v)
+
+vsize-subst : ∀ {σ σ' : type 0} (e : σ ≡ σ') (w : Val σ) → vsize (≡-subst Val e w) ≡ vsize w
+vsize-subst refl w = refl
+
+total-coerce : ∀ {σ σ' : type 0} (e : σ ≡ σ') {v : Val σ} →
+               Total σ v → Total σ' (≡-subst Val e v)
+total-coerce refl t = t
+
+-- Totality at a substituted type versus membership of the mu family. The nested case crosses between the
+-- outer family and the family of the inner body through Total at the propositionally equal type.
+fold-tot-acc : ∀ (τ₀ σ' : type 1) → arr-bound (size (μ τ₀)) σ' →
+               ∀ {v : Val (σ' [ μ τ₀ ])} → Acc _<_ (vsize v) →
+               Total (σ' [ μ τ₀ ]) v → MuT τ₀ σ' v
+unfold-tot-acc : ∀ (τ₀ σ' : type 1) →
+                 ∀ {v : Val (σ' [ μ τ₀ ])} → Acc _<_ (vsize v) →
+                 MuT τ₀ σ' v → Total (σ' [ μ τ₀ ]) v
+
+fold-tot-acc τ₀ (var Fin.zero) b av t = mu-out t
+fold-tot-acc τ₀ unit b {unit} av t = mt-unit
+fold-tot-acc τ₀ (base s) b {const c} av t = mt-base
+fold-tot-acc τ₀ (σ₁ [+] σ₂) (b₁ , b₂) {inl v₁} (acc ra) t =
+  mt-inl (fold-tot-acc τ₀ σ₁ b₁ (ra (n<1+n _)) (sum-out₁ {σ₁ [ μ τ₀ ]} {σ₂ [ μ τ₀ ]} t))
+fold-tot-acc τ₀ (σ₁ [+] σ₂) (b₁ , b₂) {inr v₂} (acc ra) t =
+  mt-inr (fold-tot-acc τ₀ σ₂ b₂ (ra (n<1+n _)) (sum-out₂ {σ₁ [ μ τ₀ ]} {σ₂ [ μ τ₀ ]} t))
+fold-tot-acc τ₀ (σ₁ [×] σ₂) (b₁ , b₂) {pair v₁ v₂} (acc ra) t =
+  mt-pair (fold-tot-acc τ₀ σ₁ b₁ (ra (s≤s (m≤m+n (vsize v₁) (vsize v₂)))) (Data.Product.proj₁ (prod-out {σ₁ [ μ τ₀ ]} {σ₂ [ μ τ₀ ]} t)))
+          (fold-tot-acc τ₀ σ₂ b₂ (ra (s≤s (m≤n+m (vsize v₂) (vsize v₁)))) (Data.Product.proj₂ (prod-out {σ₁ [ μ τ₀ ]} {σ₂ [ μ τ₀ ]} t)))
+  where import Data.Product
+fold-tot-acc τ₀ (σ₁ [→] σ₂) b av t = mt-arrow b t
+fold-tot-acc τ₀ (μ τ') b {roll w₂} (acc ra) t
+  with mu-out {τ₀ = sub (sub-lift (push (μ τ₀))) τ'} t
+... | mt-roll m₂ =
+  ≡-subst (λ x → MuT τ₀ (μ τ') (roll x)) (subst-subst-sym (unfold₁-inst τ' (μ τ₀)))
+    (mt-mu (fold-tot-acc τ₀ (unfold₁ τ') (unfold₁-arr τ' b)
+             (ra (≡-subst (λ n → n < suc (vsize w₂))
+                          (sym (vsize-subst (sym (unfold₁-inst τ' (μ τ₀))) w₂))
+                          (n<1+n _)))
+             (total-coerce (sym (unfold₁-inst τ' (μ τ₀)))
+               (unfold-tot-acc (sub (sub-lift (push (μ τ₀))) τ')
+                               (sub (sub-lift (push (μ τ₀))) τ')
+                               (ra (n<1+n _)) m₂))))
+
+unfold-tot-acc τ₀ (var Fin.zero) av m = mu-in m
+unfold-tot-acc τ₀ unit av m = tt
+unfold-tot-acc τ₀ (base s) av m = tt
+unfold-tot-acc τ₀ (σ₁ [+] σ₂) (acc ra) (mt-inl m) =
+  sum-in₁ {σ₁ [ μ τ₀ ]} {σ₂ [ μ τ₀ ]} (unfold-tot-acc τ₀ σ₁ (ra (n<1+n _)) m)
+unfold-tot-acc τ₀ (σ₁ [+] σ₂) (acc ra) (mt-inr m) =
+  sum-in₂ {σ₁ [ μ τ₀ ]} {σ₂ [ μ τ₀ ]} (unfold-tot-acc τ₀ σ₂ (ra (n<1+n _)) m)
+unfold-tot-acc τ₀ (σ₁ [×] σ₂) (acc ra) (mt-pair {v₁ = v₁} {v₂ = v₂} m₁ m₂) =
+  prod-in {σ₁ [ μ τ₀ ]} {σ₂ [ μ τ₀ ]} (unfold-tot-acc τ₀ σ₁ (ra (s≤s (m≤m+n (vsize v₁) (vsize v₂)))) m₁)
+    (unfold-tot-acc τ₀ σ₂ (ra (s≤s (m≤n+m (vsize v₂) (vsize v₁)))) m₂)
+unfold-tot-acc τ₀ (σ₁ [→] σ₂) av (mt-arrow p t) = t
+unfold-tot-acc τ₀ (μ τ') (acc ra) (mt-mu {w = w} m) =
+  mu-in (mt-roll (fold-tot-acc B B (arr-self B) (ra (n<1+n _))
+           (total-coerce E (unfold-tot-acc τ₀ (unfold₁ τ')
+              (ra (≡-subst (λ n → n < suc (vsize (≡-subst Val E w))) (vsize-subst E w) (n<1+n _)))
+              m))))
+  where
+  B : type 1
+  B = sub (sub-lift (push (μ τ₀))) τ'
+  E : (unfold₁ τ' [ μ τ₀ ]) ≡ (B [ μ B ])
+  E = unfold₁-inst τ' (μ τ₀)
+
+fold-tot : ∀ (τ₀ σ' : type 1) → arr-bound (size (μ τ₀)) σ' →
+           ∀ {v} → Total (σ' [ μ τ₀ ]) v → MuT τ₀ σ' v
+fold-tot τ₀ σ' b {v} = fold-tot-acc τ₀ σ' b (<-wellFounded (vsize v))
+
+unfold-tot : ∀ (τ₀ σ' : type 1) → ∀ {v} → MuT τ₀ σ' v → Total (σ' [ μ τ₀ ]) v
+unfold-tot τ₀ σ' {v} = unfold-tot-acc τ₀ σ' (<-wellFounded (vsize v))
+
+lookup-total : ∀ {Γ τ} (x : Γ ∋ τ) {γ : Env Γ} → TotalEnv Γ γ → Total τ (lookup x γ)
+lookup-total zero     {γ · v} (tγ , tv) = tv
+lookup-total (succ x) {γ · v} (tγ , tv) = lookup-total x tγ
+
+bool-total : ∀ (b : _) → Total (unit [+] unit) (bool→val b)
+bool-total (inj₁ _) = sum-in₁ {unit} {unit} {unit} tt
+bool-total (inj₂ _) = sum-in₂ {unit} {unit} {unit} tt
+
+-- The arrow clause of Total, stated with the canonical predicate throughout.
+ArrTot : (σ τ : type 0) {Γ' : ctxt} (γ' : Env Γ') (t : (Γ' ▸ σ) ⊢ τ) → Set ℓT
+ArrTot σ τ {Γ'} γ' t =
+  ∀ (v : Val σ) → Total σ v →
+  Σ (Val τ) λ u → Σ ((width-env γ' + width v) ⇒ width u) λ R →
+  ((γ' · v) , t ⇓ u [ R ]) × Total τ u
+
+arr-in : ∀ {σ τ Γ'} {γ' : Env Γ'} {t : (Γ' ▸ σ) ⊢ τ} →
+         ArrTot σ τ γ' t → Total (σ [→] τ) (clo γ' t)
+arr-in {σ} {τ} f v tv =
+  let (u , R , D , tu) = f v (total-irr σ tv) in u , R , D , total-irr τ tu
+
+arr-out : ∀ {σ τ Γ'} {γ' : Env Γ'} {t : (Γ' ▸ σ) ⊢ τ} →
+          Total (σ [→] τ) (clo γ' t) → ArrTot σ τ γ' t
+arr-out {σ} {τ} f v tv =
+  let (u , R , D , tu) = f v (total-irr σ tv) in u , R , D , total-irr τ tu
+
+-- Traversal of a total value by the fold body, producing the Map derivation.
+map-total : ∀ {Γ} {γ : Env Γ} {τ₀ : type 1} {σr : type 0} {s : (Γ ▸ (τ₀ [ σr ])) ⊢ σr} →
+            (∀ (w' : Val (τ₀ [ σr ])) → Total (τ₀ [ σr ]) w' →
+             Σ (Val σr) λ u → Σ ((width-env γ + width w') ⇒ width u) λ S →
+             ((γ · w') , s ⇓ u [ S ]) × Total σr u) →
+            ∀ (σ' : type 1) {v : Val (σ' [ μ τ₀ ])} → MuT τ₀ σ' v →
+            (R : width-env γ ⇒ width v) →
+            Σ (Val (σ' [ σr ])) λ v' → Σ (width-env γ ⇒ width v') λ R' →
+            Map γ s σ' v R v' R' × Total (σ' [ σr ]) v'
+map-total f (var Fin.zero) (mt-roll m') R =
+  let (w' , R' , Dm , tw') = map-total f _ m' R
+      (u , S , Ds , tu) = f w' tw'
+  in u , (S ∘ ⟨ idm _ , R' ⟩) , m-rec Dm Ds , tu
+map-total f unit {v} mt-unit R = v , R , m-unit , tt
+map-total f (base b) {v} mt-base R = v , R , m-base , tt
+map-total f (σ₁ [→] σ₂) {v} (mt-arrow p tv) R = v , R , m-arrow , tv
+map-total {σr = σr} f (σ₁ [+] σ₂) (mt-inl m') R =
+  let (v' , R' , Dm , tv') = map-total f σ₁ m' R
+  in inl v' , R' , m-inl Dm , sum-in₁ {σ₁ [ σr ]} {σ₂ [ σr ]} tv'
+map-total {σr = σr} f (σ₁ [+] σ₂) (mt-inr m') R =
+  let (v' , R' , Dm , tv') = map-total f σ₂ m' R
+  in inr v' , R' , m-inr Dm , sum-in₂ {σ₁ [ σr ]} {σ₂ [ σr ]} tv'
+map-total {σr = σr} f (σ₁ [×] σ₂) (mt-pair m₁ m₂) R =
+  let (v₁' , S , D₁ , t₁) = map-total f σ₁ m₁ (p₁ ∘ R)
+      (v₂' , T , D₂ , t₂) = map-total f σ₂ m₂ (p₂ ∘ R)
+  in pair v₁' v₂' , ⟨ S , T ⟩ , m-pair D₁ D₂ ,
+     prod-in {σ₁ [ σr ]} {σ₂ [ σr ]} t₁ t₂
+map-total {γ = γ} {τ₀ = τ₀} {σr = σr} {s = s} f (μ τ') (mt-mu {τ'} {w} m') R =
+  let (w' , R' , Dm , tw') =
+        map-total f (unfold₁ τ') m'
+          (≡-subst (λ n → width-env γ ⇒ n) (width-subst (unfold₁-inst τ' (μ τ₀)) w) R)
+  in roll (≡-subst Val (unfold₁-inst τ' σr) w') ,
+     ≡-subst (λ n → width-env γ ⇒ n) (sym (width-subst (unfold₁-inst τ' σr) w')) R' ,
+     ≡-subst (λ X → Map γ s (μ τ') (roll (≡-subst Val (unfold₁-inst τ' (μ τ₀)) w)) X
+                        (roll (≡-subst Val (unfold₁-inst τ' σr) w'))
+                        (≡-subst (λ n → width-env γ ⇒ n) (sym (width-subst (unfold₁-inst τ' σr) w')) R'))
+             (subst-sym-subst (width-subst (unfold₁-inst τ' (μ τ₀)) w))
+             (m-mu Dm) ,
+     mu-in (mt-roll (fold-tot (sub (sub-lift (push σr)) τ') (sub (sub-lift (push σr)) τ')
+                      (arr-self (sub (sub-lift (push σr)) τ'))
+                      (total-coerce (unfold₁-inst τ' σr) tw')))
+
+-- Fundamental lemma: every well-typed term evaluates, with a dependency matrix, to a total value.
+Eval : ∀ {Γ} (γ : Env Γ) {τ} (t : Γ ⊢ τ) → Set ℓT
+Eval γ {τ} t =
+  Σ (Val τ) λ v → Σ (width-env γ ⇒ width v) λ R → (γ , t ⇓ v [ R ]) × Total τ v
+
+fundamental : ∀ {Γ τ} (t : Γ ⊢ τ) (γ : Env Γ) → TotalEnv Γ γ → Eval γ t
+fundamental-s : ∀ {Γ is} (Ms : Every (λ s₁ → Γ ⊢ base s₁) is) (γ : Env Γ) → TotalEnv Γ γ →
+                Σ (sort-vals is) λ vs →
+                Σ (width-env γ ⇒ bases-width is) λ Rs → γ , Ms ⇓s vs [ Rs ]
+
+fundamental (var x) γ tγ = lookup x γ , proj-var x γ , ⇓-var x , lookup-total x tγ
+fundamental unit γ tγ = unit , to-terminal , ⇓-unit , tt
+fundamental (inl {τ₁ = τ₁} {τ₂ = τ₂} t) γ tγ =
+  let (v , R , D , tv) = fundamental t γ tγ
+  in inl v , R , ⇓-inl D , sum-in₁ {τ₁} {τ₂} tv
+fundamental (inr {τ₁ = τ₁} {τ₂ = τ₂} t) γ tγ =
+  let (v , R , D , tv) = fundamental t γ tγ
+  in inr v , R , ⇓-inr D , sum-in₂ {τ₁} {τ₂} tv
+fundamental (case {τ₁ = τ₁} {τ₂ = τ₂} s t₁ t₂) γ tγ with fundamental s γ tγ
+... | inl v , R , D , ts =
+  let (u , S , D₁ , tu) = fundamental t₁ (γ · v) (tγ , sum-out₁ {τ₁} {τ₂} ts)
+  in u , (S ∘ ⟨ idm _ , R ⟩) , ⇓-case-l D D₁ , tu
+... | inr v , R , D , ts =
+  let (u , S , D₂ , tu) = fundamental t₂ (γ · v) (tγ , sum-out₂ {τ₁} {τ₂} ts)
+  in u , (S ∘ ⟨ idm _ , R ⟩) , ⇓-case-r D D₂ , tu
+fundamental (pair {τ₁ = τ₁} {τ₂ = τ₂} s t) γ tγ =
+  let (v , R , D , tv) = fundamental s γ tγ
+      (u , S , D' , tu) = fundamental t γ tγ
+  in pair v u , ⟨ R , S ⟩ , ⇓-pair D D' , prod-in {τ₁} {τ₂} tv tu
+fundamental (fst {τ₁ = τ₁} {τ₂ = τ₂} t) γ tγ with fundamental t γ tγ
+... | pair v u , R , D , tv =
+  v , (p₁ ∘ R) , ⇓-fst D , proj₁ (prod-out {τ₁} {τ₂} tv)
+fundamental (snd {τ₁ = τ₁} {τ₂ = τ₂} t) γ tγ with fundamental t γ tγ
+... | pair v u , R , D , tv =
+  u , (p₂ ∘ R) , ⇓-snd D , proj₂ (prod-out {τ₁} {τ₂} tv)
+fundamental (lam t) γ tγ =
+  clo γ t , idm _ , ⇓-lam , arr-in (λ v tv → fundamental t (γ · v) (tγ , tv))
+fundamental (app s t) γ tγ with fundamental s γ tγ
+... | clo γ' t' , R , Ds , tf =
+  let (v , S , Dt , tv) = fundamental t γ tγ
+      (u , T , D' , tu) = arr-out tf v tv
+  in u , (T ∘ ⟨ R , S ⟩) , ⇓-app Ds Dt D' , tu
+fundamental (bop ω Ms) γ tγ =
+  let (vs , Rs , Dss) = fundamental-s Ms γ tγ
+  in const (op-fun ω .func vs) , (op-deps ω .func vs ∘ Rs) , ⇓-bop Dss , tt
+fundamental (brel ω Ms) γ tγ =
+  let (vs , Rs , Dss) = fundamental-s Ms γ tγ
+  in bool→val (rel-pred ω .func vs) , brel-mat γ (rel-pred ω .func vs) , ⇓-brel Dss ,
+     bool-total (rel-pred ω .func vs)
+fundamental (roll {τ = τ₀} t) γ tγ =
+  let (v , R , D , tv) = fundamental t γ tγ
+  in roll v , R , ⇓-roll D , mu-in (mt-roll (fold-tot τ₀ τ₀ (arr-self τ₀) tv))
+fundamental (fold s t) γ tγ =
+  let (v , R , D , tv) = fundamental t γ tγ
+      (u , R' , Dm , tu) =
+        map-total (λ w' tw' → fundamental s (γ · w') (tγ , tw'))
+                  (var Fin.zero) (mu-out tv) R
+  in u , R' , ⇓-fold D Dm , tu
+
+fundamental-s [] γ tγ = _ , _ , []
+fundamental-s (M ∷ Ms) γ tγ with fundamental M γ tγ
+... | const v , R , D , _ =
+  let (vs , Rs , Dss) = fundamental-s Ms γ tγ
+  in (v , vs) , ⟨ R , Rs ⟩ , (D ∷ Dss)
+
+-- The evaluator: every closed term evaluates, with its dependency matrix.
+eval : ∀ {τ} (t : emp ⊢ τ) →
+       Σ (Val τ) λ v → Σ (0 ⇒ width v) λ R → emp , t ⇓ v [ R ]
+eval t = let (v , R , D , _) = fundamental t emp tt in v , R , D
diff --git a/agda/src/language-syntax.agda b/agda/src/language-syntax.agda
index 10c03d4e..1ba8464f 100644
--- a/agda/src/language-syntax.agda
+++ b/agda/src/language-syntax.agda
@@ -1,60 +1,153 @@
 {-# OPTIONS --prop --postfix-projections --safe #-}
 
-open import Level using (0ℓ; suc; _⊔_)
+-- Syntax of types in the style of Lucatelli Nunes & Vákár: types are kinded over a context Δ of type
+-- variables. Strict positivity of μα.τ is enforced by requiring function types to be closed (kinded in
+-- the empty context), so type variables cannot occur in function positions.
+
+open import Data.Fin using (Fin; zero; suc)
 open import Data.List using (List; []; _∷_)
-open import signature using (Signature)
+open import Data.Nat using (ℕ; zero; suc; _+_)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; cong₂; sym; subst)
+open import Relation.Nullary using (Dec; yes; no)
+
 open import every using (Every; []; _∷_)
+open import signature using (Signature)
 
 module language-syntax {ℓ} (Sig : Signature ℓ) where
 
 open Signature Sig
 
-data type : Set ℓ where
-  unit bool : type
-  base : sort → type
-  _[×]_ _[→]_ _[+]_ : type → type → type
-  list : type → type
+TyCtxt : Set
+TyCtxt = ℕ
 
-infixr 35 _[→]_
-
-data first-order : type → Set ℓ where
-  unit  : first-order unit
-  bool  : first-order bool
-  base  : ∀ s → first-order (base s)
-  _[×]_ : ∀ {τ₁ τ₂} → first-order τ₁ → first-order τ₂ → first-order (τ₁ [×] τ₂)
-  _[+]_ : ∀ {τ₁ τ₂} → first-order τ₁ → first-order τ₂ → first-order (τ₁ [+] τ₂)
-
--- First-order types extended with `list`; not yet supported by conservativity, but useful for deriving
--- self-dualities for our examples.
-data first-order-data : type → Set ℓ where
-  unit  : first-order-data unit
-  bool  : first-order-data bool
-  base  : ∀ s → first-order-data (base s)
-  _[×]_ : ∀ {τ₁ τ₂} → first-order-data τ₁ → first-order-data τ₂ → first-order-data (τ₁ [×] τ₂)
-  _[+]_ : ∀ {τ₁ τ₂} → first-order-data τ₁ → first-order-data τ₂ → first-order-data (τ₁ [+] τ₂)
-  list  : ∀ {τ} → first-order-data τ → first-order-data (list τ)
+data type : TyCtxt → Set ℓ where
+  var   : ∀ {Δ} → Fin Δ → type Δ
+  unit  : ∀ {Δ} → type Δ
+  base  : ∀ {Δ} → sort → type Δ
+  _[+]_ : ∀ {Δ} → type Δ → type Δ → type Δ
+  _[×]_ : ∀ {Δ} → type Δ → type Δ → type Δ
+  _[→]_ : ∀ {Δ} → type zero → type zero → type Δ
+  μ     : ∀ {Δ} → type (suc Δ) → type Δ
 
 infixl 40 _[×]_ _[+]_
+infixr 35 _[→]_
 
+-- First-order types: no function spaces. Used to equip the fibres of a type's
+-- interpretation with approximation structure.
+data first-order : ∀ {Δ} → type Δ → Set ℓ where
+  var   : ∀ {Δ} (i : Fin Δ) → first-order (var i)
+  unit  : ∀ {Δ} → first-order {Δ} unit
+  base  : ∀ {Δ} (s : sort) → first-order {Δ} (base s)
+  _[+]_ : ∀ {Δ} {σ τ : type Δ} → first-order σ → first-order τ → first-order (σ [+] τ)
+  _[×]_ : ∀ {Δ} {σ τ : type Δ} → first-order σ → first-order τ → first-order (σ [×] τ)
+  μ     : ∀ {Δ} {τ : type (suc Δ)} → first-order τ → first-order (μ τ)
+
+first-order? : ∀ {Δ} (τ : type Δ) → Dec (first-order τ)
+first-order? (var i)    = yes (var i)
+first-order? unit       = yes unit
+first-order? (base s)   = yes (base s)
+first-order? (σ [+] τ) with first-order? σ | first-order? τ
+... | yes fσ | yes fτ = yes (fσ [+] fτ)
+... | no ¬fσ | _      = no λ { (fσ [+] _) → ¬fσ fσ }
+... | yes _  | no ¬fτ = no λ { (_ [+] fτ) → ¬fτ fτ }
+first-order? (σ [×] τ) with first-order? σ | first-order? τ
+... | yes fσ | yes fτ = yes (fσ [×] fτ)
+... | no ¬fσ | _      = no λ { (fσ [×] _) → ¬fσ fσ }
+... | yes _  | no ¬fτ = no λ { (_ [×] fτ) → ¬fτ fτ }
+first-order? (σ [→] τ) = no λ ()
+first-order? (μ τ) with first-order? τ
+... | yes fτ = yes (μ fτ)
+... | no ¬fτ = no λ { (μ fτ) → ¬fτ fτ }
+
+TyRen : TyCtxt → TyCtxt → Set
+TyRen Δ Δ' = Fin Δ → Fin Δ'
+
+TySub : TyCtxt → TyCtxt → Set ℓ
+TySub Δ Δ' = Fin Δ → type Δ'
+
+extᵗ : ∀ {Δ₁ Δ₂} → TyRen Δ₁ Δ₂ → TyRen (suc Δ₁) (suc Δ₂)
+extᵗ ρ zero    = zero
+extᵗ ρ (suc i) = suc (ρ i)
+
+extᵗⁿ : ∀ {Δ₁ Δ₂} n → TyRen Δ₁ Δ₂ → TyRen (n + Δ₁) (n + Δ₂)
+extᵗⁿ zero    ρ = ρ
+extᵗⁿ (suc n) ρ = extᵗ (extᵗⁿ n ρ)
+
+_*ᵗ_ : ∀ {Δ₁ Δ₂} → TyRen Δ₁ Δ₂ → type Δ₁ → type Δ₂
+ρ *ᵗ var i       = var (ρ i)
+ρ *ᵗ unit        = unit
+ρ *ᵗ base s      = base s
+ρ *ᵗ (τ₁ [+] τ₂) = (ρ *ᵗ τ₁) [+] (ρ *ᵗ τ₂)
+ρ *ᵗ (τ₁ [×] τ₂) = (ρ *ᵗ τ₁) [×] (ρ *ᵗ τ₂)
+ρ *ᵗ (τ₁ [→] τ₂) = τ₁ [→] τ₂
+ρ *ᵗ μ τ         = μ (extᵗ ρ *ᵗ τ)
+
+infixr 50 _*ᵗ_
+
+sub-lift : ∀ {Δ₁ Δ₂} → TySub Δ₁ Δ₂ → TySub (suc Δ₁) (suc Δ₂)
+sub-lift σ zero    = var zero
+sub-lift σ (suc i) = suc *ᵗ σ i
+
+sub : ∀ {Δ₁ Δ₂} → TySub Δ₁ Δ₂ → type Δ₁ → type Δ₂
+sub σ (var i)     = σ i
+sub σ unit        = unit
+sub σ (base s)    = base s
+sub σ (τ₁ [+] τ₂) = sub σ τ₁ [+] sub σ τ₂
+sub σ (τ₁ [×] τ₂) = sub σ τ₁ [×] sub σ τ₂
+sub σ (τ₁ [→] τ₂) = τ₁ [→] τ₂
+sub σ (μ τ)       = μ (sub (sub-lift σ) τ)
+
+push : ∀ {Δ} → type Δ → TySub (suc Δ) Δ
+push τ zero    = τ
+push τ (suc i) = var i
+
+_[_] : ∀ {Δ} → type (suc Δ) → type Δ → type Δ
+τ [ τ' ] = sub (push τ') τ
+
+infix 50 _[_]
+
+sub-cong : ∀ {Δ Δ'} {σ σ' : TySub Δ Δ'} (τ : type Δ) → (∀ i → σ i ≡ σ' i) → sub σ τ ≡ sub σ' τ
+sub-cong (var i)     σ≡σ' = σ≡σ' i
+sub-cong unit        _    = refl
+sub-cong (base s)    _    = refl
+sub-cong (τ₁ [+] τ₂) σ≡σ' = cong₂ _[+]_ (sub-cong τ₁ σ≡σ') (sub-cong τ₂ σ≡σ')
+sub-cong (τ₁ [×] τ₂) σ≡σ' = cong₂ _[×]_ (sub-cong τ₁ σ≡σ') (sub-cong τ₂ σ≡σ')
+sub-cong (τ₁ [→] τ₂) _ = refl
+sub-cong (μ τ)       σ≡σ' = cong μ (sub-cong τ lifted)
+  where
+    lifted : ∀ i → sub-lift _ i ≡ sub-lift _ i
+    lifted zero    = refl
+    lifted (suc i) = cong (suc *ᵗ_) (σ≡σ' i)
+
+sub-ren-id : ∀ {Δ Δ'} (τ : type Δ) {ρ : TyRen Δ Δ'} {σ : TySub Δ' Δ} →
+             (∀ i → σ (ρ i) ≡ var i) → sub σ (ρ *ᵗ τ) ≡ τ
+sub-ren-id (var i)     σ∘ρ≡id = σ∘ρ≡id i
+sub-ren-id unit        _       = refl
+sub-ren-id (base s)    _       = refl
+sub-ren-id (τ₁ [+] τ₂) σ∘ρ≡id = cong₂ _[+]_ (sub-ren-id τ₁ σ∘ρ≡id) (sub-ren-id τ₂ σ∘ρ≡id)
+sub-ren-id (τ₁ [×] τ₂) σ∘ρ≡id = cong₂ _[×]_ (sub-ren-id τ₁ σ∘ρ≡id) (sub-ren-id τ₂ σ∘ρ≡id)
+sub-ren-id (τ₁ [→] τ₂) _       = refl
+sub-ren-id (μ τ)       σ∘ρ≡id = cong μ (sub-ren-id τ lifted)
+  where
+    lifted : ∀ i → sub-lift _ (extᵗ _ i) ≡ var i
+    lifted zero    = refl
+    lifted (suc i) rewrite σ∘ρ≡id i = refl
+
+-- Total width of a list of sorts under a per-sort width assignment.
 data ctxt : Set ℓ where
   emp : ctxt
-  _,_ : ctxt → type → ctxt
+  _,_ : ctxt → type 0 → ctxt
+
+infixl 30 _,_
 
 data first-order-ctxt : ctxt → Set ℓ where
   emp : first-order-ctxt emp
   _,_ : ∀ {Γ τ} → first-order-ctxt Γ → first-order τ → first-order-ctxt (Γ , τ)
 
-data first-order-data-ctxt : ctxt → Set ℓ where
-  emp : first-order-data-ctxt emp
-  _,_ : ∀ {Γ τ} → first-order-data-ctxt Γ → first-order-data τ → first-order-data-ctxt (Γ , τ)
-
-infixl 30 _,_
+data _∋_ : ctxt → type 0 → Set ℓ where
+  zero : ∀ {Γ τ}    → (Γ , τ) ∋ τ
+  succ : ∀ {Γ τ τ'} → Γ ∋ τ → (Γ , τ') ∋ τ
 
-data _∋_ : ctxt → type → Set ℓ where
-  zero : ∀ {Γ τ} → (Γ , τ) ∋ τ
-  succ : ∀ {Γ τ τ'} → Γ ∋ τ → Γ , τ' ∋ τ
-
--- A renaming is a context morphism
 Ren : ctxt → ctxt → Set ℓ
 Ren Γ Γ' = ∀ {τ} → Γ ∋ τ → Γ' ∋ τ
 
@@ -64,114 +157,100 @@ id-ren Γ x = x
 _∘ren_ : ∀ {Γ₁ Γ₂ Γ₃} → Ren Γ₂ Γ₃ → Ren Γ₁ Γ₂ → Ren Γ₁ Γ₃
 ρ₁ ∘ren ρ₂ = λ z → ρ₁ (ρ₂ z)
 
--- Push a renaming under a context extension.
 ext : ∀ {Γ Γ' τ} → Ren Γ Γ' → Ren (Γ , τ) (Γ' , τ)
-ext ρ zero = zero
+ext ρ zero     = zero
 ext ρ (succ x) = succ (ρ x)
 
 weaken : ∀ {Γ τ} → Ren Γ (Γ , τ)
-weaken zero = succ zero
+weaken zero     = succ zero
 weaken (succ x) = succ (weaken x)
 
-data _⊢_ : ctxt → type → Set ℓ where
-  var : ∀ {Γ τ} → Γ ∋ τ → Γ ⊢ τ
-
-  unit : ∀ {Γ} → Γ ⊢ unit
-
-  -- booleans
-  true false : ∀ {Γ} → Γ ⊢ bool
-  if_then_else_ : ∀ {Γ τ} → Γ ⊢ bool → Γ ⊢ τ → Γ ⊢ τ → Γ ⊢ τ
-
-  -- sums
-  inl  : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₁ → Γ ⊢ τ₁ [+] τ₂
-  inr  : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₂ → Γ ⊢ τ₁ [+] τ₂
-  case : ∀ {Γ τ₁ τ₂ τ} → Γ ⊢ τ₁ [+] τ₂ → Γ , τ₁ ⊢ τ → Γ , τ₂ ⊢ τ → Γ ⊢ τ
-
-  -- products
-  pair : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₁ → Γ ⊢ τ₂ → Γ ⊢ τ₁ [×] τ₂
-  fst  : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₁ [×] τ₂ → Γ ⊢ τ₁
-  snd  : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₁ [×] τ₂ → Γ ⊢ τ₂
-
-  -- functions
-  lam  : ∀ {Γ τ₁ τ₂} → Γ , τ₁ ⊢ τ₂ → Γ ⊢ τ₁ [→] τ₂
-  app  : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₁ [→] τ₂ → Γ ⊢ τ₁ → Γ ⊢ τ₂
-
-  -- base operations
-  bop : ∀ {Γ in-sorts out-sort} →
-        op in-sorts out-sort →
-        Every (λ σ → Γ ⊢ base σ) in-sorts →
-        Γ ⊢ base out-sort
+data _⊢_ : ctxt → type 0 → Set ℓ where
+  var  : ∀ {Γ τ}        → Γ ∋ τ → Γ ⊢ τ
+  unit : ∀ {Γ}          → Γ ⊢ unit
+  inl  : ∀ {Γ τ₁ τ₂}    → Γ ⊢ τ₁ → Γ ⊢ τ₁ [+] τ₂
+  inr  : ∀ {Γ τ₁ τ₂}    → Γ ⊢ τ₂ → Γ ⊢ τ₁ [+] τ₂
+  case : ∀ {Γ τ₁ τ₂ τ}  → Γ ⊢ τ₁ [+] τ₂ → Γ , τ₁ ⊢ τ → Γ , τ₂ ⊢ τ → Γ ⊢ τ
+  pair : ∀ {Γ τ₁ τ₂}    → Γ ⊢ τ₁ → Γ ⊢ τ₂ → Γ ⊢ τ₁ [×] τ₂
+  fst  : ∀ {Γ τ₁ τ₂}    → Γ ⊢ τ₁ [×] τ₂ → Γ ⊢ τ₁
+  snd  : ∀ {Γ τ₁ τ₂}    → Γ ⊢ τ₁ [×] τ₂ → Γ ⊢ τ₂
+  lam  : ∀ {Γ σ τ}      → Γ , σ ⊢ τ → Γ ⊢ σ [→] τ
+  app  : ∀ {Γ σ τ}      → Γ ⊢ σ [→] τ → Γ ⊢ σ → Γ ⊢ τ
+  bop  : ∀ {Γ in-sorts out-sort} →
+         op in-sorts out-sort →
+         Every (λ σ → Γ ⊢ base σ) in-sorts →
+         Γ ⊢ base out-sort
   brel : ∀ {Γ in-sorts} →
          rel in-sorts →
          Every (λ σ → Γ ⊢ base σ) in-sorts →
-         Γ ⊢ bool
-
-  nil  : ∀ {Γ τ} → Γ ⊢ list τ
-  cons : ∀ {Γ τ} → Γ ⊢ τ → Γ ⊢ list τ → Γ ⊢ list τ
-  fold : ∀ {Γ τ₁ τ₂} →
-         Γ ⊢ τ₂ →
-         Γ , τ₁ , τ₂ ⊢ τ₂ →
-         Γ ⊢ list τ₁ →
-         Γ ⊢ τ₂
+         Γ ⊢ unit [+] unit
+  roll   : ∀ {Γ} {τ : type 1} → Γ ⊢ τ [ μ τ ] → Γ ⊢ μ τ
+  fold : ∀ {Γ} {τ : type 1} {σ : type 0} → Γ , τ [ σ ] ⊢ σ → Γ ⊢ μ τ → Γ ⊢ σ
 
--- Applying renamings to terms
 mutual
   _*_ : ∀ {Γ Γ' τ} → Ren Γ Γ' → Γ ⊢ τ → Γ' ⊢ τ
-  ρ * var x = var (ρ x)
-  ρ * unit = unit
-  ρ * true = true
-  ρ * false = false
-  ρ * (if M then M₁ else M₂) = if (ρ * M) then (ρ * M₁) else (ρ * M₂)
-  ρ * inl M = inl (ρ * M)
-  ρ * inr M = inr (ρ * M)
-  ρ * case M N₁ N₂ = case (ρ * M) (ext ρ * N₁) (ext ρ * N₂)
-  ρ * pair M N = pair (ρ * M) (ρ * N)
-  ρ * fst M = fst (ρ * M)
-  ρ * snd M = snd (ρ * M)
-  ρ * bop ω Ms = bop ω (ρ ** Ms)
-  ρ * brel ω Ms = brel ω (ρ ** Ms)
-  ρ * lam M = lam (ext ρ * M)
-  ρ * app M N = app (ρ * M) (ρ * N)
-  ρ * nil = nil
-  ρ * cons M N = cons (ρ * M) (ρ * N)
-  ρ * fold M₁ M₂ M = fold (ρ * M₁) (ext (ext ρ) * M₂) (ρ * M)
+  ρ * var x        = var (ρ x)
+  ρ * unit         = unit
+  ρ * inl t        = inl (ρ * t)
+  ρ * inr t        = inr (ρ * t)
+  ρ * case s t₁ t₂ = case (ρ * s) (ext ρ * t₁) (ext ρ * t₂)
+  ρ * pair s t     = pair (ρ * s) (ρ * t)
+  ρ * fst t        = fst (ρ * t)
+  ρ * snd t        = snd (ρ * t)
+  ρ * lam t        = lam (ext ρ * t)
+  ρ * app s t      = app (ρ * s) (ρ * t)
+  ρ * bop ω ts     = bop ω (ρ ** ts)
+  ρ * brel ω ts    = brel ω (ρ ** ts)
+  ρ * roll t       = roll (ρ * t)
+  ρ * fold s t     = fold (ext ρ * s) (ρ * t)
 
   _**_ : ∀ {Γ Γ' σs} → Ren Γ Γ' → Every (λ σ → Γ ⊢ base σ) σs → Every (λ σ → Γ' ⊢ base σ) σs
-  ρ ** [] = []
-  ρ ** (M ∷ Ms) = (ρ * M) ∷ (ρ ** Ms)
+  ρ ** []       = []
+  ρ ** (t ∷ ts) = (ρ * t) ∷ (ρ ** ts)
+
+list : type 0 → type 0
+list τ = μ (unit [+] (((λ ()) *ᵗ τ) [×] var zero))
+
+nil : ∀ {Γ τ} → Γ ⊢ list τ
+nil = roll (inl unit)
+
+cons : ∀ {Γ τ} → Γ ⊢ τ → Γ ⊢ list τ → Γ ⊢ list τ
+cons {_} {τ} h t = roll (inr (pair (subst (λ t → _ ⊢ t) (sym (sub-ren-id τ (λ ()))) h) t))
+
+foldr : ∀ {Γ σ τ} → Γ ⊢ τ → Γ , σ , τ ⊢ τ → Γ ⊢ list σ → Γ ⊢ τ
+foldr {Γ} {σ} {τ} nilCase consCase M =
+  fold {τ = unit [+] (((λ ()) *ᵗ σ) [×] var zero)}
+    (case (var zero)
+          (weaken * (weaken * nilCase))
+          (app (app (weaken * (weaken * (lam (lam consCase))))
+                    (subst (Γ-inr ⊢_) (sub-ren-id σ (λ ())) (fst (var zero))))
+               (snd (var zero))))
+    M
+  where
+    Γ-inr : ctxt
+    Γ-inr = Γ , (unit [+] (((λ ()) *ᵗ σ) [×] var zero)) [ τ ] , ((λ ()) *ᵗ σ) [ τ ] [×] τ
 
--- “macros”
 append : ∀ {Γ τ} → Γ ⊢ list τ → Γ ⊢ list τ → Γ ⊢ list τ
-append xs ys = fold ys (cons (var (succ zero)) (var zero)) xs
+append xs ys = foldr ys (cons (var (succ zero)) (var zero)) xs
 
 return : ∀ {Γ τ} → Γ ⊢ τ → Γ ⊢ list τ
 return x = cons x nil
 
 from_collect_ : ∀ {Γ τ₁ τ₂} → Γ ⊢ list τ₁ → Γ , τ₁ ⊢ list τ₂ → Γ ⊢ list τ₂
-from M collect N = fold nil (append (weaken * N) (var zero)) M
+from M collect N = foldr nil (append (weaken * N) (var zero)) M
+
+append-f : ∀ {Γ τ} → Γ ⊢ list τ [→] list τ [→] list τ
+append-f = lam (lam (foldr (var zero) (cons (var (succ zero)) (var zero)) (var (succ zero))))
+
+bool : type 0
+bool = unit [+] unit
+
+true false : ∀ {Γ} → Γ ⊢ bool
+true  = inl unit
+false = inr unit
+
+if_then_else_ : ∀ {Γ τ} → Γ ⊢ bool → Γ ⊢ τ → Γ ⊢ τ → Γ ⊢ τ
+if M then N₁ else N₂ = case M (weaken * N₁) (weaken * N₂)
 
 when_；_ : ∀ {Γ τ} → Γ ⊢ bool → Γ ⊢ list τ → Γ ⊢ list τ
 when M ； N = if M then N else nil
-
--- Some useful functions:
-append-f : ∀ {Γ τ} → Γ ⊢ list τ [→] list τ [→] list τ
-append-f = lam (lam (fold (var zero) (cons (var (succ zero)) (var zero)) (var (succ zero))))
-
--- The list monad
-{-
-ret : ∀ {Γ τ} → Γ ⊢ τ [→] list τ
-ret = lam (return (var zero))
-
-bind : ∀ {Γ τ₁ τ₂} → Γ ⊢ list τ₁ [→] (τ₁ [→] list τ₂) [→] list τ₂
-bind = lam (lam (from (var (succ zero)) collect (app (var (succ zero)) (var zero))))
-
-guard : ∀ {Γ} → Γ ⊢ bool [→] list unit
-guard = lam (if (var zero) then (cons unit nil) else nil)
--}
-
--- Definition of a syntactically defined monad
-record SynMonad : Set ℓ where
-  field
-    Mon  : type → type
-    pure : ∀ {Γ τ} → Γ ⊢ τ [→] Mon τ
-    bind : ∀ {Γ σ τ} → Γ ⊢ Mon σ [→] (σ [→] Mon τ) [→] Mon τ
diff --git a/agda/src/list.agda b/agda/src/list.agda
new file mode 100644
index 00000000..22521845
--- /dev/null
+++ b/agda/src/list.agda
@@ -0,0 +1,312 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Permutation and partition lemmas for lists, including lists of lists compared up to reordering
+-- at both levels.
+module list where
+
+open import Data.Bool as Bool using (Bool; not; _∨_)
+open import Data.Bool.ListAction using (any)
+open import Data.Empty using (⊥; ⊥-elim)
+open import Data.Bool.Properties using (∨-assoc)
+open import Data.Fin as Fin using (Fin)
+open import Data.List using (List; []; _∷_; _++_; map; concat; filterᵇ; partitionᵇ; tabulate)
+open import Data.List.Properties using (++-assoc)
+import Data.List.Relation.Binary.Permutation.Homogeneous as H
+import Data.List.Relation.Binary.Permutation.Propositional as ↭
+open ↭ using (_↭_; ↭-refl; ↭-trans; ↭-reflexive)
+open import Data.List.Relation.Binary.Pointwise using (Pointwise; []; _∷_)
+open import Data.List.Relation.Unary.All using (All; []; _∷_; universal) renaming (map to All-map)
+import Data.List.Relation.Unary.All.Properties as AllP
+open import Data.List.Relation.Unary.AllPairs using (AllPairs; []; _∷_)
+open import Data.List.Relation.Unary.Any using (Any; here; there)
+open import Data.List.Relation.Binary.Permutation.Propositional.Properties
+  using (++⁺; ++-comm; shift; All-resp-↭)
+open import Data.Product using (_×_; _,_; proj₁; proj₂)
+open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Relation.Binary.PropositionalEquality using (_≡_; subst)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; cong to ≡-cong; cong₂ to ≡-cong₂)
+
+private
+  ∨-swap : ∀ a b c → (a ∨ (b ∨ c)) ≡ (b ∨ (a ∨ c))
+  ∨-swap Bool.false b c = ≡-refl
+  ∨-swap Bool.true Bool.false c = ≡-refl
+  ∨-swap Bool.true Bool.true c = ≡-refl
+
+  ∨-interchange : ∀ a b c d → ((a ∨ b) ∨ (c ∨ d)) ≡ ((a ∨ c) ∨ (b ∨ d))
+  ∨-interchange Bool.true  b c d = ≡-refl
+  ∨-interchange Bool.false b c d = ∨-swap b c d
+
+++-swap : ∀ {a} {A : Set a} (xs ys zs : List A) → xs ++ (ys ++ zs) ↭ ys ++ (xs ++ zs)
+++-swap xs ys zs =
+  ↭-trans (↭-reflexive (≡-sym (++-assoc xs ys zs)))
+          (↭-trans (++⁺ (++-comm xs ys) ↭-refl) (↭-reflexive (++-assoc ys xs zs)))
+
+any-perm : ∀ {a} {A : Set a} (f : A → Bool) {rs rs' : List A} →
+           rs ↭ rs' → any f rs ≡ any f rs'
+any-perm f ↭.refl = ≡-refl
+any-perm f (↭.prep r p) = ≡-cong (f r ∨_) (any-perm f p)
+any-perm f (↭.swap a b p) =
+  ≡-trans (≡-cong (λ z → f a ∨ (f b ∨ z)) (any-perm f p)) (∨-swap (f a) (f b) _)
+any-perm f (↭.trans p q) = ≡-trans (any-perm f p) (any-perm f q)
+
+any-cong : ∀ {a} {A : Set a} {f g : A → Bool} → (∀ x → f x ≡ g x) →
+           ∀ xs → any f xs ≡ any g xs
+any-cong h []       = ≡-refl
+any-cong h (x ∷ xs) = ≡-cong₂ _∨_ (h x) (any-cong h xs)
+
+∨-false : ∀ x y → (x ∨ y) ≡ Bool.false → (x ≡ Bool.false) × (y ≡ Bool.false)
+∨-false Bool.false y h = ≡-refl , h
+
+∨-true : ∀ x → (x ∨ Bool.true) ≡ Bool.true
+∨-true Bool.false = ≡-refl
+∨-true Bool.true  = ≡-refl
+
+∨-true-inv : ∀ x y → (x ∨ y) ≡ Bool.true → (x ≡ Bool.true) ⊎ (y ≡ Bool.true)
+∨-true-inv Bool.true  y h = inj₁ ≡-refl
+∨-true-inv Bool.false y h = inj₂ h
+
+any-false : ∀ {a} {A : Set a} {f : A → Bool} {xs : List A} →
+            All (λ x → f x ≡ Bool.false) xs → any f xs ≡ Bool.false
+any-false []       = ≡-refl
+any-false (h ∷ hs) = ≡-cong₂ _∨_ h (any-false hs)
+
+any-false-All : ∀ {a} {A : Set a} (f : A → Bool) (xs : List A) →
+                any f xs ≡ Bool.false → All (λ x → f x ≡ Bool.false) xs
+any-false-All f []       h = []
+any-false-All f (x ∷ xs) h with ∨-false (f x) (any f xs) h
+... | (hx , hxs) = hx ∷ any-false-All f xs hxs
+
+any-tabulate-false : ∀ {a} {A : Set a} {n} (g : Fin n → A) (f : A → Bool) →
+                     any f (tabulate g) ≡ Bool.false → ∀ i → f (g i) ≡ Bool.false
+any-tabulate-false g f h Fin.zero    = proj₁ (∨-false (f (g Fin.zero)) _ h)
+any-tabulate-false g f h (Fin.suc i) =
+  any-tabulate-false (λ k → g (Fin.suc k)) f (proj₂ (∨-false (f (g Fin.zero)) _ h)) i
+
+-- A reflexive test finds every member of a list within that list.
+any-self : ∀ {a} {A : Set a} {f : A → A → Bool} → (∀ x → f x x ≡ Bool.true) →
+           ∀ xs → All (λ x → any (f x) xs ≡ Bool.true) xs
+any-self     h []       = []
+any-self {f = f} h (x ∷ xs) =
+  ≡-cong (_∨ any (f x) xs) (h x) ∷
+  All-map (λ {y} prf → ≡-trans (≡-cong (f y x ∨_) prf) (∨-true (f y x))) (any-self h xs)
+
+any-map : ∀ {a b} {A : Set a} {B : Set b} (f : B → Bool) (g : A → B) (xs : List A) →
+          any f (map g xs) ≡ any (λ x → f (g x)) xs
+any-map f g []       = ≡-refl
+any-map f g (x ∷ xs) = ≡-cong (f (g x) ∨_) (any-map f g xs)
+
+any-Any : ∀ {a} {A : Set a} (f : A → Bool) (xs : List A) →
+          any f xs ≡ Bool.true → Any (λ x → f x ≡ Bool.true) xs
+any-Any f (x ∷ xs) h with ∨-true-inv (f x) (any f xs) h
+... | inj₁ e = here e
+... | inj₂ e = there (any-Any f xs e)
+
+Any-All : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} {xs : List A} →
+          Any P xs → All Q xs → Any (λ x → P x × Q x) xs
+Any-All (here px) (qx ∷ _) = here (px , qx)
+Any-All (there a) (_ ∷ qs) = there (Any-All a qs)
+
+-- Eliminate an Any whose predicate is refutable.
+Any-contra : ∀ {a p b} {A : Set a} {P : A → Set p} {B : Set b} {xs : List A} →
+             (∀ {x} → P x → ⊥) → Any P xs → B
+Any-contra contra (here px) = ⊥-elim (contra px)
+Any-contra contra (there a) = Any-contra contra a
+
+map-All-cong : ∀ {a b} {A : Set a} {B : Set b} {f g : A → B} {xs : List A} →
+               All (λ x → f x ≡ g x) xs → map f xs ≡ map g xs
+map-All-cong []       = ≡-refl
+map-All-cong (h ∷ hs) = ≡-cong₂ _∷_ h (map-All-cong hs)
+
+-- Look up a Boolean membership witness in an All, given that the test is sound for equality.
+member-All : ∀ {a p} {A : Set a} {P : A → Set p} {eq : A → A → Bool} →
+             (∀ {x y} → eq x y ≡ Bool.true → x ≡ y) →
+             ∀ {x xs} → All P xs → any (eq x) xs ≡ Bool.true → P x
+member-All {eq = eq} sound {x} {y ∷ ys} (py ∷ pys) h with ∨-true-inv (eq x y) (any (eq x) ys) h
+... | inj₁ e = subst _ (≡-sym (sound e)) py
+... | inj₂ e = member-All sound pys e
+
+any-or : ∀ {a} {A : Set a} (f g : A → Bool) (xs : List A) →
+         any (λ x → f x ∨ g x) xs ≡ (any f xs ∨ any g xs)
+any-or f g []       = ≡-refl
+any-or f g (x ∷ xs) =
+  ≡-trans (≡-cong ((f x ∨ g x) ∨_) (any-or f g xs)) (∨-interchange (f x) (g x) (any f xs) (any g xs))
+
+-- Swapping the order of a doubly-nested search.
+any-comm : ∀ {a b} {A : Set a} {B : Set b} (h : A → B → Bool) (xs : List A) (ys : List B) →
+           any (λ x → any (h x) ys) xs ≡ any (λ y → any (λ x → h x y) xs) ys
+any-comm h []       ys = ≡-sym (any-false (universal (λ y → ≡-refl) ys))
+any-comm h (x ∷ xs) ys =
+  ≡-trans (≡-cong (any (h x) ys ∨_) (any-comm h xs ys))
+          (≡-sym (any-or (h x) (λ y → any (λ x' → h x' y) xs) ys))
+
+any-++ : ∀ {a} {A : Set a} (f : A → Bool) (xs ys : List A) →
+         any f (xs ++ ys) ≡ (any f xs ∨ any f ys)
+any-++ f []       ys = ≡-refl
+any-++ f (x ∷ xs) ys = ≡-trans (≡-cong (f x ∨_) (any-++ f xs ys)) (≡-sym (∨-assoc (f x) _ _))
+
+any-concat : ∀ {a} {A : Set a} (f : A → Bool) (xss : List (List A)) →
+             any f (concat xss) ≡ any (λ xs → any f xs) xss
+any-concat f []         = ≡-refl
+any-concat f (xs ∷ xss) =
+  ≡-trans (any-++ f xs (concat xss)) (≡-cong (any f xs ∨_) (any-concat f xss))
+
+-- Lists of lists compared up to reordering at both levels.
+_↭↭_ : ∀ {a} {A : Set a} → List (List A) → List (List A) → Set a
+_↭↭_ = H.Permutation _↭_
+
+private
+  pw-refl : ∀ {a} {A : Set a} (xss : List (List A)) → Pointwise _↭_ xss xss
+  pw-refl []         = []
+  pw-refl (xs ∷ xss) = ↭-refl ∷ pw-refl xss
+
+↭↭-refl : ∀ {a} {A : Set a} {xss : List (List A)} → xss ↭↭ xss
+↭↭-refl = H.refl (pw-refl _)
+
+↭↭-of-↭ : ∀ {a} {A : Set a} {xss yss : List (List A)} → xss ↭ yss → xss ↭↭ yss
+↭↭-of-↭ ↭.refl         = ↭↭-refl
+↭↭-of-↭ (↭.prep x p)   = H.prep ↭-refl (↭↭-of-↭ p)
+↭↭-of-↭ (↭.swap x y p) = H.swap ↭-refl ↭-refl (↭↭-of-↭ p)
+↭↭-of-↭ (↭.trans p q)  = H.trans (↭↭-of-↭ p) (↭↭-of-↭ q)
+
+concat-resp : ∀ {a} {A : Set a} {rss rss' : List (List A)} →
+              rss ↭↭ rss' → concat rss ↭ concat rss'
+concat-resp (H.refl [])       = ↭-refl
+concat-resp (H.refl (r ∷ pw)) = ++⁺ r (concat-resp (H.refl pw))
+concat-resp (H.prep r p)      = ++⁺ r (concat-resp p)
+concat-resp (H.swap {ys = ys} {x′ = x′} {y′ = y′} r₁ r₂ p) =
+  ↭-trans (++⁺ r₁ (++⁺ r₂ (concat-resp p))) (++-swap x′ y′ (concat ys))
+concat-resp (H.trans p q)     = ↭-trans (concat-resp p) (concat-resp q)
+
+map-proj₁-pair : ∀ {a b} {A : Set a} {B : Set b} (g : A → B) (xs : List A) →
+                 map proj₁ (map (λ x → (x , g x)) xs) ≡ xs
+map-proj₁-pair g []       = ≡-refl
+map-proj₁-pair g (x ∷ xs) = ≡-cong (x ∷_) (map-proj₁-pair g xs)
+
+-- The two halves of a partition recombine to the original, up to order.
+partition-↭ : ∀ {a} {A : Set a} (f : A → Bool) (xs : List A) →
+              (proj₁ (partitionᵇ f xs) ++ proj₂ (partitionᵇ f xs)) ↭ xs
+partition-↭ f []       = ↭-refl
+partition-↭ f (x ∷ xs) with f x
+... | Bool.true  = ↭.prep x (partition-↭ f xs)
+... | Bool.false =
+  ↭-trans (shift x (proj₁ (partitionᵇ f xs)) (proj₂ (partitionᵇ f xs)))
+          (↭.prep x (partition-↭ f xs))
+
+partition-All : ∀ {a p} {A : Set a} {P : A → Set p} (f : A → Bool) {xs : List A} → All P xs →
+                All P (proj₁ (partitionᵇ f xs)) × All P (proj₂ (partitionᵇ f xs))
+partition-All f [] = [] , []
+partition-All f (_∷_ {x} px pxs) with partition-All f pxs
+... | (a₁ , a₂) with f x
+...   | Bool.true  = px ∷ a₁ , a₂
+...   | Bool.false = a₁ , px ∷ a₂
+
+part₂-false : ∀ {a} {A : Set a} (f : A → Bool) (xs : List A) →
+              All (λ x → f x ≡ Bool.false) (proj₂ (partitionᵇ f xs))
+part₂-false f []       = []
+part₂-false f (x ∷ xs) with f x in eq
+... | Bool.true  = part₂-false f xs
+... | Bool.false = eq ∷ part₂-false f xs
+
+All-zip : ∀ {a p q r} {A : Set a} {P : A → Set p} {Q : A → Set q} {R : A → Set r} →
+          (∀ {x} → P x → Q x → R x) → ∀ {xs : List A} → All P xs → All Q xs → All R xs
+All-zip h []       []       = []
+All-zip h (p ∷ ps) (q ∷ qs) = h p q ∷ All-zip h ps qs
+
+AllPairs-map : ∀ {a r s} {A : Set a} {S : A → A → Set r} {S' : A → A → Set s} →
+               (∀ {x y} → S x y → S' x y) →
+               ∀ {xs : List A} → AllPairs S xs → AllPairs S' xs
+AllPairs-map h []         = []
+AllPairs-map h (px ∷ ps) = All-map h px ∷ AllPairs-map h ps
+
+AllPairs-zip : ∀ {a r s} {A : Set a} {S : A → A → Set r} {S' : A → A → Set s} →
+               ∀ {xs : List A} → AllPairs S xs → AllPairs S' xs →
+               AllPairs (λ x y → S x y × S' x y) xs
+AllPairs-zip []         []           = []
+AllPairs-zip (px ∷ ps) (px' ∷ ps') = All-zip _,_ px px' ∷ AllPairs-zip ps ps'
+
+-- Partitioning preserves pairwise relatedness, and every kept member relates to every dropped one.
+partition-AllPairs : ∀ {a r} {A : Set a} {S : A → A → Set r} (f : A → Bool) →
+                     (∀ {x y} → S x y → S y x) →
+                     ∀ {xs : List A} → AllPairs S xs →
+                     AllPairs S (proj₁ (partitionᵇ f xs))
+                     × AllPairs S (proj₂ (partitionᵇ f xs))
+                     × All (λ y → All (λ x → S x y) (proj₁ (partitionᵇ f xs)))
+                           (proj₂ (partitionᵇ f xs))
+partition-AllPairs f sym [] = [] , [] , []
+partition-AllPairs f sym (_∷_ {x} px ps) with partition-AllPairs f sym ps | partition-All f px
+... | (a₁ , a₂ , cross) | (px₁ , px₂) with f x
+...   | Bool.true  = px₁ ∷ a₁ , a₂ , All-zip (λ s c → s ∷ c) px₂ cross
+...   | Bool.false = a₁ , px₂ ∷ a₂ , All-map (λ s → sym s) px₁ ∷ cross
+
+any-filterᵇ : ∀ {a} {A : Set a} (f g : A → Bool) (xs : List A) →
+              any f (filterᵇ g xs) ≡ Bool.true → any f xs ≡ Bool.true
+any-filterᵇ f g (x ∷ xs) h with g x
+... | Bool.false = ≡-trans (≡-cong (f x ∨_) (any-filterᵇ f g xs h)) (∨-true (f x))
+... | Bool.true with ∨-true-inv (f x) (any f (filterᵇ g xs)) h
+...   | inj₁ e = ≡-cong (_∨ any f xs) e
+...   | inj₂ e = ≡-trans (≡-cong (f x ∨_) (any-filterᵇ f g xs e)) (∨-true (f x))
+
+filter-All : ∀ {a p} {A : Set a} {P : A → Set p} (f : A → Bool) {xs : List A} →
+             All P xs → All P (filterᵇ f xs)
+filter-All f []               = []
+filter-All f (_∷_ {x} px pxs) with f x
+... | Bool.true  = px ∷ filter-All f pxs
+... | Bool.false = filter-All f pxs
+
+filter-AllPairs : ∀ {a r} {A : Set a} {S : A → A → Set r} (f : A → Bool) {xs : List A} →
+                  AllPairs S xs → AllPairs S (filterᵇ f xs)
+filter-AllPairs f []               = []
+filter-AllPairs f (_∷_ {x} px ps) with f x
+... | Bool.true  = filter-All f px ∷ filter-AllPairs f ps
+... | Bool.false = filter-AllPairs f ps
+
+filter-all-true : ∀ {a} {A : Set a} {f : A → Bool} {xs : List A} →
+                  All (λ x → f x ≡ Bool.true) xs → filterᵇ f xs ≡ xs
+filter-all-true []              = ≡-refl
+filter-all-true (_∷_ {x} h hs) rewrite h = ≡-cong (x ∷_) (filter-all-true hs)
+
+AllPairs-++⁻ : ∀ {a r} {A : Set a} {S : A → A → Set r} (xs ys : List A) →
+               AllPairs S (xs ++ ys) →
+               AllPairs S xs × AllPairs S ys × All (λ x → All (S x) ys) xs
+AllPairs-++⁻ []       ys ps        = [] , ps , []
+AllPairs-++⁻ (x ∷ xs) ys (px ∷ ps) with AllPairs-++⁻ xs ys ps
+... | (a₁ , a₂ , cross) = (AllP.++⁻ˡ xs px ∷ a₁) , a₂ , (AllP.++⁻ʳ xs px ∷ cross)
+
+-- Pairwise relatedness respects permutation when the relation is symmetric.
+AllPairs-perm : ∀ {a r} {A : Set a} {S : A → A → Set r} →
+                (∀ {x y} → S x y → S y x) →
+                {xs ys : List A} → xs ↭ ys → AllPairs S xs → AllPairs S ys
+AllPairs-perm sym ↭.refl         ps                            = ps
+AllPairs-perm sym (↭.prep x p)   (px ∷ ps)                     =
+  All-resp-↭ p px ∷ AllPairs-perm sym p ps
+AllPairs-perm sym (↭.swap x y p) ((pxy ∷ pxs) ∷ (pys ∷ ps)) =
+  (sym pxy ∷ All-resp-↭ p pys) ∷ (All-resp-↭ p pxs ∷ AllPairs-perm sym p ps)
+AllPairs-perm sym (↭.trans p q)  ps                            =
+  AllPairs-perm sym q (AllPairs-perm sym p ps)
+
+-- On a pairwise-distinct list, filtering out a listed element removes exactly its one occurrence.
+filter-out-↭ : ∀ {a} {A : Set a} {eq : A → A → Bool} →
+               (∀ {x y} → eq x y ≡ Bool.true → x ≡ y) →
+               {x : A} {xs : List A} →
+               AllPairs (λ y z → eq y z ≡ Bool.false) xs →
+               any (eq x) xs ≡ Bool.true →
+               (x ∷ filterᵇ (λ y → not (eq x y)) xs) ↭ xs
+filter-out-↭ {eq = eq} sound {x} {y ∷ xs} (py ∷ ps) h with eq x y in e
+... | Bool.false = ↭-trans (↭.swap x y ↭.refl) (↭.prep y (filter-out-↭ sound ps h))
+... | Bool.true with sound e
+...   | ≡-refl =
+  ↭.prep x (↭-reflexive (filter-all-true (All-map (λ hz → ≡-cong not hz) py)))
+
+map-partition₁ : ∀ {a b} {A : Set a} {B : Set b} (h : A → B) (f : B → Bool) (xs : List A) →
+                 proj₁ (partitionᵇ f (map h xs)) ≡ map h (proj₁ (partitionᵇ (λ x → f (h x)) xs))
+map-partition₁ h f []       = ≡-refl
+map-partition₁ h f (x ∷ xs) with f (h x)
+... | Bool.true  = ≡-cong (h x ∷_) (map-partition₁ h f xs)
+... | Bool.false = map-partition₁ h f xs
+
+map-partition₂ : ∀ {a b} {A : Set a} {B : Set b} (h : A → B) (f : B → Bool) (xs : List A) →
+                 proj₂ (partitionᵇ f (map h xs)) ≡ map h (proj₂ (partitionᵇ (λ x → f (h x)) xs))
+map-partition₂ h f []       = ≡-refl
+map-partition₂ h f (x ∷ xs) with f (h x)
+... | Bool.true  = map-partition₂ h f xs
+... | Bool.false = ≡-cong (h x ∷_) (map-partition₂ h f xs)
diff --git a/agda/src/lists.agda b/agda/src/lists.agda
index f4877af8..62349b2a 100644
--- a/agda/src/lists.agda
+++ b/agda/src/lists.agda
@@ -53,7 +53,7 @@ module _ (A : 𝒞.obj) where
       𝒞P.prod-m (𝒞.id _) (transport {m} {o} _)
     ≈⟨ 𝒞P.prod-m-cong (𝒞.≈-sym 𝒞.id-left) (ListF .fmor-comp ⟪ succ-injective eq1 ⟫ ⟪ succ-injective eq2 ⟫) ⟩
       𝒞P.prod-m (𝒞.id _ 𝒞.∘ 𝒞.id _) (transport (succ-injective eq1) 𝒞.∘ transport (succ-injective eq2))
-    ≈⟨ 𝒞P.pair-functorial _ _ _ _ ⟩
+    ≈⟨ 𝒞P.prod-m-comp _ _ _ _ ⟩
       𝒞P.prod-m (𝒞.id _) (transport (succ-injective eq1)) 𝒞.∘ 𝒞P.prod-m (𝒞.id _) (transport (succ-injective eq2))
     ∎
     where open ≈-Reasoning 𝒞.isEquiv
@@ -114,7 +114,7 @@ module _ (A : 𝒞.obj) where
           cons-m 𝒞.∘ 𝒞P.prod-m (𝒞.id _ 𝒞.∘ 𝒞.id _) (𝒞.id _ 𝒞.∘ α .transf m)
         ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (𝒞P.prod-m-cong 𝒞.≈-refl (α .natural {m} {n} ⟪ succ-injective eq ⟫)) ⟩
           cons-m 𝒞.∘ 𝒞P.prod-m (𝒞.id _ 𝒞.∘ 𝒞.id _) (α .transf n 𝒞.∘ transport (succ-injective eq))
-        ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (𝒞P.pair-functorial _ _ _ _) ⟩
+        ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (𝒞P.prod-m-comp _ _ _ _) ⟩
           cons-m 𝒞.∘ (𝒞P.prod-m (𝒞.id A) (α .transf n) 𝒞.∘ 𝒞P.prod-m (𝒞.id A) (transport {m} {n} _))
         ≈˘⟨ 𝒞.assoc _ _ _ ⟩
          (cons-m 𝒞.∘ 𝒞P.prod-m (𝒞.id A) (α .transf n)) 𝒞.∘ 𝒞P.prod-m (𝒞.id A) (transport (succ-injective eq))
diff --git a/agda/src/matrix-embedding-semimod.agda b/agda/src/matrix-embedding-semimod.agda
index 90c1df32..aae013d0 100644
--- a/agda/src/matrix-embedding-semimod.agda
+++ b/agda/src/matrix-embedding-semimod.agda
@@ -56,10 +56,10 @@ private
   S.trans (endo-comm f g x₁) (g .func-resp-≈ (f .func-resp-≈ x₁≈x₂))
 
 open import matrix-embedding SemiMod.cmon-enriched SemiMod.biproduct 𝟘 𝟘-initial 𝟘-terminal 𝕀 (λ {f} {g} → ∘-comm {f} {g}) public
-  renaming (S to End𝕀)
 
--- The embedding factors through the self-dual semimodules: each free object X^ n is (on the nose) the free
--- self-dual semimodule S^ n.
+-- The embedding factors through the self-dual semimodules: each free object X^ n is isomorphic to the free
+-- self-dual semimodule S^ n. The two differ only by the unit law at width one, where S^ 1 is 𝕀 and X^ 1 is
+-- 𝕀 ⊕ 𝟘.
 import sd-semimodule
 open import Data.Nat using (ℕ; zero; suc)
 open import functor using (Functor)
@@ -67,14 +67,17 @@ open import functor using (Functor)
 module SDSemiMod = sd-semimodule S
 open SDSemiMod using (S^_)
 open import prop-setoid using (module ≈-Reasoning)
+open import commutative-semiring using (_⇒h_)
 
 private
   module C = Category SemiMod.cat
   open C.Iso
 
-  X^≅S^ : ∀ n → C.Iso (X^ n) (SDSemiMod.SelfDual.obj (S^ n))
-  X^≅S^ zero = C.Iso-refl
-  X^≅S^ (suc n) = SDSemiMod.⊕-iso C.Iso-refl (X^≅S^ n)
+-- The free object of width n, as a self-dual semimodule.
+X^≅S^ : ∀ n → C.Iso (X^ n) (SDSemiMod.SelfDual.obj (S^ n))
+X^≅S^ zero = C.Iso-refl
+X^≅S^ (suc zero) = SemiMod.⊕-runit-iso
+X^≅S^ (suc (suc n)) = SDSemiMod.⊕-iso C.Iso-refl (X^≅S^ (suc n))
 
 embed : Functor Mat.cat SDSemiMod.cat
 embed .Functor.fobj n = S^ n
@@ -111,3 +114,42 @@ embed .Functor.fmor-comp {x} {y} {z} f g = begin
     (X^≅S^ z .fwd C.∘ (F .Functor.fmor f C.∘ X^≅S^ y .bwd)) C.∘ (X^≅S^ y .fwd C.∘ (F .Functor.fmor g C.∘ X^≅S^ x .bwd))
   ∎
   where open ≈-Reasoning C.isEquiv
+
+------------------------------------------------------------------------------
+-- The scalars are the 𝕀-endomorphisms, in both directions: a scalar acts by multiplication, and an
+-- endomorphism is recovered as its value at ι. Packaging both as semiring homomorphisms lets the
+-- generic embedding be read at S rather than at EndX.
+
+mult-endo : S.Carrier → SemiMod._⇒_ 𝕀 𝕀
+mult-endo s .SemiMod._⇒_.*→* .prop-setoid._⇒_.func y = y S.· s
+mult-endo s .SemiMod._⇒_.*→* .prop-setoid._⇒_.func-resp-≈ e = S.·-cong e S.refl
+mult-endo s .SemiMod._⇒_.preserve-ze = S.ε-annihilₗ
+mult-endo s .SemiMod._⇒_.preserve-+ = S.·-+-distribᵣ
+mult-endo s .SemiMod._⇒_.preserve-· = S.·-assoc
+
+into : S ⇒h EndX
+into ._⇒h_.f = mult-endo
+into ._⇒h_.f-cong e .SemiMod._≈m_.*≈* .prop-setoid._≃m_.func-eq y≈y' = S.·-cong y≈y' e
+into ._⇒h_.f-+ .SemiMod._≈m_.*≈* .prop-setoid._≃m_.func-eq y≈y' =
+  S.trans (S.·-cong y≈y' S.refl) S.·-+-distribₗ
+into ._⇒h_.f-· .SemiMod._≈m_.*≈* .prop-setoid._≃m_.func-eq y≈y' =
+  S.trans (S.·-cong y≈y' S.refl)
+    (S.trans (S.·-cong S.refl S.·-comm) (S.sym (S.·-assoc)))
+into ._⇒h_.f-ε .SemiMod._≈m_.*≈* .prop-setoid._≃m_.func-eq y≈y' =
+  S.trans (S.·-cong y≈y' S.refl) S.ε-annihilᵣ
+into ._⇒h_.f-ι .SemiMod._≈m_.*≈* .prop-setoid._≃m_.func-eq y≈y' =
+  S.trans (S.·-cong y≈y' S.refl) (S.trans S.·-comm S.·-lunit)
+
+endo-scalar : SemiMod._⇒_ 𝕀 𝕀 → S.Carrier
+endo-scalar h = h .SemiMod._⇒_.*→* .prop-setoid._⇒_.func S.ι
+
+outof : EndX ⇒h S
+outof ._⇒h_.f = endo-scalar
+outof ._⇒h_.f-cong e = e .SemiMod._≈m_.*≈* .prop-setoid._≃m_.func-eq S.refl
+outof ._⇒h_.f-+ = S.refl
+outof ._⇒h_.f-· {a} {b} =
+  S.trans (scalar-endo a (endo-scalar b)) S.·-comm
+outof ._⇒h_.f-ε = S.refl
+outof ._⇒h_.f-ι = S.refl
+
+open AtSemiring S into outof public using (mat→mor; mor→mat; module MatS)
diff --git a/agda/src/matrix-embedding.agda b/agda/src/matrix-embedding.agda
index 6c4e0f17..b8898492 100644
--- a/agda/src/matrix-embedding.agda
+++ b/agda/src/matrix-embedding.agda
@@ -7,8 +7,9 @@ open import categories using (Category; IsInitial; IsTerminal; HasInitial; HasTe
 open import setoid-cat using (SetoidCat)
 open import cmon-enriched using (CMonEnriched; Biproduct; biproducts→products; biproduct-iso)
 open import commutative-monoid using (CommutativeMonoid; _=[_]>_)
-open import commutative-semiring using (CommutativeSemiring)
-open import functor using (Functor)
+open import commutative-semiring using (CommutativeSemiring; _⇒h_)
+open import functor using (Functor; _∘F_)
+import matrix-functor
 
 -- Suppose 𝒞 a biproduct category with a chosen object X whose endomorphism hom 𝒞(X, X) is commutative.
 -- Then 𝒞(X, X) is a commutative semiring (composition as multiplication, addition of morphisms as
@@ -48,13 +49,13 @@ module matrix-embedding
   ∘-monoid .CommutativeMonoid.+-assoc = assoc _ _ _
   ∘-monoid .CommutativeMonoid.+-comm = ∘-comm
 
-  S : CommutativeSemiring A
-  S .CommutativeSemiring.additive = homCM X X
-  S .CommutativeSemiring.multiplicative = ∘-monoid
-  S .CommutativeSemiring.·-+-distribₗ {x} {y} {z} = comp-bilinear₂ x y z
-  S .CommutativeSemiring.ε-annihilₗ {x} = comp-bilinear-ε₁ x
+  EndX : CommutativeSemiring A
+  EndX .CommutativeSemiring.additive = homCM X X
+  EndX .CommutativeSemiring.multiplicative = ∘-monoid
+  EndX .CommutativeSemiring.·-+-distribₗ {x} {y} {z} = comp-bilinear₂ x y z
+  EndX .CommutativeSemiring.ε-annihilₗ {x} = comp-bilinear-ε₁ x
 
-  module CS = CommutativeSemiring S
+  module CS = CommutativeSemiring EndX
   open CS using () renaming (_+_ to _+ₛ_; _·_ to _·ₛ_)
 
   -- 𝒞(X, X) IS the scalar carrier, so the embedding's scalar map is the identity and the
@@ -79,7 +80,7 @@ module matrix-embedding
   scalar⁻¹∘scalar≈id = scalar-iso .bwd∘fwd≈id
 
   import matrix
-  module Mat = matrix.Mat S
+  module Mat = matrix.Mat EndX
   open Mat using (Matrix) public
 
   module _ where
@@ -367,7 +368,7 @@ module matrix-embedding
       scalar .func (M i j)
     ∎ where open ≈-Reasoning isEquiv
 
-  -- F : Mat(S) → MatRep(𝒞, X), the "assemble matrix from entries" direction.
+  -- F : Mat(End X) → MatRep(𝒞, X), the "assemble matrix from entries" direction.
   F : Functor Mat.cat cat
   F .fobj n = n
   F .fmor = F-fmor
@@ -399,7 +400,7 @@ module matrix-embedding
       π {k} i ∘ ((F .fmor M ∘ F .fmor N) ∘ ι {m} j)
     ∎) where open ≈-Reasoning isEquiv
 
-  -- F⁻¹ : MatRep(𝒞, X) → Mat(S), the "extract matrix of entries" direction.
+  -- F⁻¹ : MatRep(𝒞, X) → Mat(End X), the "extract matrix of entries" direction.
   F⁻¹ : Functor cat Mat.cat
   F⁻¹ .fobj n = n
   F⁻¹ .fmor {m} {n} f i j = scalar⁻¹ .func (entry {m} {n} f i j)
@@ -413,7 +414,7 @@ module matrix-embedding
       scalar⁻¹ .func (scalar .func (Mat.e i j))
     ≈⟨ scalar⁻¹∘scalar≈id .func-eq (Setoid.refl A) ⟩
       Mat.e i j
-    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence S)
+    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence EndX)
   F⁻¹ .fmor-comp {m} {n} {k} g f i j =
     begin
       scalar⁻¹ .func (entry {m} {k} (g ∘ f) i j)
@@ -429,7 +430,7 @@ module matrix-embedding
         (scalar .func (Mat.Σ {n} (λ l → scalar⁻¹ .func (entry {n} {k} g i l) ·ₛ scalar⁻¹ .func (entry {m} {n} f l j))))
     ≈⟨ scalar⁻¹∘scalar≈id .func-eq (Setoid.refl A) ⟩
       Mat.Σ {n} (λ l → scalar⁻¹ .func (entry {n} {k} g i l) ·ₛ scalar⁻¹ .func (entry {m} {n} f l j))
-    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence S)
+    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence EndX)
 
   F⁻¹∘F : ∀ {m n} (M : Matrix n m) → (F⁻¹ .fmor (F .fmor M)) Mat.≈ₘ M
   F⁻¹∘F {m} {n} M i j =
@@ -439,7 +440,7 @@ module matrix-embedding
       scalar⁻¹ .func (scalar .func (M i j))
     ≈⟨ scalar⁻¹∘scalar≈id .func-eq (Setoid.refl A) ⟩
       M i j
-    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence S)
+    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence EndX)
 
   F∘F⁻¹ : ∀ {m n} (f : X^ m ⇒ X^ n) → F .fmor {m} {n} (F⁻¹ .fmor {m} {n} f) ≈ f
   F∘F⁻¹ {m} {n} f = entry-ext {m} {n} (λ i j →
@@ -481,7 +482,7 @@ module matrix-embedding
       π {n} i ∘ ((F .fmor {m} {n} M +m F .fmor {m} {n} N) ∘ ι {m} j)
     ∎) where open ≈-Reasoning isEquiv
 
-  -- Morphisms in Mat(S) are determined by their F-images.
+  -- Morphisms in Mat(End X) are determined by their F-images.
   F-faithful : ∀ {m n} {M N : Matrix n m} → F .fmor {m} {n} M ≈ F .fmor {m} {n} N → M Mat.≈ₘ N
   F-faithful {m} {n} {M} {N} eq i j =
     begin
@@ -492,7 +493,7 @@ module matrix-embedding
       scalar⁻¹ .func (entry {m} {n} (F .fmor {m} {n} N) i j)
     ≈⟨ F⁻¹∘F {m} {n} N i j ⟩
       N i j
-    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence S)
+    ∎ where open ≈-Reasoning (CommutativeSemiring.isEquivalence EndX)
 
   F⁻¹-εₘ : ∀ {m n} → (F⁻¹ .fmor {m} {n} (εm {X^ m} {X^ n})) Mat.≈ₘ (Mat.εₘ {n} {m})
   F⁻¹-εₘ {m} {n} = F-faithful {m} {n}
@@ -628,3 +629,28 @@ module matrix-embedding
 
   𝓕-preserve-products : preserve-chosen-products 𝓕 (biproducts→products cmon biproduct) (biproducts→products CM BP)
   𝓕-preserve-products {m} {n} = biproduct-iso CM (biproduct𝒞 m n) (BP (X^ m) (X^ n))
+
+  ------------------------------------------------------------------------------
+  -- The embedding for a semiring presented as End X up to isomorphism. Callers hold a semiring S
+  -- of their own rather than End X itself, so matrices over S reach 𝒞 by relabelling entries along
+  -- the isomorphism and then embedding. Both directions are composites of functors, so their laws
+  -- are inherited rather than restated.
+
+  module AtSemiring
+    {o' e'} {B : Setoid o' e'} (S : CommutativeSemiring B)
+    (into : S ⇒h EndX) (outof : EndX ⇒h S)
+    where
+
+    module MatS = matrix.Mat S
+
+    private
+      module In  = matrix-functor.Strict into
+      module Out = matrix-functor.Strict outof
+
+    -- A matrix over S as a morphism between the free objects on its dimensions.
+    mat→mor : Functor MatS.cat cat
+    mat→mor = F ∘F In.functor
+
+    -- And back: the matrix of entries of such a morphism.
+    mor→mat : Functor cat MatS.cat
+    mor→mat = Out.functor ∘F F⁻¹
diff --git a/agda/src/matrix-functor.agda b/agda/src/matrix-functor.agda
index a08cb3b0..333aea4f 100644
--- a/agda/src/matrix-functor.agda
+++ b/agda/src/matrix-functor.agda
@@ -10,7 +10,9 @@ open import Level using (Level)
 open import Data.Nat using (ℕ)
 open import Data.Fin using (Fin; zero; suc)
 open import prop-setoid using (Setoid)
+open import categories using (Category)
 open import commutative-semiring using (CommutativeSemiring; _⇒ˡ_; _⇒h_)
+open import functor using (Functor)
 import commutative-monoid
 import matrix
 
@@ -72,6 +74,15 @@ module Strict
         E (M Mat-S.∘ N) Mat-T.≈ₘ (E M Mat-T.∘ E N)
   E-∘ M N i j = T.trans (f-Σ (λ l → M i l S.· N l j)) (Σ-preserves (λ l → f-· {M i l} {N l j}))
 
+  -- The entrywise action packaged as a functor, so that composing it with an embedding of matrices
+  -- into a category inherits that embedding's laws instead of restating them.
+  functor : Functor Mat-S.cat Mat-T.cat
+  functor .Functor.fobj n = n
+  functor .Functor.fmor = E
+  functor .Functor.fmor-cong = E-cong
+  functor .Functor.fmor-id = E-I
+  functor .Functor.fmor-comp = E-∘
+
 -- A lax homomorphism into an additively idempotent semiring acts laxly: composition is preserved
 -- up to the additive preorder.
 module Lax
diff --git a/agda/src/matrix.agda b/agda/src/matrix.agda
index 4a2445d5..0e9a1b50 100644
--- a/agda/src/matrix.agda
+++ b/agda/src/matrix.agda
@@ -4,6 +4,7 @@ module matrix where
 
 open import Level using (0ℓ)
 open import prop-setoid using (Setoid)
+import Relation.Binary.PropositionalEquality as ≡
 open import commutative-semiring using (CommutativeSemiring)
 
 -- Matrices over a commutative semiring S. (Commutativity means the dot product is commutative, which means
@@ -82,6 +83,11 @@ module Mat {o ℓ} {A : Setoid o ℓ} (S : CommutativeSemiring A) where
   Σ-cong : ∀ {n} {f g : Fin n → Carrier} → (∀ i → f i ≈ g i) → Σ {n} f ≈ Σ {n} g
   Σ-cong = +-to-Σ.Σ-preserves _≈_ refl +-cong
 
+  -- Equality version; not an instance of Σ-preserves, which takes Prop-valued relations.
+  Σ-cong-≡ : ∀ {n} {f g : Fin n → Carrier} → (∀ i → f i ≡.≡ g i) → Σ {n} f ≡.≡ Σ {n} g
+  Σ-cong-≡ {zero}  p = ≡.refl
+  Σ-cong-≡ {suc n} p = ≡.cong₂ _+_ (p zero) (Σ-cong-≡ {n} (λ i → p (suc i)))
+
   -- Kronecker delta is symmetric.
   e-sym : ∀ {n} (i j : Fin n) → e i j ≈ e j i
   e-sym zero zero = refl
@@ -340,6 +346,14 @@ module Mat {o ℓ} {A : Setoid o ℓ} (S : CommutativeSemiring A) where
   biproduct m n .Biproduct.zero-2 = zero-2 m n
   biproduct m n .Biproduct.id-+ = id-+ m n
 
+  -- Copairing of blocks: [ f , g ] as a matrix into the summed domain.
+  _∥_ : ∀ {m n k} → Matrix k m → Matrix k n → Matrix k (m +ℕ n)
+  _∥_ {m} {n} f g = Biproduct.copair (biproduct m n) f g
+
+  -- A scalar as a 1-by-1 block.
+  block : Carrier → Matrix 1 1
+  block c _ _ = c
+
   -- Vector concatenation, a monoid homomorphism preserving pointwise additive structure.
   concat : ∀ {x y} → Vec x → Vec y → Vec (x +ℕ y)
   concat {zero} u v = v
@@ -398,3 +412,366 @@ module Mat {o ℓ} {A : Setoid o ℓ} (S : CommutativeSemiring A) where
   Σ-p₂ {zero} w i = Σ-unit i w
   Σ-p₂ {suc x} w i =
     trans (+-cong ε-annihilₗ refl) (trans +-lunit (Σ-p₂ {x} (λ j → w (suc j)) i))
+
+-- Additional (ordered) structures that might be present on S.
+module _ {A : Setoid 0ℓ 0ℓ} (S : CommutativeSemiring A) where
+  open import basics using (IsPreorder; IsJoin; IsBottom; IsMeet; IsTop; module Disjoint)
+  open import preorder using (Preorder)
+  open import Data.Nat using (ℕ; zero; suc)
+  open import Data.Fin using (Fin; zero; suc)
+  open import join-semilattice using (JoinSemilattice)
+  open import meet-semilattice using (MeetSemilattice)
+
+  -- Pointwise lifts to Vec n.
+  module vec (P : Preorder) (n : ℕ) where
+    open Preorder
+    open JoinSemilattice
+    open MeetSemilattice
+
+    preorder : Preorder
+    preorder .Carrier = Fin n → P .Carrier
+    preorder ._≤_ u v = ∀ i → P ._≤_ (u i) (v i)
+    preorder .≤-isPreorder .IsPreorder.refl i = IsPreorder.refl (P .≤-isPreorder)
+    preorder .≤-isPreorder .IsPreorder.trans u≤v v≤w i = IsPreorder.trans (P .≤-isPreorder) (u≤v i) (v≤w i)
+
+    join : JoinSemilattice P → JoinSemilattice preorder
+    join J ._∨_ u v i = J ._∨_ (u i) (v i)
+    join J .⊥ _ = J .⊥
+    join J .∨-isJoin .IsJoin.inl i = IsJoin.inl (J .∨-isJoin)
+    join J .∨-isJoin .IsJoin.inr i = IsJoin.inr (J .∨-isJoin)
+    join J .∨-isJoin .IsJoin.[_,_] u≤w v≤w i = IsJoin.[_,_] (J .∨-isJoin) (u≤w i) (v≤w i)
+    join J .⊥-isBottom .IsBottom.≤-bottom i = IsBottom.≤-bottom (J .⊥-isBottom)
+
+    meet : MeetSemilattice P → MeetSemilattice preorder
+    meet M ._∧_ u v i = M ._∧_ (u i) (v i)
+    meet M .⊤ _ = M .⊤
+    meet M .∧-isMeet .IsMeet.π₁ i = IsMeet.π₁ (M .∧-isMeet)
+    meet M .∧-isMeet .IsMeet.π₂ i = IsMeet.π₂ (M .∧-isMeet)
+    meet M .∧-isMeet .IsMeet.⟨_,_⟩ x≤y x≤z i = IsMeet.⟨_,_⟩ (M .∧-isMeet) (x≤y i) (x≤z i)
+    meet M .⊤-isTop .IsTop.≤-top i = IsTop.≤-top (M .⊤-isTop)
+
+  open Mat S
+    renaming (
+      _·_ to _∧_;
+      _+_ to _∨_;
+      ε to ⊥;
+      ι to ⊤;
+      ·-cong to ∧-cong;
+      ·-assoc to ∧-assoc;
+      ·-comm to ∧-comm;
+      ·-lunit to ∧-lunit;
+      +-cong to ∨-cong;
+      +-assoc to ∨-assoc;
+      +-comm to ∨-comm;
+      +-lunit to ∨-lunit;
+      ·-+-distribₗ to ∧-∨-distribₗ;
+      ·-+-distribᵣ to ∧-∨-distribᵣ;
+      ε-annihilₗ to ⊥-annihilₗ;
+      ε-annihilᵣ to ⊥-annihilᵣ
+    )
+
+  module Join
+    (_≤_          : Carrier → Carrier → Prop _)
+    (≤-isPreorder : IsPreorder _≤_)
+    (∨-isJoin     : IsJoin ≤-isPreorder _∨_)
+    (⊥-isBottom   : IsBottom ≤-isPreorder ⊥)
+    (≈→≤          : ∀ {x y} → x ≈ y → x ≤ y)
+    where
+
+    open IsPreorder ≤-isPreorder public using (_≃_) renaming (refl to ≤-refl; trans to ≤-trans)
+    open import prop public using (proj₁; proj₂)
+
+    preorder : Preorder
+    preorder .Preorder.Carrier = Carrier
+    preorder .Preorder._≤_ = _≤_
+    preorder .Preorder.≤-isPreorder = ≤-isPreorder
+
+    joins : JoinSemilattice preorder
+    joins .JoinSemilattice._∨_ = _∨_
+    joins .JoinSemilattice.⊥ = ⊥
+    joins .JoinSemilattice.∨-isJoin = ∨-isJoin
+    joins .JoinSemilattice.⊥-isBottom = ⊥-isBottom
+
+    -- Iterated-∨ laws (Σ as iterated +). Σ-ub mirrors inl/inr, Σ-lub mirrors [_,_].
+    Σ-ub : ∀ {n} (f : Fin n → Carrier) (i : Fin n) → f i ≤ Σ f
+    Σ-ub f zero = IsJoin.inl ∨-isJoin
+    Σ-ub f (suc i) = ≤-trans (Σ-ub (λ j → f (suc j)) i) (IsJoin.inr ∨-isJoin)
+
+    Σ-lub : ∀ {n} {z} (f : Fin n → Carrier) → (∀ j → f j ≤ z) → Σ f ≤ z
+    Σ-lub {zero} _ _ = IsBottom.≤-bottom ⊥-isBottom
+    Σ-lub {suc n} f h = IsJoin.[_,_] ∨-isJoin (h zero) (Σ-lub (λ j → f (suc j)) (λ j → h (suc j)))
+
+    Σ-mono : ∀ {n} {f g : Fin n → Carrier} → (∀ j → f j ≤ g j) → Σ f ≤ Σ g
+    Σ-mono = +-to-Σ.Σ-preserves _≤_ ≤-refl (IsJoin.mono ∨-isJoin)
+
+    -- Pointwise lift of _≤_ and _≃_ to Vec, from vec.preorder.
+    module _ {n : ℕ} where
+      open Preorder (vec.preorder preorder n) using () renaming (_≤_ to _≤^_; _≃_ to _≃^_) public
+
+    -- Iterated-∨ at Vec level.
+    Σ^-ub : ∀ {m n} (g : Fin m → Vec n) (i : Fin m) → g i ≤^ Σ^ g
+    Σ^-ub g i j = Σ-ub (λ k → g k j) i
+
+    Σ^-lub : ∀ {m n} {z : Vec n} (g : Fin m → Vec n) → (∀ i → g i ≤^ z) → Σ^ g ≤^ z
+    Σ^-lub g h j = Σ-lub (λ k → g k j) (λ i → h i j)
+
+    Σ^-mono : ∀ {m n} {g g' : Fin m → Vec n} → (∀ i → g i ≤^ g' i) → Σ^ g ≤^ Σ^ g'
+    Σ^-mono h j = Σ-mono (λ i → h i j)
+
+    -- Basis decomposition of a join-preserving, scale-linear map. Scale-linearity is an explicit hypothesis
+    -- because f's interaction with scalar · isn't otherwise constrained (like it is in Two). Currently unused,
+    -- but nice because it shows that because every such f is determined by its action on basis vectors, we
+    -- can think of it as a "join of atomic slices".
+    module _ {m n}
+      (f       : Vec m → Vec n)
+      (f-mono  : ∀ {u v} → u ≤^ v → f u ≤^ f v)
+      (f-⊥     : ∀ j → f (λ _ → ⊥) j ≤ ⊥)
+      (f-∨     : ∀ u v j → f (λ k → u k ∨ v k) j ≤ (f u j ∨ f v j))
+      (f-scale : ∀ a v j → f (scale a v) j ≃ scale a (f v) j)
+      where
+
+      -- f preserves and reflects Σ^.
+      f-Σ^ : ∀ {k} (g : Fin k → Vec m) → f (Σ^ g) ≃^ Σ^ (λ i → f (g i))
+      f-Σ^ {zero} g .proj₁ j = f-⊥ j
+      f-Σ^ {suc k} g .proj₁ j =
+        ≤-trans (f-∨ (g zero) (Σ^ (λ i → g (suc i))) j)
+                (IsJoin.mono ∨-isJoin ≤-refl (f-Σ^ (λ i → g (suc i)) .proj₁ j))
+      f-Σ^ g .proj₂ = Σ^-lub _ (λ i → f-mono (Σ^-ub g i))
+
+      basis-decomp : ∀ (v : Vec m) j → f v j ≃ Σ^ (λ i → scale (v i) (f (e i))) j
+      basis-decomp v j .proj₁ =
+        ≤-trans (f-mono (λ k → ≈→≤ (Σ^-basis v k)) j)
+          (≤-trans (f-Σ^ (λ i → scale (v i) (e i)) .proj₁ j)
+                   (Σ-mono (λ i → f-scale (v i) (e i) j .proj₁)))
+      basis-decomp v j .proj₂ =
+        ≤-trans (Σ-mono (λ i → f-scale (v i) (e i) j .proj₂))
+          (≤-trans (f-Σ^ (λ i → scale (v i) (e i)) .proj₂ j)
+                   (f-mono (λ k → ≈→≤ (sym (Σ^-basis v k))) j))
+
+  -- A commutative semiring is exactly a (bounded) distributive lattice when both ∨ (= +) and ∧ (= ·) are
+  -- idempotent and ⊤ (= 1) is the additive top. The (shared) induced order is x ≤ y iff x ∨ y ≈ y.
+  module DistributiveLattice
+    (∨-idem    : ∀ {x} → x ∨ x ≈ x)
+    (∧-idem    : ∀ {x} → x ∧ x ≈ x)
+    (⊤-add-top : ∀ {x} → ⊤ ∨ x ≈ ⊤)
+    where
+
+    open import prop using (proj₁; proj₂)
+
+    _≤_ : Carrier → Carrier → Prop _
+    x ≤ y = x ∨ y ≈ y
+
+    ≤-isPreorder : IsPreorder _≤_
+    ≤-isPreorder .IsPreorder.refl = ∨-idem
+    ≤-isPreorder .IsPreorder.trans {x} {y} {z} x≤y y≤z =
+      trans (∨-cong refl (sym y≤z)) (trans (sym ∨-assoc) (trans (∨-cong x≤y refl) y≤z))
+
+    ≈→≤ : ∀ {x y} → x ≈ y → x ≤ y
+    ≈→≤ x≈y = trans (∨-cong x≈y refl) ∨-idem
+
+    ∨-isJoin : IsJoin ≤-isPreorder _∨_
+    ∨-isJoin .IsJoin.inl = trans (sym ∨-assoc) (∨-cong ∨-idem refl)
+    ∨-isJoin .IsJoin.inr =
+      trans (∨-cong refl ∨-comm) (trans (sym ∨-assoc) (trans (∨-cong ∨-idem refl) ∨-comm))
+    ∨-isJoin .IsJoin.[_,_] x≤z y≤z = trans ∨-assoc (trans (∨-cong refl y≤z) x≤z)
+
+    ⊥-isBottom : IsBottom ≤-isPreorder ⊥
+    ⊥-isBottom .IsBottom.≤-bottom = ∨-lunit
+
+    ⊤-isTop : IsTop ≤-isPreorder ⊤
+    ⊤-isTop .IsTop.≤-top = trans ∨-comm ⊤-add-top
+
+    ∨-∧-absorption : ∀ {a b} → a ∨ (a ∧ b) ≈ a
+    ∨-∧-absorption {a} {b} =
+      trans (∨-cong (trans (sym ∧-lunit) ∧-comm) refl)
+            (trans (sym ∧-∨-distribₗ) (trans (∧-cong refl ⊤-add-top) (trans ∧-comm ∧-lunit)))
+
+    ∧-monoʳ : ∀ {a b c} → a ≤ b → c ∧ a ≤ c ∧ b
+    ∧-monoʳ a≤b = trans (sym ∧-∨-distribₗ) (∧-cong refl a≤b)
+
+    ∧-monoˡ : ∀ {a b c} → a ≤ b → a ∧ c ≤ b ∧ c
+    ∧-monoˡ a≤b = trans (sym ∧-∨-distribᵣ) (∧-cong a≤b refl)
+
+    ∧-isMeet : IsMeet ≤-isPreorder _∧_
+    ∧-isMeet .IsMeet.π₁ = trans ∨-comm ∨-∧-absorption
+    ∧-isMeet .IsMeet.π₂ = trans (∨-cong ∧-comm refl) (trans ∨-comm ∨-∧-absorption)
+    ∧-isMeet .IsMeet.⟨_,_⟩ {x} {y} {z} x≤y x≤z =
+      ≤-isPreorder .IsPreorder.trans
+        (trans (∨-cong (sym ∧-idem) refl) (∧-monoʳ x≤z)) (∧-monoˡ x≤y)
+
+    ∧-∨-distrib : ∀ {x y z} → x ∧ (y ∨ z) ≤ (x ∧ y) ∨ (x ∧ z)
+    ∧-∨-distrib = ≈→≤ ∧-∨-distribₗ
+
+    ∨-∧-distribₗ : ∀ {a b c} → (a ∨ b) ∧ (a ∨ c) ≈ a ∨ (b ∧ c)
+    ∨-∧-distribₗ {a} {b} {c} =
+      trans ∧-∨-distribᵣ
+            (trans (∨-cong ∧-∨-distribₗ ∧-∨-distribₗ)
+                  (trans (∨-cong (∨-cong ∧-idem refl) (∨-cong ∧-comm refl))
+                          (trans (∨-cong ∨-∧-absorption refl)
+                                 (trans (sym ∨-assoc) (∨-cong ∨-∧-absorption refl)))))
+
+    open import conjugate using (Obj; _⇒c_)
+    open _⇒c_
+
+    open Join _≤_ ≤-isPreorder ∨-isJoin ⊥-isBottom ≈→≤ using (Σ-mono; Σ-ub; Σ-lub) public
+    open IsPreorder ≤-isPreorder using () renaming (refl to ≤-refl; trans to ≤-trans)
+    open IsMeet ∧-isMeet using () renaming (mono to ∧-mono)
+
+    DistribLattice : ℕ → Obj
+    DistribLattice n .Obj.carrier .Preorder.Carrier = Fin n → Carrier
+    DistribLattice n .Obj.carrier .Preorder._≤_ u v = ∀ i → u i ≤ v i
+    DistribLattice n .Obj.carrier .Preorder.≤-isPreorder .IsPreorder.refl i = ≤-refl
+    DistribLattice n .Obj.carrier .Preorder.≤-isPreorder .IsPreorder.trans u≤v v≤w i =
+      ≤-trans (u≤v i) (v≤w i)
+    DistribLattice n .Obj.meets .MeetSemilattice._∧_ u v i = u i ∧ v i
+    DistribLattice n .Obj.meets .MeetSemilattice.⊤ _ = ⊤
+    DistribLattice n .Obj.meets .MeetSemilattice.∧-isMeet .IsMeet.π₁ i = IsMeet.π₁ ∧-isMeet
+    DistribLattice n .Obj.meets .MeetSemilattice.∧-isMeet .IsMeet.π₂ i = IsMeet.π₂ ∧-isMeet
+    DistribLattice n .Obj.meets .MeetSemilattice.∧-isMeet .IsMeet.⟨_,_⟩ x≤y x≤z i =
+      IsMeet.⟨_,_⟩ ∧-isMeet (x≤y i) (x≤z i)
+    DistribLattice n .Obj.meets .MeetSemilattice.⊤-isTop .IsTop.≤-top i = IsTop.≤-top ⊤-isTop
+    DistribLattice n .Obj.joins .JoinSemilattice._∨_ u v i = u i ∨ v i
+    DistribLattice n .Obj.joins .JoinSemilattice.⊥ _ = ⊥
+    DistribLattice n .Obj.joins .JoinSemilattice.∨-isJoin .IsJoin.inl i = IsJoin.inl ∨-isJoin
+    DistribLattice n .Obj.joins .JoinSemilattice.∨-isJoin .IsJoin.inr i = IsJoin.inr ∨-isJoin
+    DistribLattice n .Obj.joins .JoinSemilattice.∨-isJoin .IsJoin.[_,_] x≤y y≤z i =
+      IsJoin.[_,_] ∨-isJoin (x≤y i) (y≤z i)
+    DistribLattice n .Obj.joins .JoinSemilattice.⊥-isBottom .IsBottom.≤-bottom i =
+      IsBottom.≤-bottom ⊥-isBottom
+    DistribLattice n .Obj.∧-∨-distrib _ _ _ _ = ∧-∨-distrib
+
+    open import join-semilattice using () renaming (_=>_ to _=>J_)
+    open _=>J_
+    open preorder._=>_ using (fun; mono)
+
+    -- Push y inside, interchange, pull x out.
+    swap : ∀ {m n} (M : Matrix n m) {x : Vec m} {y : Vec n} → y ⋅ (λ i → M i ⋅ x) ≈ (λ j → (M ᵀ) j ⋅ y) ⋅ x
+    swap {m} {n} M {x} {y} =
+      trans (Σ-cong {n} (λ i → Σ-·-distribₗ (y i) (λ j → M i j ∧ x j)))
+            (trans (Σ-interchange {n} {m} (λ i j → y i ∧ (M i j ∧ x j)))
+                   (Σ-cong {m} (λ j →
+                     trans (Σ-cong {n} (λ i → trans (sym ∧-assoc) (∧-cong ∧-comm refl)))
+                           (sym (Σ-·-distribᵣ (λ i → M i j ∧ y i) (x j))))))
+
+    to-conj : ∀ {m n} → Matrix n m → DistribLattice n ⇒c DistribLattice m
+    to-conj {m} {n} M .right .func .fun x j = (M ᵀ) j ⋅ x
+    to-conj {m} {n} M .right .func .mono x≤x' j = Σ-mono (λ i → ∧-mono ≤-refl (x≤x' i))
+    to-conj {m} {n} M .right .∨-preserving {x} {x'} j =
+      ≈→≤ (trans (Σ-cong {n} (λ i → ∧-∨-distribₗ)) (sym (Σ-+ {n} _ _)))
+    to-conj {m} {n} M .right .⊥-preserving j =
+      ≈→≤ (trans (Σ-cong {n} (λ i → ⊥-annihilᵣ)) (Σ-ε {n}))
+    to-conj {m} {n} M .left .func .fun y i = M i ⋅ y
+    to-conj {m} {n} M .left .func .mono y≤y' i = Σ-mono (λ j → ∧-mono ≤-refl (y≤y' j))
+    to-conj {m} {n} M .left .∨-preserving {y} {y'} i =
+      ≈→≤ (trans (Σ-cong {m} (λ j → ∧-∨-distribₗ)) (sym (Σ-+ {m} _ _)))
+    to-conj {m} {n} M .left .⊥-preserving i =
+      ≈→≤ (trans (Σ-cong {m} (λ j → ⊥-annihilᵣ)) (Σ-ε {m}))
+    to-conj {m} {n} M .conjugate {x} {y} .proj₁ h i =
+      ≤-trans (Σ-ub _ i) (≤-trans (≈→≤ (sym (swap (M ᵀ) {x} {y}))) (Σ-lub _ h))
+    to-conj {m} {n} M .conjugate {x} {y} .proj₂ k j =
+      ≤-trans (Σ-ub _ j) (≤-trans (≈→≤ (swap (M ᵀ) {x} {y})) (Σ-lub _ k))
+
+    -- The opposite semiring, with + and · swapped.
+    opposite : CommutativeSemiring A
+    opposite .CommutativeSemiring.additive = multiplicative
+    opposite .CommutativeSemiring.multiplicative = additive
+    opposite .CommutativeSemiring.·-+-distribₗ = sym ∨-∧-distribₗ
+    opposite .CommutativeSemiring.ε-annihilₗ = ⊤-add-top
+
+    -- The action of the transpose Mᵀ over the opposite semiring: a meet-preserving map given by y ↦ (j ↦ ⊓ᵢ
+    -- (M i j ∨ y i)). Distinct from the conjugate (which uses joins-of-meets). Athough this requires only
+    -- distributivity, not anything Boolean, we can think of this as the adjoint of ¬M; but neither ¬M nor the
+    -- right adjoint of M can themselves be defined for such a structure. Under additional Boolean (perhaps
+    -- only Heyting) assumptions, applying this construction to ¬M recovers the right adjoint of M.
+    private
+      module M-op = Mat opposite
+      open meet-semilattice using (MeetSemilattice)
+
+    open IsTop ⊤-isTop using () renaming (≤-top to ≤-⊤)
+
+    to-adj-candidate : ∀ {m n} → Matrix n m →
+                       meet-semilattice._=>_ (DistribLattice n .Obj.meets) (DistribLattice m .Obj.meets)
+    to-adj-candidate {m} {n} M .meet-semilattice._=>_.func .preorder._=>_.fun y j =
+      M-op.Σ {n} (λ i → M i j ∨ y i)
+    to-adj-candidate {m} {n} M .meet-semilattice._=>_.func .preorder._=>_.mono y≤y' j =
+      M-op.+-to-Σ.Σ-preserves _≤_ ≤-refl (IsMeet.mono ∧-isMeet)
+        (λ i → IsJoin.mono ∨-isJoin ≤-refl (y≤y' i))
+    to-adj-candidate {m} {n} M .meet-semilattice._=>_.∧-preserving {y₁} {y₂} j =
+      ≈→≤ (trans (M-op.Σ-+ {n} (λ i → M i j ∨ y₁ i) (λ i → M i j ∨ y₂ i))
+                 (M-op.Σ-cong {n} (λ i → ∨-∧-distribₗ)))
+    to-adj-candidate {m} {n} M .meet-semilattice._=>_.⊤-preserving j =
+      ≈→≤ (sym (trans (M-op.Σ-cong {n} (λ i → trans ∨-comm ⊤-add-top)) (M-op.Σ-ε {n})))
+
+open import prop using (_⇔_; proj₁; proj₂)
+
+-- I think we can actually derive this just from a Heyting implication.
+module BooleanAlgebra
+  {A : Setoid 0ℓ 0ℓ} (S : CommutativeSemiring A)
+  (let open CommutativeSemiring S hiding (_≈_; trans; sym; refl); open Setoid A)
+  (∨-idem    : ∀ {x} → x + x ≈ x)
+  (∧-idem    : ∀ {x} → x · x ≈ x)
+  (⊤-add-top : ∀ {x} → ι + x ≈ ι)
+  (let module L = DistributiveLattice S ∨-idem ∧-idem ⊤-add-top)
+  (¬ : Setoid.Carrier A → Setoid.Carrier A)
+  (complement-∨ : ∀ {x} → ι L.≤ (x + ¬ x))
+  (complement-∧ : ∀ {x} → (x · ¬ x) L.≤ ε)
+  where
+  module L-op = DistributiveLattice L.opposite ∧-idem ∨-idem ε-annihilₗ
+
+  open Mat S using (Matrix; Σ)
+  open Mat L.opposite using () renaming (Σ to Σ-op; module +-to-Σ to +-to-Σ-op)
+  open import Data.Nat using (ℕ)
+  open import Data.Fin using (Fin)
+  import preorder
+  open import conjugate using (_⇒c_)
+  open import join-semilattice using () renaming (_=>_ to _=>J_)
+  import meet-semilattice
+  open _⇒c_
+  open _=>J_
+  open preorder._=>_
+
+  open import galois using () renaming (Obj to Obj-g; _⇒g_ to _=>g_)
+
+  BoundedLattice : ℕ → Obj-g
+  BoundedLattice n .Obj-g.carrier = L.DistribLattice n .conjugate.Obj.carrier
+  BoundedLattice n .Obj-g.meets = L.DistribLattice n .conjugate.Obj.meets
+  BoundedLattice n .Obj-g.joins = L.DistribLattice n .conjugate.Obj.joins
+
+  ¬ₘ : ∀ {m n} → Matrix n m → Matrix n m
+  ¬ₘ M i j = ¬ (M i j)
+
+  open import basics using (IsPreorder; IsMeet; IsJoin)
+
+  -- L-op's order is L's order reversed (up to the idempotence-derived equivalence).
+  L-op⇔L : ∀ {a b} → (a L-op.≤ b) ⇔ (b L.≤ a)
+  L-op⇔L .proj₁ a·b≈b =
+    trans (+-cong (sym a·b≈b) refl) (trans +-comm L.∨-∧-absorption)
+  L-op⇔L .proj₂ b+a≈a =
+    trans (·-cong (sym b+a≈a) refl) (trans ·-+-distribᵣ (trans (+-cong ∧-idem ·-comm) L.∨-∧-absorption))
+
+  open IsPreorder L.≤-isPreorder using () renaming (refl to ≤-refl; trans to ≤-trans)
+  open IsJoin L.∨-isJoin using () renaming (mono to ∨-mono)
+  open IsMeet L.∧-isMeet using (π₂)
+  open L using (∧-monoʳ; ≈→≤; Σ-ub; Σ-lub)
+
+  -- Direction matching `to-conj`. The right adjoint is the meet-preserving "adjoint to ¬M candidate" that we
+  -- were able to compute using the tranpose on the opposite semiring.
+  to-gal : ∀ {m n} → Matrix n m → BoundedLattice n =>g BoundedLattice m
+  to-gal M ._=>g_.left = L.to-conj M .left .func
+  to-gal M ._=>g_.right = L.to-adj-candidate (¬ₘ M) .meet-semilattice._=>_.func
+  to-gal M ._=>g_.left⊣right {x} {y} .proj₁ y≤rx i =
+    Σ-lub _ (λ j →
+      ≤-trans (∧-monoʳ (≤-trans (y≤rx j) (L-op⇔L .proj₁ (L-op.Σ-ub _ i))))
+              (≤-trans (≈→≤ ·-+-distribₗ)
+                       (≤-trans (∨-mono complement-∧ ≤-refl)
+                                (≤-trans (≈→≤ +-lunit) π₂))))
+  to-gal M ._=>g_.left⊣right {x} {y} .proj₂ ly≤x j =
+    L-op⇔L .proj₁ (L-op.Σ-lub _ (λ i → L-op⇔L .proj₂ (helper i)))
+    where
+      helper : ∀ i → y j L.≤ ¬ (M i j) + x i
+      helper i =
+        ≤-trans (≈→≤ (trans (sym ·-lunit) ·-comm))
+                (≤-trans (∧-monoʳ complement-∨)
+                         (≤-trans (≈→≤ ·-+-distribₗ)
+                                  (≤-trans (∨-mono (≤-trans (≈→≤ ·-comm) (≤-trans (Σ-ub _ j) (ly≤x i))) π₂)
+                                           (≈→≤ +-comm))))
diff --git a/agda/src/meet-semilattice.agda b/agda/src/meet-semilattice.agda
index 0646f3e8..20e6ed2f 100644
--- a/agda/src/meet-semilattice.agda
+++ b/agda/src/meet-semilattice.agda
@@ -323,6 +323,8 @@ module _ where
   open MeetSemilattice
   open _=>_
   open preorder._=>_
+  open _≃m_
+  open preorder._≃m_
 
   L : ∀ {A} → MeetSemilattice A → MeetSemilattice (preorder.L A)
   L X ._∧_ bottom _ = bottom
@@ -380,8 +382,7 @@ module _ where
   L-map f .∧-preserving {< x >} {< x₁ >} = f .∧-preserving
   L-map f .⊤-preserving = f .⊤-preserving
 
-  L-strength : ∀ {A B}{X : MeetSemilattice A}{Y : MeetSemilattice B} →
-               (X ⊕ L Y) => L (X ⊕ Y)
+  L-strength : ∀ {A B}{X : MeetSemilattice A}{Y : MeetSemilattice B} → (X ⊕ L Y) => L (X ⊕ Y)
   L-strength .func .fun (x , bottom) = bottom
   L-strength .func .fun (x , < y >) = < x , y >
   L-strength .func .mono {x₁ , bottom} {x₂ , bottom} (x₁≤x₂ , tt) = tt
@@ -391,3 +392,25 @@ module _ where
   L-strength .∧-preserving {x , < x₁ >} {x' , bottom} = tt
   L-strength {A}{B} .∧-preserving {x , < x₁ >} {x' , < x₂ >} = A .≤-refl , B .≤-refl
   L-strength {A}{B} .⊤-preserving = A .≤-refl , B .≤-refl
+
+  L-strength-natural : ∀ {A₁ A₂ B₁ B₂}
+                       {X₁ : MeetSemilattice A₁} {X₂ : MeetSemilattice A₂}
+                       {Y₁ : MeetSemilattice B₁} {Y₂ : MeetSemilattice B₂}
+                       (f : X₁ => X₂) (g : Y₁ => Y₂) →
+                       (L-map ⟨ f ∘ project₁ , g ∘ project₂ ⟩ ∘ L-strength {X = X₁} {Y = Y₁}) ≃m
+                       (L-strength {X = X₂} {Y = Y₂} ∘ ⟨ f ∘ project₁ , L-map g ∘ project₂ ⟩)
+  L-strength-natural f g .eqfunc .eqfun (x , bottom) = tt , tt
+  L-strength-natural {A₂ = A₂} {B₂ = B₂} f g .eqfunc .eqfun (x , < y >) =
+    (A₂ × B₂) .≃-refl
+
+  L-strength-p₂ : ∀ {A B}{X : MeetSemilattice A}{Y : MeetSemilattice B} →
+                  (L-map project₂ ∘ L-strength {X = X} {Y = Y}) ≃m project₂
+  L-strength-p₂ .eqfunc .eqfun (x , bottom) = tt , tt
+  L-strength-p₂ {B = B} .eqfunc .eqfun (x , < y >) = B .≃-refl
+
+  -- Associativity coherence: L-strength commutes with the diagonal ⟨ project₁ , id ⟩.
+  L-strength-assoc : ∀ {A B}{X : MeetSemilattice A}{Y : MeetSemilattice B} →
+                     (L-strength {X = X} {Y = X ⊕ Y} ∘ ⟨ project₁ , L-strength {X = X} {Y = Y} ⟩) ≃m
+                     (L-map ⟨ project₁ , id ⟩ ∘ L-strength {X = X} {Y = Y})
+  L-strength-assoc .eqfunc .eqfun (x , bottom) = tt , tt
+  L-strength-assoc {A} {B} .eqfunc .eqfun (x , < y >) = (A × (A × B)) .≃-refl
diff --git a/agda/src/nat.agda b/agda/src/nat.agda
index 787a2daf..ca223957 100644
--- a/agda/src/nat.agda
+++ b/agda/src/nat.agda
@@ -288,6 +288,10 @@ module _ where
   zero-m .func x = zero
   zero-m .func-resp-≈ x = ≃-refl
 
+  one-m : 𝟙 {0ℓ} {0ℓ} ⇒s ℕₛ
+  one-m .func x = succ zero
+  one-m .func-resp-≈ x = ≃-refl
+
 ------------------------------------------------------------------------------
 -- Multiplication: _*_ is defined in Agda.Builtin.Nat
 
diff --git a/agda/src/polynomial-functor.agda b/agda/src/polynomial-functor.agda
new file mode 100644
index 00000000..5ebc996e
--- /dev/null
+++ b/agda/src/polynomial-functor.agda
@@ -0,0 +1,992 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Nat using (ℕ; zero; suc)
+import Data.Nat
+open import Data.Sum using ([_,_]; inj₁; inj₂) renaming (map to ⊎-map)
+open import Level using (_⊔_)
+open import categories
+  using (Category; HasTerminal; HasProducts; HasCoproducts; HasStrongCoproducts;
+         strong-coproducts→coproducts; coKleisli-prod)
+open import functor using (Functor)
+open import prop-setoid using (module ≈-Reasoning)
+open import Relation.Binary.PropositionalEquality using (_≡_; cong; cong₂)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; subst to ≡-subst)
+
+module polynomial-functor where
+
+data Poly {o m e} (𝒞 : Category o m e) (n : ℕ) : Set o where
+  const : Category.obj 𝒞 → Poly 𝒞 n
+  var   : Fin n → Poly 𝒞 n
+  _+_   : Poly 𝒞 n → Poly 𝒞 n → Poly 𝒞 n
+  _×_   : Poly 𝒞 n → Poly 𝒞 n → Poly 𝒞 n
+  μ     : Poly 𝒞 (suc n) → Poly 𝒞 n
+
+extend : ∀ {n} {ℓ} {A : Set ℓ} → (Fin n → A) → A → Fin (suc n) → A
+extend δ x Fin.zero    = x
+extend δ x (Fin.suc i) = δ i
+
+-- Interpretation of the polynomials in a category with terminal object, products and strong coproducts.
+module Interp
+  {o m e} {𝒞 : Category o m e}
+  (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞SCP : HasStrongCoproducts 𝒞 𝒞P)
+  where
+
+  open Category 𝒞
+  open HasProducts 𝒞P
+  open HasCoproducts (strong-coproducts→coproducts 𝒞T 𝒞SCP)
+  open HasStrongCoproducts 𝒞SCP using () renaming (copair to scopair)
+
+  -- co-Kleisli notation: a morphism f : prod Γ X ⇒ Y lives in the co-Kleisli category for prod Γ -.
+  infixl 21 _∘co_
+  _∘co_ : ∀ {Γ X Y Z} → (prod Γ Y ⇒ Z) → (prod Γ X ⇒ Y) → (prod Γ X ⇒ Z)
+  _∘co_ {Γ} = Category._∘_ (coKleisli-prod 𝒞P Γ)
+
+  fobj : ∀ {n} → (μ-obj : ∀ {m} → Poly 𝒞 (suc m) → (Fin m → obj) → obj) → Poly 𝒞 n → (Fin n → obj) → obj
+  fobj μ-obj (const A) δ = A
+  fobj μ-obj (var i)   δ = δ i
+  fobj μ-obj (P + Q)   δ = coprod (fobj μ-obj P δ) (fobj μ-obj Q δ)
+  fobj μ-obj (P × Q)   δ = prod (fobj μ-obj P δ) (fobj μ-obj Q δ)
+  fobj μ-obj (μ P)     δ = μ-obj P δ
+
+  -- Parameterised initial algebras for the polynomials: carrier, algebra map and catamorphism, as
+  -- operations only. The catamorphism is in context Γ (the open form avoids closure conversion, hence
+  -- exponentials). The β/η laws live in HasMuLaws below, stated via the strong functorial action
+  -- strong-fmor, which is defined from these operations; making the laws fields here would be circular.
+  record HasMu : Set (o ⊔ m ⊔ e) where
+    field
+      μ-obj : ∀ {n} → Poly 𝒞 (suc n) → (Fin n → obj) → obj
+      inMap     : ∀ {n} (P : Poly 𝒞 (suc n)) (δ : Fin n → obj) → fobj μ-obj P (extend δ (μ-obj P δ)) ⇒ μ-obj P δ
+      ⦅_⦆  : ∀ {n Γ A} {P : Poly 𝒞 (suc n)} {δ : Fin n → obj} →
+             (prod Γ (fobj μ-obj P (extend δ A)) ⇒ A) → prod Γ (μ-obj P δ) ⇒ A
+
+    open HasTerminal 𝒞T using (witness; to-terminal; to-terminal-unique)
+
+    strong-extend-mor : ∀ {n Γ} {δ δ' : Fin n → obj} {X Y} →
+                 (∀ i → prod Γ (δ i) ⇒ δ' i) → (prod Γ X ⇒ Y) → ∀ i → prod Γ (extend δ X i) ⇒ extend δ' Y i
+    strong-extend-mor fs x→y Fin.zero    = x→y
+    strong-extend-mor fs x→y (Fin.suc i) = fs i
+
+    mutual
+      strong-fmor : ∀ {n Γ} (P : Poly 𝒞 n) {δ δ' : Fin n → obj} →
+                    (∀ i → prod Γ (δ i) ⇒ δ' i) → prod Γ (fobj μ-obj P δ) ⇒ fobj μ-obj P δ'
+      strong-fmor (const A) fs = p₂
+      strong-fmor (var i)   fs = fs i
+      strong-fmor (P + Q)   fs = scopair (in₁ ∘ strong-fmor P fs) (in₂ ∘ strong-fmor Q fs)
+      strong-fmor (P × Q)   fs = strong-prod-m (strong-fmor P fs) (strong-fmor Q fs)
+      strong-fmor (μ P)     fs = strong-μ-fmor P fs
+
+      strong-μ-fmor : ∀ {n Γ} (P : Poly 𝒞 (suc n)) {δ δ' : Fin n → obj} →
+                      (∀ i → prod Γ (δ i) ⇒ δ' i) → prod Γ (μ-obj P δ) ⇒ μ-obj P δ'
+      strong-μ-fmor P {δ} {δ'} fs = ⦅ inMap P δ' ∘ strong-fmor P (strong-extend-mor fs p₂) ⦆
+
+    fmor : ∀ {n} (P : Poly 𝒞 n) {δ δ' : Fin n → obj} → (∀ i → δ i ⇒ δ' i) → fobj μ-obj P δ ⇒ fobj μ-obj P δ'
+    fmor P fs = strong-fmor P (λ i → fs i ∘ p₂) ∘ pair to-terminal (id _)
+
+    -- A morphism between μ-objs, induced by an unfolding of P into Q at the target carrier.
+    -- P, δ are explicit because fobj/μ-obj are not injective, so they can't be inferred from unfold.
+    μ-map : ∀ {m n} (P : Poly 𝒞 (suc m)) (δ : Fin m → obj) (Q : Poly 𝒞 (suc n)) (δ' : Fin n → obj) →
+            (fobj μ-obj P (extend δ (μ-obj Q δ')) ⇒ fobj μ-obj Q (extend δ' (μ-obj Q δ'))) →
+            μ-obj P δ ⇒ μ-obj Q δ'
+    μ-map P δ Q δ' unfold = ⦅_⦆ {P = P} {δ = δ} ((inMap Q δ' ∘ unfold) ∘ p₂) ∘ pair to-terminal (id _)
+
+  -- The initiality laws for HasMu, stated via the strong functorial action derived from its operations.
+  record HasMuLaws (Mu : HasMu) : Set (o ⊔ m ⊔ e) where
+    open HasMu Mu
+    field
+      ⦅⦆-β : ∀ {n Γ A} {P : Poly 𝒞 (suc n)} {δ : Fin n → obj}
+             (alg : prod Γ (fobj μ-obj P (extend δ A)) ⇒ A) →
+             (⦅ alg ⦆ ∘co (inMap P δ ∘ p₂)) ≈ (alg ∘co strong-fmor P (strong-extend-mor (λ i → p₂) ⦅ alg ⦆))
+      ⦅⦆-η : ∀ {n Γ A} {P : Poly 𝒞 (suc n)} {δ : Fin n → obj}
+             (alg : prod Γ (fobj μ-obj P (extend δ A)) ⇒ A) (h : prod Γ (μ-obj P δ) ⇒ A) →
+             (h ∘co (inMap P δ ∘ p₂)) ≈ (alg ∘co strong-fmor P (strong-extend-mor (λ i → p₂) h)) → h ≈ ⦅ alg ⦆
+
+-- Action of a functor on polynomials: apply the functor at the const leaves.
+Poly-map : ∀ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂} →
+           Functor 𝒞 𝒟 → ∀ {n} → Poly 𝒞 n → Poly 𝒟 n
+Poly-map F (const A) = const (F .Functor.fobj A)
+Poly-map F (var i)   = var i
+Poly-map F (P + Q)   = Poly-map F P + Poly-map F Q
+Poly-map F (P × Q)   = Poly-map F P × Poly-map F Q
+Poly-map F (μ P)     = μ (Poly-map F P)
+
+-- The constant-free form of a polynomial: constants are replaced by fresh
+-- variables, numbered above the original ones. The traversal carries an
+-- injection of each subterm's constant block into the full block, so no
+-- renaming of polynomials is needed. The constant-free never mentions the constants
+-- and so lives over any category.
+#c : ∀ {o₁ m₁ e₁} {𝒞 : Category o₁ m₁ e₁} {n} → Poly 𝒞 n → ℕ
+#c (const A) = 1
+#c (var i)   = 0
+#c (P + Q)   = #c P Data.Nat.+ #c Q
+#c (P × Q)   = #c P Data.Nat.+ #c Q
+#c (μ P)     = #c P
+
+constant-free-go : ∀ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂} {n k}
+              (P : Poly 𝒞 n) → (Fin (#c P) → Fin k) → Poly 𝒟 (n Data.Nat.+ k)
+constant-free-go {n = n} {k} (const A) ι = var (n Fin.↑ʳ ι Fin.zero)
+constant-free-go {k = k} (var i)      ι = var (i Fin.↑ˡ k)
+constant-free-go (P + Q) ι = constant-free-go P (λ c → ι (c Fin.↑ˡ #c Q)) + constant-free-go Q (λ c → ι (#c P Fin.↑ʳ c))
+constant-free-go (P × Q) ι = constant-free-go P (λ c → ι (c Fin.↑ˡ #c Q)) × constant-free-go Q (λ c → ι (#c P Fin.↑ʳ c))
+constant-free-go (μ P)   ι = μ (constant-free-go P ι)
+
+constant-free : ∀ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂} {n}
+           (P : Poly 𝒞 n) → Poly 𝒟 (n Data.Nat.+ #c P)
+constant-free P = constant-free-go P (λ c → c)
+
+-- The constant-free never mentions the constants, so transporting it along a functor
+-- gives the constant-free form again: the two instantiations coincide.
+Poly-map-constant-free-go : ∀ {o₁ m₁ e₁ o₂ m₂ e₂ o₃ m₃ e₃}
+                       {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂} {ℰ : Category o₃ m₃ e₃}
+                       (G : Functor 𝒟 ℰ) {n k} (P : Poly 𝒞 n) (ι : Fin (#c P) → Fin k) →
+                       Poly-map G (constant-free-go {𝒟 = 𝒟} P ι) ≡ constant-free-go {𝒟 = ℰ} P ι
+Poly-map-constant-free-go G (const A) ι = ≡-refl
+Poly-map-constant-free-go G (var i)   ι = ≡-refl
+Poly-map-constant-free-go G (P + Q) ι =
+  cong₂ _+_ (Poly-map-constant-free-go G P (λ c → ι (c Fin.↑ˡ #c Q)))
+            (Poly-map-constant-free-go G Q (λ c → ι (#c P Fin.↑ʳ c)))
+Poly-map-constant-free-go G (P × Q) ι =
+  cong₂ _×_ (Poly-map-constant-free-go G P (λ c → ι (c Fin.↑ˡ #c Q)))
+            (Poly-map-constant-free-go G Q (λ c → ι (#c P Fin.↑ʳ c)))
+Poly-map-constant-free-go G (μ P) ι = cong μ (Poly-map-constant-free-go G P ι)
+
+-- The constants of a polynomial, indexed by its constant block.
+consts : ∀ {o₁ m₁ e₁} {𝒞 : Category o₁ m₁ e₁} {n} (P : Poly 𝒞 n) → Fin (#c P) → Category.obj 𝒞
+consts (const A) _ = A
+consts (P + Q) c = [ consts P , consts Q ] (Fin.splitAt (#c P) c)
+consts (P × Q) c = [ consts P , consts Q ] (Fin.splitAt (#c P) c)
+consts (μ P)   c = consts P c
+
+-- Extend an environment by a constant block.
+_++e_ : ∀ {a} {A : Set a} {n k} → (Fin n → A) → (Fin k → A) → Fin (n Data.Nat.+ k) → A
+_++e_ {n = n} δ cs i = [ δ , cs ] (Fin.splitAt n i)
+
+-- Extension commutes with pointwise application.
+++e-map : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) {n k}
+          (δ : Fin n → A) (cs : Fin k → A) (i : Fin (n Data.Nat.+ k)) →
+          f ((δ ++e cs) i) ≡ ((λ j → f (δ j)) ++e (λ c → f (cs c))) i
+++e-map f {n} δ cs i with Fin.splitAt n i
+... | inj₁ _ = ≡-refl
+... | inj₂ _ = ≡-refl
+
+-- Transporting a polynomial along a functor preserves the constant count, the
+-- constants themselves up to the functor, and the constant-free form.
+#c-Poly-map : ∀ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂}
+              (G : Functor 𝒞 𝒟) {n} (P : Poly 𝒞 n) → #c (Poly-map G P) ≡ #c P
+#c-Poly-map G (const A) = ≡-refl
+#c-Poly-map G (var i)   = ≡-refl
+#c-Poly-map G (P + Q)   = cong₂ Data.Nat._+_ (#c-Poly-map G P) (#c-Poly-map G Q)
+#c-Poly-map G (P × Q)   = cong₂ Data.Nat._+_ (#c-Poly-map G P) (#c-Poly-map G Q)
+#c-Poly-map G (μ P)     = #c-Poly-map G P
+
+private
+  subst-↑ˡ : ∀ {m m' n n'} (p : m' ≡ m) (q : n' ≡ n) (c : Fin m') →
+             ≡-subst Fin (cong₂ Data.Nat._+_ p q) (c Fin.↑ˡ n') ≡ (≡-subst Fin p c) Fin.↑ˡ n
+  subst-↑ˡ ≡-refl ≡-refl c = ≡-refl
+
+  subst-↑ʳ : ∀ {m m' n n'} (p : m' ≡ m) (q : n' ≡ n) (c : Fin n') →
+             ≡-subst Fin (cong₂ Data.Nat._+_ p q) (m' Fin.↑ʳ c) ≡ m Fin.↑ʳ (≡-subst Fin q c)
+  subst-↑ʳ ≡-refl ≡-refl c = ≡-refl
+
+  splitAt-subst : ∀ {m m' n n'} (p : m' ≡ m) (q : n' ≡ n) (c : Fin (m' Data.Nat.+ n')) →
+                  Fin.splitAt m (≡-subst Fin (cong₂ Data.Nat._+_ p q) c) ≡
+                  ⊎-map (≡-subst Fin p) (≡-subst Fin q) (Fin.splitAt m' c)
+  splitAt-subst {m} ≡-refl ≡-refl c with Fin.splitAt m c
+  ... | inj₁ _ = ≡-refl
+  ... | inj₂ _ = ≡-refl
+
+consts-Poly-map : ∀ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂}
+                  (G : Functor 𝒞 𝒟) {n} (P : Poly 𝒞 n) (c : Fin (#c (Poly-map G P))) →
+                  consts (Poly-map G P) c ≡
+                  G .Functor.fobj (consts P (≡-subst Fin (#c-Poly-map G P) c))
+consts-Poly-map G (const A) c = ≡-refl
+consts-Poly-map G (P + Q) c
+  rewrite splitAt-subst (#c-Poly-map G P) (#c-Poly-map G Q) c
+  with Fin.splitAt (#c (Poly-map G P)) c
+... | inj₁ c₁ = consts-Poly-map G P c₁
+... | inj₂ c₂ = consts-Poly-map G Q c₂
+consts-Poly-map G (P × Q) c
+  rewrite splitAt-subst (#c-Poly-map G P) (#c-Poly-map G Q) c
+  with Fin.splitAt (#c (Poly-map G P)) c
+... | inj₁ c₁ = consts-Poly-map G P c₁
+... | inj₂ c₂ = consts-Poly-map G Q c₂
+consts-Poly-map G (μ P) c = consts-Poly-map G P c
+
+-- The constant-free is unchanged by renaming the constant block pointwise.
+constant-free-go-cong : ∀ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂}
+                   {n k} (P : Poly 𝒞 n) {ι₁ ι₂ : Fin (#c P) → Fin k} →
+                   (∀ c → ι₁ c ≡ ι₂ c) →
+                   constant-free-go {𝒟 = 𝒟} P ι₁ ≡ constant-free-go {𝒟 = 𝒟} P ι₂
+constant-free-go-cong {n = n} (const A) eq = cong (λ t → var (n Fin.↑ʳ t)) (eq Fin.zero)
+constant-free-go-cong (var i)   eq = ≡-refl
+constant-free-go-cong (P + Q) eq =
+  cong₂ _+_ (constant-free-go-cong P (λ c → eq (c Fin.↑ˡ #c Q)))
+            (constant-free-go-cong Q (λ c → eq (#c P Fin.↑ʳ c)))
+constant-free-go-cong (P × Q) eq =
+  cong₂ _×_ (constant-free-go-cong P (λ c → eq (c Fin.↑ˡ #c Q)))
+            (constant-free-go-cong Q (λ c → eq (#c P Fin.↑ʳ c)))
+constant-free-go-cong (μ P) eq = cong μ (constant-free-go-cong P eq)
+
+-- The constant-free never mentions the constants, so transporting its source along
+-- a functor gives the constant-free form again, up to the cast of the constant block.
+constant-free-go-Poly-map : ∀ {o₁ m₁ e₁ o₂ m₂ e₂ o₃ m₃ e₃}
+                       {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂} {ℰ : Category o₃ m₃ e₃}
+                       (G : Functor 𝒞 𝒟) {n k} (P : Poly 𝒞 n) (ι : Fin (#c P) → Fin k) →
+                       constant-free-go {𝒟 = ℰ} (Poly-map G P) (λ c → ι (≡-subst Fin (#c-Poly-map G P) c)) ≡
+                       constant-free-go {𝒟 = ℰ} P ι
+constant-free-go-Poly-map G (const A) ι = ≡-refl
+constant-free-go-Poly-map G (var i)   ι = ≡-refl
+constant-free-go-Poly-map G (P + Q) ι =
+  cong₂ _+_
+    (≡-trans (constant-free-go-cong (Poly-map G P)
+               (λ c → cong ι (subst-↑ˡ (#c-Poly-map G P) (#c-Poly-map G Q) c)))
+             (constant-free-go-Poly-map G P (λ c → ι (c Fin.↑ˡ #c Q))))
+    (≡-trans (constant-free-go-cong (Poly-map G Q)
+               (λ c → cong ι (subst-↑ʳ (#c-Poly-map G P) (#c-Poly-map G Q) c)))
+             (constant-free-go-Poly-map G Q (λ c → ι (#c P Fin.↑ʳ c))))
+constant-free-go-Poly-map G (P × Q) ι =
+  cong₂ _×_
+    (≡-trans (constant-free-go-cong (Poly-map G P)
+               (λ c → cong ι (subst-↑ˡ (#c-Poly-map G P) (#c-Poly-map G Q) c)))
+             (constant-free-go-Poly-map G P (λ c → ι (c Fin.↑ˡ #c Q))))
+    (≡-trans (constant-free-go-cong (Poly-map G Q)
+               (λ c → cong ι (subst-↑ʳ (#c-Poly-map G P) (#c-Poly-map G Q) c)))
+             (constant-free-go-Poly-map G Q (λ c → ι (#c P Fin.↑ʳ c))))
+constant-free-go-Poly-map G (μ P) ι = cong μ (constant-free-go-Poly-map G P ι)
+
+-- The functor preserves μ-types: each μ-object maps, up to isomorphism, to the
+-- μ-object of the image polynomial in the image environment.
+Preserves-μ : ∀ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟 : Category o₂ m₂ e₂}
+              (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞SCP : HasStrongCoproducts 𝒞 𝒞P)
+              (𝒟T : HasTerminal 𝒟) (𝒟P : HasProducts 𝒟) (𝒟SCP : HasStrongCoproducts 𝒟 𝒟P) →
+              Interp.HasMu 𝒞T 𝒞P 𝒞SCP → Interp.HasMu 𝒟T 𝒟P 𝒟SCP → Functor 𝒞 𝒟 →
+              Set (o₁ ⊔ m₂ ⊔ e₂)
+Preserves-μ {𝒞 = 𝒞} {𝒟 = 𝒟} 𝒞T 𝒞P 𝒞SCP 𝒟T 𝒟P 𝒟SCP 𝒞Mu 𝒟Mu F =
+  ∀ {n} (P : Poly 𝒞 (suc n)) (δ : Fin n → Category.obj 𝒞) →
+  Category.Iso 𝒟 (F .Functor.fobj (CM.μ-obj P δ))
+                 (DM.μ-obj (Poly-map F P) (λ i → F .Functor.fobj (δ i)))
+  where
+    module CM = Interp.HasMu 𝒞Mu
+    module DM = Interp.HasMu 𝒟Mu
+
+------------------------------------------------------------------------------
+-- Componentwise morphisms between polynomials, their action on interpretations and μ-objects, and the functor
+-- laws for that action, derived from the initiality laws. Componentwise isomorphic polynomials have isomorphic
+-- μ-objects.
+module MuIso
+  {o m e} {𝒞 : Category o m e}
+  (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞SCP : HasStrongCoproducts 𝒞 𝒞P)
+  (Mu : Interp.HasMu 𝒞T 𝒞P 𝒞SCP)
+  (Laws : Interp.HasMuLaws 𝒞T 𝒞P 𝒞SCP Mu)
+  where
+
+  open Category 𝒞
+  open HasProducts 𝒞P
+  open HasCoproducts (strong-coproducts→coproducts 𝒞T 𝒞SCP) using (in₁; in₂)
+  open HasStrongCoproducts 𝒞SCP using (copair-in₁; copair-in₂; copair-ext)
+    renaming (copair to scopair; copair-cong to scopair-cong; copair-ext0 to scopair-ext0;
+              copair-reindex to scopair-reindex)
+  open HasTerminal 𝒞T using (to-terminal)
+  open categories.Unitor 𝒞T 𝒞P using (sect; unitor-comp)
+  open Interp 𝒞T 𝒞P 𝒞SCP
+  open HasMu Mu
+  open HasMuLaws Laws
+
+  -- A componentwise morphism between two polynomials of the same shape: a
+  -- morphism at each pair of const leaves.
+  data PolyMor : ∀ {n} → Poly 𝒞 n → Poly 𝒞 n → Set (o ⊔ m) where
+    const : ∀ {n A B} → A ⇒ B → PolyMor {n} (const A) (const B)
+    var   : ∀ {n} (i : Fin n) → PolyMor (var i) (var i)
+    _+_   : ∀ {n} {P P' Q Q' : Poly 𝒞 n} → PolyMor P P' → PolyMor Q Q' → PolyMor (P + Q) (P' + Q')
+    _×_   : ∀ {n} {P P' Q Q' : Poly 𝒞 n} → PolyMor P P' → PolyMor Q Q' → PolyMor (P × Q) (P' × Q')
+    μ     : ∀ {n} {P P' : Poly 𝒞 (suc n)} → PolyMor P P' → PolyMor (μ P) (μ P')
+
+  -- Label composition and identity.
+  _∙_ : ∀ {n} {P Q R : Poly 𝒞 n} → PolyMor Q R → PolyMor P Q → PolyMor P R
+  const g ∙ const f = const (g ∘ f)
+  var i   ∙ var .i  = var i
+  (s + t) ∙ (r + u) = (s ∙ r) + (t ∙ u)
+  (s × t) ∙ (r × u) = (s ∙ r) × (t ∙ u)
+  μ s     ∙ μ r     = μ (s ∙ r)
+
+  pm-id : ∀ {n} (P : Poly 𝒞 n) → PolyMor P P
+  pm-id (const A) = const (id A)
+  pm-id (var i)   = var i
+  pm-id (P + Q)   = pm-id P + pm-id Q
+  pm-id (P × Q)   = pm-id P × pm-id Q
+  pm-id (μ P)     = μ (pm-id P)
+
+  -- Pointwise equality of componentwise morphisms.
+  data PolyMor-≈ : ∀ {n} {P Q : Poly 𝒞 n} → PolyMor P Q → PolyMor P Q → Prop (o ⊔ m ⊔ e) where
+    const : ∀ {n A B} {f g : A ⇒ B} → f ≈ g → PolyMor-≈ {n} (const f) (const g)
+    var   : ∀ {n} (i : Fin n) → PolyMor-≈ (var i) (var i)
+    _+_   : ∀ {n} {P P' Q Q' : Poly 𝒞 n} {r r' : PolyMor P P'} {s s' : PolyMor Q Q'} →
+            PolyMor-≈ r r' → PolyMor-≈ s s' → PolyMor-≈ (r + s) (r' + s')
+    _×_   : ∀ {n} {P P' Q Q' : Poly 𝒞 n} {r r' : PolyMor P P'} {s s' : PolyMor Q Q'} →
+            PolyMor-≈ r r' → PolyMor-≈ s s' → PolyMor-≈ (r × s) (r' × s')
+    μ     : ∀ {n} {P P' : Poly 𝒞 (suc n)} {r r' : PolyMor P P'} →
+            PolyMor-≈ r r' → PolyMor-≈ (μ r) (μ r')
+
+  -- Componentwise isomorphism.
+  record PolyIso {n} (P Q : Poly 𝒞 n) : Set (o ⊔ m ⊔ e) where
+    field
+      fwd     : PolyMor P Q
+      bwd     : PolyMor Q P
+      bwd∘fwd : PolyMor-≈ (bwd ∙ fwd) (pm-id P)
+      fwd∘bwd : PolyMor-≈ (fwd ∙ bwd) (pm-id Q)
+
+  -- Action of a componentwise morphism on interpretations and on μ-objects, in
+  -- context Γ.
+  mutual
+    pm-fmor : ∀ {n Γ} {P Q : Poly 𝒞 n} → PolyMor P Q → {δ δ' : Fin n → obj} →
+              (∀ i → prod Γ (δ i) ⇒ δ' i) → prod Γ (fobj μ-obj P δ) ⇒ fobj μ-obj Q δ'
+    pm-fmor (const f) fs = f ∘ p₂
+    pm-fmor (var i)   fs = fs i
+    pm-fmor (r + s)   fs = scopair (in₁ ∘ pm-fmor r fs) (in₂ ∘ pm-fmor s fs)
+    pm-fmor (r × s)   fs = strong-prod-m (pm-fmor r fs) (pm-fmor s fs)
+    pm-fmor (μ r)     fs = pm-μ-fmor r fs
+
+    pm-μ-fmor : ∀ {n Γ} {P Q : Poly 𝒞 (suc n)} → PolyMor P Q → {δ δ' : Fin n → obj} →
+                (∀ i → prod Γ (δ i) ⇒ δ' i) → prod Γ (μ-obj P δ) ⇒ μ-obj Q δ'
+    pm-μ-fmor {Q = Q} r {δ} {δ'} fs = ⦅ inMap Q δ' ∘ pm-fmor r (strong-extend-mor fs p₂) ⦆
+
+  -- The fold respects equality of algebras. P and δ are explicit because fobj/μ-obj are not injective, so
+  -- can't be inferred from the algebras.
+  ⦅⦆-cong : ∀ {n Γ A} (P : Poly 𝒞 (suc n)) (δ : Fin n → obj)
+            {alg alg' : prod Γ (fobj μ-obj P (extend δ A)) ⇒ A} →
+            alg ≈ alg' → ⦅_⦆ {P = P} {δ = δ} alg ≈ ⦅_⦆ {P = P} {δ = δ} alg'
+  ⦅⦆-cong P δ {alg = alg} {alg' = alg'} e =
+    ⦅⦆-η {P = P} {δ = δ} alg' (⦅_⦆ {P = P} {δ = δ} alg)
+      (≈-trans (⦅⦆-β {P = P} {δ = δ} alg)
+        (∘-cong e ≈-refl))
+
+  -- On identity labels the action is the strong functorial action.
+  mutual
+    pm-fmor-id : ∀ {n Γ} (P : Poly 𝒞 n) {δ δ' : Fin n → obj} (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                 pm-fmor (pm-id P) fs ≈ strong-fmor P fs
+    pm-fmor-id (const A) fs = id-left
+    pm-fmor-id (var i)   fs = ≈-refl
+    pm-fmor-id (P + Q)   fs =
+      scopair-cong (∘-cong ≈-refl (pm-fmor-id P fs)) (∘-cong ≈-refl (pm-fmor-id Q fs))
+    pm-fmor-id (P × Q)   fs = strong-prod-m-cong (pm-fmor-id P fs) (pm-fmor-id Q fs)
+    pm-fmor-id (μ P)     fs = pm-μ-fmor-id P fs
+
+    pm-μ-fmor-id : ∀ {n Γ} (P : Poly 𝒞 (suc n)) {δ δ' : Fin n → obj} (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                   pm-μ-fmor (pm-id P) fs ≈ strong-μ-fmor P fs
+    pm-μ-fmor-id P {δ} fs = ⦅⦆-cong P δ (∘-cong ≈-refl (pm-fmor-id P _))
+
+  -- The action respects equality of labels and environments.
+  mutual
+    pm-fmor-cong : ∀ {n Γ} {P Q : Poly 𝒞 n} {r r' : PolyMor P Q} → PolyMor-≈ r r' →
+                   {δ δ' : Fin n → obj} {fs fs' : ∀ i → prod Γ (δ i) ⇒ δ' i} →
+                   (∀ i → fs i ≈ fs' i) → pm-fmor r fs ≈ pm-fmor r' fs'
+    pm-fmor-cong (const e) es = ∘-cong e ≈-refl
+    pm-fmor-cong (var i)   es = es i
+    pm-fmor-cong (e + e')  es =
+      scopair-cong (∘-cong ≈-refl (pm-fmor-cong e es)) (∘-cong ≈-refl (pm-fmor-cong e' es))
+    pm-fmor-cong (e × e')  es = strong-prod-m-cong (pm-fmor-cong e es) (pm-fmor-cong e' es)
+    pm-fmor-cong (μ e)     es = pm-μ-fmor-cong e es
+
+    pm-μ-fmor-cong : ∀ {n Γ} {P Q : Poly 𝒞 (suc n)} {r r' : PolyMor P Q} → PolyMor-≈ r r' →
+                     {δ δ' : Fin n → obj} {fs fs' : ∀ i → prod Γ (δ i) ⇒ δ' i} →
+                     (∀ i → fs i ≈ fs' i) → pm-μ-fmor r fs ≈ pm-μ-fmor r' fs'
+    pm-μ-fmor-cong {P = P} e {δ} es =
+      ⦅⦆-cong P δ (∘-cong ≈-refl (pm-fmor-cong e (strong-extend-mor-cong es)))
+      where
+        strong-extend-mor-cong : ∀ {n Γ} {δ δ' : Fin n → obj} {X Y}
+          {fs fs' : ∀ i → prod Γ (δ i) ⇒ δ' i} {x : prod Γ X ⇒ Y} →
+          (∀ i → fs i ≈ fs' i) → ∀ i → strong-extend-mor fs x i ≈ strong-extend-mor fs' x i
+        strong-extend-mor-cong es Fin.zero    = ≈-refl
+        strong-extend-mor-cong es (Fin.suc i) = es i
+
+  pm-≈-refl : ∀ {n} {P Q : Poly 𝒞 n} (r : PolyMor P Q) → PolyMor-≈ r r
+  pm-≈-refl (const f) = const ≈-refl
+  pm-≈-refl (var i)   = var i
+  pm-≈-refl (r + s)   = pm-≈-refl r + pm-≈-refl s
+  pm-≈-refl (r × s)   = pm-≈-refl r × pm-≈-refl s
+  pm-≈-refl (μ r)     = μ (pm-≈-refl r)
+
+  ------------------------------------------------------------------------------
+  -- Functor laws for the strong action, derived from the initiality laws.
+
+  private
+    module CoK {Γ : obj} = Category (coKleisli-prod 𝒞P Γ)
+
+  pair-p₁-comp : ∀ {Γ X Y Z} (x : prod Γ X ⇒ Y) (y : prod Γ Z ⇒ X) →
+                 (pair p₁ x ∘ pair p₁ y) ≈ pair p₁ (x ∘ pair p₁ y)
+  pair-p₁-comp x y =
+    begin
+      pair p₁ x ∘ pair p₁ y
+    ≈⟨ pair-natural _ _ _ ⟩
+      pair (p₁ ∘ pair p₁ y) (x ∘ pair p₁ y)
+    ≈⟨ pair-cong (pair-p₁ _ _) ≈-refl ⟩
+      pair p₁ (x ∘ pair p₁ y)
+    ∎ where open ≈-Reasoning isEquiv
+
+  -- Push a plain morphism out of a co-Kleisli composite.
+  ∘co-push : ∀ {Γ W X Y Z} (x : prod Γ Y ⇒ Z) (a : X ⇒ Y) (y : prod Γ W ⇒ X) →
+             ((x ∘co (a ∘ p₂)) ∘co y) ≈ (x ∘co (a ∘ y))
+  ∘co-push x a y =
+    begin
+      (x ∘ pair p₁ (a ∘ p₂)) ∘ pair p₁ y
+    ≈⟨ assoc _ _ _ ⟩
+      x ∘ (pair p₁ (a ∘ p₂) ∘ pair p₁ y)
+    ≈⟨ ∘-cong ≈-refl (pair-p₁-comp _ _) ⟩
+      x ∘ pair p₁ ((a ∘ p₂) ∘ pair p₁ y)
+    ≈⟨ ∘-cong ≈-refl (pair-cong ≈-refl (≈-trans (assoc _ _ _) (∘-cong ≈-refl (pair-p₂ _ _)))) ⟩
+      x ∘ pair p₁ (a ∘ y)
+    ∎ where open ≈-Reasoning isEquiv
+
+  -- Composites of strong copairings of injections.
+  scopair-comp : ∀ {Γ X₁ X₂ Y₁ Y₂ Z₁ Z₂}
+    (f₂ : prod Γ Y₁ ⇒ Z₁) (g₂ : prod Γ Y₂ ⇒ Z₂) (f₁ : prod Γ X₁ ⇒ Y₁) (g₁ : prod Γ X₂ ⇒ Y₂) →
+    (scopair (in₁ ∘ f₂) (in₂ ∘ g₂) ∘co scopair (in₁ ∘ f₁) (in₂ ∘ g₁))
+      ≈ scopair (in₁ ∘ (f₂ ∘co f₁)) (in₂ ∘ (g₂ ∘co g₁))
+  scopair-comp f₂ g₂ f₁ g₁ =
+    ≈-trans (≈-sym (copair-ext _)) (scopair-cong branch₁ branch₂)
+    where
+      G = scopair (in₁ ∘ f₂) (in₂ ∘ g₂)
+      F = scopair (in₁ ∘ f₁) (in₂ ∘ g₁)
+
+      branch₁ : ((G ∘ pair p₁ F) ∘ pair p₁ (in₁ ∘ p₂)) ≈ (in₁ ∘ (f₂ ∘co f₁))
+      branch₁ =
+        begin
+          (G ∘ pair p₁ F) ∘ pair p₁ (in₁ ∘ p₂)
+        ≈⟨ assoc _ _ _ ⟩
+          G ∘ (pair p₁ F ∘ pair p₁ (in₁ ∘ p₂))
+        ≈⟨ ∘-cong ≈-refl (pair-p₁-comp _ _) ⟩
+          G ∘ pair p₁ (F ∘ pair p₁ (in₁ ∘ p₂))
+        ≈⟨ ∘-cong ≈-refl (pair-cong ≈-refl (copair-in₁ _ _)) ⟩
+          G ∘ pair p₁ (in₁ ∘ f₁)
+        ≈˘⟨ ∘co-push G in₁ f₁ ⟩
+          (G ∘ pair p₁ (in₁ ∘ p₂)) ∘ pair p₁ f₁
+        ≈⟨ ∘-cong (copair-in₁ _ _) ≈-refl ⟩
+          (in₁ ∘ f₂) ∘ pair p₁ f₁
+        ≈⟨ assoc _ _ _ ⟩
+          in₁ ∘ (f₂ ∘co f₁)
+        ∎ where open ≈-Reasoning isEquiv
+
+      branch₂ : ((G ∘ pair p₁ F) ∘ pair p₁ (in₂ ∘ p₂)) ≈ (in₂ ∘ (g₂ ∘co g₁))
+      branch₂ =
+        begin
+          (G ∘ pair p₁ F) ∘ pair p₁ (in₂ ∘ p₂)
+        ≈⟨ assoc _ _ _ ⟩
+          G ∘ (pair p₁ F ∘ pair p₁ (in₂ ∘ p₂))
+        ≈⟨ ∘-cong ≈-refl (pair-p₁-comp _ _) ⟩
+          G ∘ pair p₁ (F ∘ pair p₁ (in₂ ∘ p₂))
+        ≈⟨ ∘-cong ≈-refl (pair-cong ≈-refl (copair-in₂ _ _)) ⟩
+          G ∘ pair p₁ (in₂ ∘ g₁)
+        ≈˘⟨ ∘co-push G in₂ g₁ ⟩
+          (G ∘ pair p₁ (in₂ ∘ p₂)) ∘ pair p₁ g₁
+        ≈⟨ ∘-cong (copair-in₂ _ _) ≈-refl ⟩
+          (in₂ ∘ g₂) ∘ pair p₁ g₁
+        ≈⟨ assoc _ _ _ ⟩
+          in₂ ∘ (g₂ ∘co g₁)
+        ∎ where open ≈-Reasoning isEquiv
+
+  -- The strong action respects equality of environments.
+  mutual
+    strong-fmor-cong : ∀ {n Γ} (P : Poly 𝒞 n) {δ δ' : Fin n → obj}
+                       {fs fs' : ∀ i → prod Γ (δ i) ⇒ δ' i} →
+                       (∀ i → fs i ≈ fs' i) → strong-fmor P fs ≈ strong-fmor P fs'
+    strong-fmor-cong (const A) es = ≈-refl
+    strong-fmor-cong (var i)   es = es i
+    strong-fmor-cong (P + Q)   es =
+      scopair-cong (∘-cong ≈-refl (strong-fmor-cong P es)) (∘-cong ≈-refl (strong-fmor-cong Q es))
+    strong-fmor-cong (P × Q)   es = strong-prod-m-cong (strong-fmor-cong P es) (strong-fmor-cong Q es)
+    strong-fmor-cong (μ P)     es = strong-μ-fmor-cong P es
+
+    strong-μ-fmor-cong : ∀ {n Γ} (P : Poly 𝒞 (suc n)) {δ δ' : Fin n → obj}
+                         {fs fs' : ∀ i → prod Γ (δ i) ⇒ δ' i} →
+                         (∀ i → fs i ≈ fs' i) → strong-μ-fmor P fs ≈ strong-μ-fmor P fs'
+    strong-μ-fmor-cong P {δ} {δ'} {fs} {fs'} es =
+      ⦅⦆-cong P δ (∘-cong ≈-refl (strong-fmor-cong P sem-es))
+      where
+        sem-es : ∀ i → strong-extend-mor fs p₂ i ≈ strong-extend-mor fs' p₂ i
+        sem-es Fin.zero    = ≈-refl
+        sem-es (Fin.suc i) = es i
+
+  -- Pointwise co-Kleisli composition of extended environments is the extension
+  -- of the composites.
+  strong-extend-mor-comp : ∀ {n Γ} {δ δ' δ'' : Fin n → obj} {X Y Z}
+    {as : ∀ i → prod Γ (δ' i) ⇒ δ'' i} {bs : ∀ i → prod Γ (δ i) ⇒ δ' i} {cs : ∀ i → prod Γ (δ i) ⇒ δ'' i}
+    {x : prod Γ Y ⇒ Z} {y : prod Γ X ⇒ Y} {z : prod Γ X ⇒ Z} →
+    (∀ i → (as i ∘co bs i) ≈ cs i) → ((x ∘co y) ≈ z) →
+    ∀ i → (strong-extend-mor as x i ∘co strong-extend-mor bs y i) ≈ strong-extend-mor cs z i
+  strong-extend-mor-comp es ez Fin.zero    = ez
+  strong-extend-mor-comp es ez (Fin.suc i) = es i
+
+  -- The strong action is functorial: composites of actions are actions of
+  -- pointwise co-Kleisli composites.
+  mutual
+    strong-fmor-comp : ∀ {n Γ} (P : Poly 𝒞 n) {δ δ' δ'' : Fin n → obj}
+                       (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                       (strong-fmor P gs ∘co strong-fmor P fs) ≈ strong-fmor P (λ i → gs i ∘co fs i)
+    strong-fmor-comp (const A) gs fs = CoK.id-left
+    strong-fmor-comp (var i)   gs fs = ≈-refl
+    strong-fmor-comp (P + Q)   gs fs =
+      ≈-trans (scopair-comp _ _ _ _)
+              (scopair-cong (∘-cong ≈-refl (strong-fmor-comp P gs fs))
+                            (∘-cong ≈-refl (strong-fmor-comp Q gs fs)))
+    strong-fmor-comp (P × Q)   gs fs =
+      ≈-trans (strong-prod-m-comp _ _ _ _)
+              (strong-prod-m-cong (strong-fmor-comp P gs fs) (strong-fmor-comp Q gs fs))
+    strong-fmor-comp (μ P)     gs fs = strong-μ-fmor-comp P gs fs
+
+    -- Fusion: postcomposition with an algebra morphism takes folds to folds.
+    fusion : ∀ {n Γ A B} {P : Poly 𝒞 (suc n)} {δ : Fin n → obj}
+             (a : prod Γ (fobj μ-obj P (extend δ A)) ⇒ A)
+             (b : prod Γ (fobj μ-obj P (extend δ B)) ⇒ B)
+             (h : prod Γ A ⇒ B) →
+             ((h ∘co a) ≈ (b ∘co strong-fmor P (strong-extend-mor (λ i → p₂) h))) →
+             (h ∘co ⦅ a ⦆) ≈ ⦅ b ⦆
+    fusion {P = P} {δ = δ} a b h hyp =
+      ⦅⦆-η b (h ∘co ⦅ a ⦆)
+        (begin
+          (h ∘co ⦅ a ⦆) ∘co (inMap P δ ∘ p₂)
+        ≈⟨ CoK.assoc _ _ _ ⟩
+          h ∘co (⦅ a ⦆ ∘co (inMap P δ ∘ p₂))
+        ≈⟨ CoK.∘-cong ≈-refl (⦅⦆-β {P = P} {δ = δ} a) ⟩
+          h ∘co (a ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) ⦅ a ⦆))
+        ≈˘⟨ CoK.assoc _ _ _ ⟩
+          (h ∘co a) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) ⦅ a ⦆)
+        ≈⟨ CoK.∘-cong hyp ≈-refl ⟩
+          (b ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) h)) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) ⦅ a ⦆)
+        ≈⟨ CoK.assoc _ _ _ ⟩
+          b ∘co (strong-fmor P (strong-extend-mor (λ _ → p₂) h) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) ⦅ a ⦆))
+        ≈⟨ CoK.∘-cong ≈-refl (≈-trans (strong-fmor-comp P _ _) (strong-fmor-cong P (strong-extend-mor-comp (λ _ → CoK.id-left) ≈-refl))) ⟩
+          b ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) (h ∘co ⦅ a ⦆))
+        ∎)
+      where open ≈-Reasoning isEquiv
+
+    strong-μ-fmor-comp : ∀ {n Γ} (P : Poly 𝒞 (suc n)) {δ δ' δ'' : Fin n → obj}
+                         (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                         (strong-μ-fmor P gs ∘co strong-μ-fmor P fs) ≈ strong-μ-fmor P (λ i → gs i ∘co fs i)
+    strong-μ-fmor-comp P {δ} {δ'} {δ''} gs fs =
+      fusion alg-f alg μ-gs head'
+      where
+        μ-gs = strong-μ-fmor P gs
+        alg-f = inMap P δ' ∘ strong-fmor P (strong-extend-mor fs p₂)
+        alg-g = inMap P δ'' ∘ strong-fmor P (strong-extend-mor gs p₂)
+        alg = inMap P δ'' ∘ strong-fmor P (strong-extend-mor (λ i → gs i ∘co fs i) p₂)
+
+        head : (μ-gs ∘co alg-f) ≈ (alg-g ∘co strong-fmor P (strong-extend-mor fs μ-gs))
+        head =
+          begin
+            μ-gs ∘co (inMap P δ' ∘ strong-fmor P (strong-extend-mor fs p₂))
+          ≈˘⟨ ∘co-push μ-gs (inMap P δ') _ ⟩
+            (μ-gs ∘co (inMap P δ' ∘ p₂)) ∘co strong-fmor P (strong-extend-mor fs p₂)
+          ≈⟨ CoK.∘-cong (⦅⦆-β {P = P} {δ = δ'} alg-g) ≈-refl ⟩
+            (alg-g ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-gs)) ∘co strong-fmor P (strong-extend-mor fs p₂)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            alg-g ∘co (strong-fmor P (strong-extend-mor (λ _ → p₂) μ-gs) ∘co strong-fmor P (strong-extend-mor fs p₂))
+          ≈⟨ CoK.∘-cong ≈-refl (≈-trans (strong-fmor-comp P _ _) (strong-fmor-cong P (strong-extend-mor-comp (λ _ → CoK.id-left) CoK.id-right))) ⟩
+            alg-g ∘co strong-fmor P (strong-extend-mor fs μ-gs)
+          ∎ where open ≈-Reasoning isEquiv
+
+        head' : (μ-gs ∘co alg-f) ≈ (alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-gs))
+        head' =
+          begin
+            μ-gs ∘co alg-f
+          ≈⟨ head ⟩
+            alg-g ∘co strong-fmor P (strong-extend-mor fs μ-gs)
+          ≈⟨ assoc _ _ _ ⟩
+            inMap P δ'' ∘ (strong-fmor P (strong-extend-mor gs p₂) ∘co strong-fmor P (strong-extend-mor fs μ-gs))
+          ≈⟨ ∘-cong ≈-refl (≈-trans (strong-fmor-comp P _ _) (strong-fmor-cong P (strong-extend-mor-comp (λ _ → ≈-refl) CoK.id-left))) ⟩
+            inMap P δ'' ∘ strong-fmor P (strong-extend-mor (λ j → gs j ∘co fs j) μ-gs)
+          ≈˘⟨ ∘-cong ≈-refl (≈-trans (strong-fmor-comp P _ _) (strong-fmor-cong P (strong-extend-mor-comp (λ _ → CoK.id-right) CoK.id-left))) ⟩
+            inMap P δ'' ∘ (strong-fmor P (strong-extend-mor (λ j → gs j ∘co fs j) p₂) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-gs))
+          ≈˘⟨ assoc _ _ _ ⟩
+            alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-gs)
+          ∎ where open ≈-Reasoning isEquiv
+
+  -- The strong action interchanges with the componentwise action: post- or
+  -- pre-composing a strong action is absorbed into the environments.
+  mutual
+    pm-fmor-post : ∀ {n Γ} {P Q : Poly 𝒞 n} (r : PolyMor P Q) {δ δ' δ'' : Fin n → obj}
+                   (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                   (strong-fmor Q gs ∘co pm-fmor r fs) ≈ pm-fmor r (λ i → gs i ∘co fs i)
+    pm-fmor-post (const f) gs fs = CoK.id-left
+    pm-fmor-post (var i)   gs fs = ≈-refl
+    pm-fmor-post (r + s)   gs fs =
+      ≈-trans (scopair-comp _ _ _ _)
+              (scopair-cong (∘-cong ≈-refl (pm-fmor-post r gs fs))
+                            (∘-cong ≈-refl (pm-fmor-post s gs fs)))
+    pm-fmor-post (r × s)   gs fs =
+      ≈-trans (strong-prod-m-comp _ _ _ _)
+              (strong-prod-m-cong (pm-fmor-post r gs fs) (pm-fmor-post s gs fs))
+    pm-fmor-post (μ r)     gs fs = pm-μ-fmor-post r gs fs
+
+    pm-fmor-pre : ∀ {n Γ} {P Q : Poly 𝒞 n} (r : PolyMor P Q) {δ δ' δ'' : Fin n → obj}
+                  (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                  (pm-fmor r gs ∘co strong-fmor P fs) ≈ pm-fmor r (λ i → gs i ∘co fs i)
+    pm-fmor-pre (const f) gs fs = CoK.id-right
+    pm-fmor-pre (var i)   gs fs = ≈-refl
+    pm-fmor-pre (r + s)   gs fs =
+      ≈-trans (scopair-comp _ _ _ _)
+              (scopair-cong (∘-cong ≈-refl (pm-fmor-pre r gs fs))
+                            (∘-cong ≈-refl (pm-fmor-pre s gs fs)))
+    pm-fmor-pre (r × s)   gs fs =
+      ≈-trans (strong-prod-m-comp _ _ _ _)
+              (strong-prod-m-cong (pm-fmor-pre r gs fs) (pm-fmor-pre s gs fs))
+    pm-fmor-pre (μ r)     gs fs = pm-μ-fmor-pre r gs fs
+
+    pm-μ-fmor-post : ∀ {n Γ} {P Q : Poly 𝒞 (suc n)} (r : PolyMor P Q) {δ δ' δ'' : Fin n → obj}
+                     (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                     (strong-μ-fmor Q gs ∘co pm-μ-fmor r fs) ≈ pm-μ-fmor r (λ i → gs i ∘co fs i)
+    pm-μ-fmor-post {P = P} {Q = Q} r {δ} {δ'} {δ''} gs fs =
+      ⦅⦆-η {P = P} {δ = δ} alg (μ-gs ∘co μ-r) chain
+      where
+        μ-gs = strong-μ-fmor Q gs
+        μ-r = pm-μ-fmor r fs
+        alg-r = inMap Q δ' ∘ pm-fmor r (strong-extend-mor fs p₂)
+        alg-g = inMap Q δ'' ∘ strong-fmor Q (strong-extend-mor gs p₂)
+        alg = inMap Q δ'' ∘ pm-fmor r (strong-extend-mor (λ i → gs i ∘co fs i) p₂)
+
+        head : (μ-gs ∘co alg-r) ≈ (alg-g ∘co pm-fmor r (strong-extend-mor fs μ-gs))
+        head =
+          begin
+            μ-gs ∘co (inMap Q δ' ∘ pm-fmor r (strong-extend-mor fs p₂))
+          ≈˘⟨ ∘co-push μ-gs (inMap Q δ') _ ⟩
+            (μ-gs ∘co (inMap Q δ' ∘ p₂)) ∘co pm-fmor r (strong-extend-mor fs p₂)
+          ≈⟨ CoK.∘-cong (⦅⦆-β {P = Q} {δ = δ'} alg-g) ≈-refl ⟩
+            (alg-g ∘co strong-fmor Q (strong-extend-mor (λ _ → p₂) μ-gs)) ∘co pm-fmor r (strong-extend-mor fs p₂)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            alg-g ∘co (strong-fmor Q (strong-extend-mor (λ _ → p₂) μ-gs) ∘co pm-fmor r (strong-extend-mor fs p₂))
+          ≈⟨ CoK.∘-cong ≈-refl (≈-trans (pm-fmor-post r _ _) (pm-fmor-cong (pm-≈-refl r) (strong-extend-mor-comp (λ _ → CoK.id-left) CoK.id-right))) ⟩
+            alg-g ∘co pm-fmor r (strong-extend-mor fs μ-gs)
+          ∎ where open ≈-Reasoning isEquiv
+
+        chain : ((μ-gs ∘co μ-r) ∘co (inMap P δ ∘ p₂)) ≈ (alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) (μ-gs ∘co μ-r)))
+        chain =
+          begin
+            (μ-gs ∘co μ-r) ∘co (inMap P δ ∘ p₂)
+          ≈⟨ CoK.assoc μ-gs μ-r (inMap P δ ∘ p₂) ⟩
+            μ-gs ∘co (μ-r ∘co (inMap P δ ∘ p₂))
+          ≈⟨ CoK.∘-cong ≈-refl (⦅⦆-β {P = P} {δ = δ} alg-r) ⟩
+            μ-gs ∘co (alg-r ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-r))
+          ≈˘⟨ CoK.assoc μ-gs alg-r _ ⟩
+            (μ-gs ∘co alg-r) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-r)
+          ≈⟨ CoK.∘-cong head ≈-refl ⟩
+            (alg-g ∘co pm-fmor r (strong-extend-mor fs μ-gs)) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-r)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            alg-g ∘co (pm-fmor r (strong-extend-mor fs μ-gs) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-r))
+          ≈⟨ CoK.∘-cong ≈-refl (≈-trans (pm-fmor-pre r _ _) (pm-fmor-cong (pm-≈-refl r) (strong-extend-mor-comp (λ _ → CoK.id-right) ≈-refl))) ⟩
+            alg-g ∘co pm-fmor r (strong-extend-mor fs (μ-gs ∘co μ-r))
+          ≈⟨ assoc _ _ _ ⟩
+            inMap Q δ'' ∘ (strong-fmor Q (strong-extend-mor gs p₂) ∘co pm-fmor r (strong-extend-mor fs (μ-gs ∘co μ-r)))
+          ≈⟨ ∘-cong ≈-refl (≈-trans (pm-fmor-post r _ _) (pm-fmor-cong (pm-≈-refl r) (strong-extend-mor-comp (λ _ → ≈-refl) CoK.id-left))) ⟩
+            inMap Q δ'' ∘ pm-fmor r (strong-extend-mor (λ j → gs j ∘co fs j) (μ-gs ∘co μ-r))
+          ≈˘⟨ ∘-cong ≈-refl (≈-trans (pm-fmor-pre r _ _) (pm-fmor-cong (pm-≈-refl r) (strong-extend-mor-comp (λ _ → CoK.id-right) CoK.id-left))) ⟩
+            inMap Q δ'' ∘ (pm-fmor r (strong-extend-mor (λ j → gs j ∘co fs j) p₂) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) (μ-gs ∘co μ-r)))
+          ≈˘⟨ assoc _ _ _ ⟩
+            alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) (μ-gs ∘co μ-r))
+          ∎ where open ≈-Reasoning isEquiv
+
+    pm-μ-fmor-pre : ∀ {n Γ} {P Q : Poly 𝒞 (suc n)} (r : PolyMor P Q) {δ δ' δ'' : Fin n → obj}
+                    (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                    (pm-μ-fmor r gs ∘co strong-μ-fmor P fs) ≈ pm-μ-fmor r (λ i → gs i ∘co fs i)
+    pm-μ-fmor-pre {P = P} {Q = Q} r {δ} {δ'} {δ''} gs fs =
+      ⦅⦆-η {P = P} {δ = δ} alg (μ-r ∘co μ-fs) chain
+      where
+        μ-r = pm-μ-fmor r gs
+        μ-fs = strong-μ-fmor P fs
+        alg-f = inMap P δ' ∘ strong-fmor P (strong-extend-mor fs p₂)
+        alg-r = inMap Q δ'' ∘ pm-fmor r (strong-extend-mor gs p₂)
+        alg = inMap Q δ'' ∘ pm-fmor r (strong-extend-mor (λ i → gs i ∘co fs i) p₂)
+
+        head : (μ-r ∘co alg-f) ≈ (alg-r ∘co strong-fmor P (strong-extend-mor fs μ-r))
+        head =
+          begin
+            μ-r ∘co (inMap P δ' ∘ strong-fmor P (strong-extend-mor fs p₂))
+          ≈˘⟨ ∘co-push μ-r (inMap P δ') _ ⟩
+            (μ-r ∘co (inMap P δ' ∘ p₂)) ∘co strong-fmor P (strong-extend-mor fs p₂)
+          ≈⟨ CoK.∘-cong (⦅⦆-β {P = P} {δ = δ'} alg-r) ≈-refl ⟩
+            (alg-r ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-r)) ∘co strong-fmor P (strong-extend-mor fs p₂)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            alg-r ∘co (strong-fmor P (strong-extend-mor (λ _ → p₂) μ-r) ∘co strong-fmor P (strong-extend-mor fs p₂))
+          ≈⟨ CoK.∘-cong ≈-refl (≈-trans (strong-fmor-comp P _ _) (strong-fmor-cong P (strong-extend-mor-comp (λ _ → CoK.id-left) CoK.id-right))) ⟩
+            alg-r ∘co strong-fmor P (strong-extend-mor fs μ-r)
+          ∎ where open ≈-Reasoning isEquiv
+
+        chain : ((μ-r ∘co μ-fs) ∘co (inMap P δ ∘ p₂)) ≈ (alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) (μ-r ∘co μ-fs)))
+        chain =
+          begin
+            (μ-r ∘co μ-fs) ∘co (inMap P δ ∘ p₂)
+          ≈⟨ CoK.assoc μ-r μ-fs (inMap P δ ∘ p₂) ⟩
+            μ-r ∘co (μ-fs ∘co (inMap P δ ∘ p₂))
+          ≈⟨ CoK.∘-cong ≈-refl (⦅⦆-β {P = P} {δ = δ} alg-f) ⟩
+            μ-r ∘co (alg-f ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-fs))
+          ≈˘⟨ CoK.assoc μ-r alg-f _ ⟩
+            (μ-r ∘co alg-f) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-fs)
+          ≈⟨ CoK.∘-cong head ≈-refl ⟩
+            (alg-r ∘co strong-fmor P (strong-extend-mor fs μ-r)) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-fs)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            alg-r ∘co (strong-fmor P (strong-extend-mor fs μ-r) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-fs))
+          ≈⟨ CoK.∘-cong ≈-refl (≈-trans (strong-fmor-comp P _ _) (strong-fmor-cong P (strong-extend-mor-comp (λ _ → CoK.id-right) ≈-refl))) ⟩
+            alg-r ∘co strong-fmor P (strong-extend-mor fs (μ-r ∘co μ-fs))
+          ≈⟨ assoc _ _ _ ⟩
+            inMap Q δ'' ∘ (pm-fmor r (strong-extend-mor gs p₂) ∘co strong-fmor P (strong-extend-mor fs (μ-r ∘co μ-fs)))
+          ≈⟨ ∘-cong ≈-refl (≈-trans (pm-fmor-pre r _ _) (pm-fmor-cong (pm-≈-refl r) (strong-extend-mor-comp (λ _ → ≈-refl) CoK.id-left))) ⟩
+            inMap Q δ'' ∘ pm-fmor r (strong-extend-mor (λ j → gs j ∘co fs j) (μ-r ∘co μ-fs))
+          ≈˘⟨ ∘-cong ≈-refl (≈-trans (pm-fmor-pre r _ _) (pm-fmor-cong (pm-≈-refl r) (strong-extend-mor-comp (λ _ → CoK.id-right) CoK.id-left))) ⟩
+            inMap Q δ'' ∘ (pm-fmor r (strong-extend-mor (λ j → gs j ∘co fs j) p₂) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) (μ-r ∘co μ-fs)))
+          ≈˘⟨ assoc _ _ _ ⟩
+            alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) (μ-r ∘co μ-fs))
+          ∎ where open ≈-Reasoning isEquiv
+
+  -- The componentwise action is functorial: composites of actions are actions
+  -- of composite labels and pointwise co-Kleisli composite environments.
+  mutual
+    pm-fmor-comp : ∀ {n Γ} {P Q R : Poly 𝒞 n} (s : PolyMor Q R) (r : PolyMor P Q) {δ δ' δ'' : Fin n → obj}
+                   (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                   (pm-fmor s gs ∘co pm-fmor r fs) ≈ pm-fmor (s ∙ r) (λ i → gs i ∘co fs i)
+    pm-fmor-comp (const g) (const f) gs fs =
+      ≈-trans (assoc _ _ _) (≈-trans (∘-cong ≈-refl (pair-p₂ _ _)) (≈-sym (assoc _ _ _)))
+    pm-fmor-comp (var i)   (var .i)  gs fs = ≈-refl
+    pm-fmor-comp (s + t)   (r + u)   gs fs =
+      ≈-trans (scopair-comp _ _ _ _)
+              (scopair-cong (∘-cong ≈-refl (pm-fmor-comp s r gs fs))
+                            (∘-cong ≈-refl (pm-fmor-comp t u gs fs)))
+    pm-fmor-comp (s × t)   (r × u)   gs fs =
+      ≈-trans (strong-prod-m-comp _ _ _ _)
+              (strong-prod-m-cong (pm-fmor-comp s r gs fs) (pm-fmor-comp t u gs fs))
+    pm-fmor-comp (μ s)     (μ r)     gs fs = pm-μ-fmor-comp s r gs fs
+
+    pm-μ-fmor-comp : ∀ {n Γ} {P Q R : Poly 𝒞 (suc n)} (s : PolyMor Q R) (r : PolyMor P Q) {δ δ' δ'' : Fin n → obj}
+                     (gs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                     (pm-μ-fmor s gs ∘co pm-μ-fmor r fs) ≈ pm-μ-fmor (s ∙ r) (λ i → gs i ∘co fs i)
+    pm-μ-fmor-comp {P = P} {Q = Q} {R = R} s r {δ} {δ'} {δ''} gs fs =
+      fusion alg-r alg μ-s head'
+      where
+        μ-s = pm-μ-fmor s gs
+        μ-r = pm-μ-fmor r fs
+        alg-r = inMap Q δ' ∘ pm-fmor r (strong-extend-mor fs p₂)
+        alg-s = inMap R δ'' ∘ pm-fmor s (strong-extend-mor gs p₂)
+        alg = inMap R δ'' ∘ pm-fmor (s ∙ r) (strong-extend-mor (λ i → gs i ∘co fs i) p₂)
+
+        head : (μ-s ∘co alg-r) ≈ (alg-s ∘co pm-fmor r (strong-extend-mor fs μ-s))
+        head =
+          begin
+            μ-s ∘co (inMap Q δ' ∘ pm-fmor r (strong-extend-mor fs p₂))
+          ≈˘⟨ ∘co-push μ-s (inMap Q δ') _ ⟩
+            (μ-s ∘co (inMap Q δ' ∘ p₂)) ∘co pm-fmor r (strong-extend-mor fs p₂)
+          ≈⟨ CoK.∘-cong (⦅⦆-β {P = Q} {δ = δ'} alg-s) ≈-refl ⟩
+            (alg-s ∘co strong-fmor Q (strong-extend-mor (λ _ → p₂) μ-s)) ∘co pm-fmor r (strong-extend-mor fs p₂)
+          ≈⟨ CoK.assoc _ _ _ ⟩
+            alg-s ∘co (strong-fmor Q (strong-extend-mor (λ _ → p₂) μ-s) ∘co pm-fmor r (strong-extend-mor fs p₂))
+          ≈⟨ CoK.∘-cong ≈-refl (≈-trans (pm-fmor-post r _ _) (pm-fmor-cong (pm-≈-refl r) (strong-extend-mor-comp (λ _ → CoK.id-left) CoK.id-right))) ⟩
+            alg-s ∘co pm-fmor r (strong-extend-mor fs μ-s)
+          ∎ where open ≈-Reasoning isEquiv
+
+        head' : (μ-s ∘co alg-r) ≈ (alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-s))
+        head' =
+          begin
+            μ-s ∘co alg-r
+          ≈⟨ head ⟩
+            alg-s ∘co pm-fmor r (strong-extend-mor fs μ-s)
+          ≈⟨ assoc _ _ _ ⟩
+            inMap R δ'' ∘ (pm-fmor s (strong-extend-mor gs p₂) ∘co pm-fmor r (strong-extend-mor fs μ-s))
+          ≈⟨ ∘-cong ≈-refl (≈-trans (pm-fmor-comp s r _ _) (pm-fmor-cong (pm-≈-refl (s ∙ r)) (strong-extend-mor-comp (λ _ → ≈-refl) CoK.id-left))) ⟩
+            inMap R δ'' ∘ pm-fmor (s ∙ r) (strong-extend-mor (λ j → gs j ∘co fs j) μ-s)
+          ≈˘⟨ ∘-cong ≈-refl (≈-trans (pm-fmor-pre (s ∙ r) _ _) (pm-fmor-cong (pm-≈-refl (s ∙ r)) (strong-extend-mor-comp (λ _ → CoK.id-right) CoK.id-left))) ⟩
+            inMap R δ'' ∘ (pm-fmor (s ∙ r) (strong-extend-mor (λ j → gs j ∘co fs j) p₂) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-s))
+          ≈˘⟨ assoc _ _ _ ⟩
+            alg ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) μ-s)
+          ∎ where open ≈-Reasoning isEquiv
+
+  -- On identity environments the strong action is the identity.
+  mutual
+    strong-fmor-p₂ : ∀ {n Γ} (P : Poly 𝒞 n) {δ : Fin n → obj} →
+                     strong-fmor {Γ = Γ} P {δ} {δ} (λ i → p₂) ≈ p₂
+    strong-fmor-p₂ (const A) = ≈-refl
+    strong-fmor-p₂ (var i)   = ≈-refl
+    strong-fmor-p₂ (P + Q)   =
+      ≈-trans (scopair-cong (∘-cong ≈-refl (strong-fmor-p₂ P)) (∘-cong ≈-refl (strong-fmor-p₂ Q)))
+              scopair-ext0
+    strong-fmor-p₂ (P × Q)   =
+      ≈-trans (strong-prod-m-cong (strong-fmor-p₂ P) (strong-fmor-p₂ Q))
+              (≈-trans (pair-cong (pair-p₂ _ _) (pair-p₂ _ _)) (pair-ext _))
+    strong-fmor-p₂ (μ P)     = strong-μ-fmor-p₂ P
+
+    strong-μ-fmor-p₂ : ∀ {n Γ} (P : Poly 𝒞 (suc n)) {δ : Fin n → obj} →
+                       strong-μ-fmor {Γ = Γ} P {δ} {δ} (λ i → p₂) ≈ p₂
+    strong-μ-fmor-p₂ P {δ} =
+      ≈-sym (⦅⦆-η {P = P} {δ = δ} alg₀ p₂ premise)
+      where
+        alg₀ : prod _ (fobj μ-obj P (extend δ (μ-obj P δ))) ⇒ μ-obj P δ
+        alg₀ = inMap P δ ∘ strong-fmor P (strong-extend-mor {X = μ-obj P δ} {Y = μ-obj P δ} (λ _ → p₂) p₂)
+
+        es₀ : ∀ i → strong-extend-mor {X = μ-obj P δ} {Y = μ-obj P δ} (λ _ → p₂) p₂ i ≈ p₂
+        es₀ Fin.zero    = ≈-refl
+        es₀ (Fin.suc i) = ≈-refl
+
+        rhs : (alg₀ ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) p₂)) ≈ (inMap P δ ∘ p₂)
+        rhs =
+          begin
+            alg₀ ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) p₂)
+          ≈⟨ assoc _ _ _ ⟩
+            inMap P δ ∘ (strong-fmor P (strong-extend-mor (λ _ → p₂) p₂) ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) p₂))
+          ≈⟨ ∘-cong ≈-refl (≈-trans (strong-fmor-comp P _ _) (strong-fmor-cong P (strong-extend-mor-comp (λ _ → CoK.id-left) CoK.id-left))) ⟩
+            inMap P δ ∘ strong-fmor P (strong-extend-mor (λ _ → p₂) p₂)
+          ≈⟨ ∘-cong ≈-refl (strong-fmor-cong P es₀) ⟩
+            inMap P δ ∘ strong-fmor P (λ i → p₂)
+          ≈⟨ ∘-cong ≈-refl (strong-fmor-p₂ P) ⟩
+            inMap P δ ∘ p₂
+          ∎ where open ≈-Reasoning isEquiv
+
+        premise : (p₂ ∘co (inMap P δ ∘ p₂)) ≈ (alg₀ ∘co strong-fmor P (strong-extend-mor (λ _ → p₂) p₂))
+        premise = ≈-trans CoK.id-left (≈-sym rhs)
+
+  -- Componentwise isomorphic polynomials have isomorphic μ-objects.
+  pm-μ-iso : ∀ {n} {P Q : Poly 𝒞 (suc n)} (r : PolyIso P Q) {δ δ' : Fin n → obj} →
+             (es : ∀ i → Iso (δ i) (δ' i)) → Iso (μ-obj P δ) (μ-obj Q δ')
+  pm-μ-iso {P = P} {Q = Q} r {δ} {δ'} es = record
+    { fwd = pm-μ-fmor (r .PolyIso.fwd) (λ i → es i .Iso.fwd ∘ p₂) ∘ sect
+    ; bwd = pm-μ-fmor (r .PolyIso.bwd) (λ i → es i .Iso.bwd ∘ p₂) ∘ sect
+    ; fwd∘bwd≈id = roundtrip Q (r .PolyIso.bwd) (r .PolyIso.fwd) (r .PolyIso.fwd∘bwd)
+                     (λ i → es i .Iso.bwd) (λ i → es i .Iso.fwd) (λ i → es i .Iso.fwd∘bwd≈id)
+    ; bwd∘fwd≈id = roundtrip P (r .PolyIso.fwd) (r .PolyIso.bwd) (r .PolyIso.bwd∘fwd)
+                     (λ i → es i .Iso.fwd) (λ i → es i .Iso.bwd) (λ i → es i .Iso.bwd∘fwd≈id)
+    }
+    where
+      roundtrip : ∀ {n} (A : Poly 𝒞 (suc n)) {B : Poly 𝒞 (suc n)} {δA δB : Fin n → obj}
+                  (u : PolyMor A B) (v : PolyMor B A) → PolyMor-≈ (v ∙ u) (pm-id A) →
+                  (us : ∀ i → δA i ⇒ δB i) (vs : ∀ i → δB i ⇒ δA i) → (∀ i → (vs i ∘ us i) ≈ id (δA i)) →
+                  ((pm-μ-fmor v (λ i → vs i ∘ p₂) ∘ sect) ∘ (pm-μ-fmor u (λ i → us i ∘ p₂) ∘ sect)) ≈ id (μ-obj A δA)
+      roundtrip A {B} {δA} {δB} u v vu us vs law =
+        ≈-trans (unitor-comp _ _)
+        (≈-trans (∘-cong (pm-μ-fmor-comp v u _ _) ≈-refl)
+        (≈-trans (∘-cong (pm-μ-fmor-cong vu env-law) ≈-refl)
+        (≈-trans (∘-cong (pm-μ-fmor-id A _) ≈-refl)
+        (≈-trans (∘-cong (strong-μ-fmor-p₂ A) ≈-refl)
+                 (pair-p₂ _ _)))))
+        where
+          env-law : ∀ i → ((vs i ∘ p₂) ∘co (us i ∘ p₂)) ≈ p₂
+          env-law i =
+            begin
+              (vs i ∘ p₂) ∘ pair p₁ (us i ∘ p₂)
+            ≈⟨ assoc _ _ _ ⟩
+              vs i ∘ (p₂ ∘ pair p₁ (us i ∘ p₂))
+            ≈⟨ ∘-cong ≈-refl (pair-p₂ _ _) ⟩
+              vs i ∘ (us i ∘ p₂)
+            ≈˘⟨ assoc _ _ _ ⟩
+              (vs i ∘ us i) ∘ p₂
+            ≈⟨ ∘-cong (law i) ≈-refl ⟩
+              id _ ∘ p₂
+            ≈⟨ id-left ⟩
+              p₂
+            ∎ where open ≈-Reasoning isEquiv
+
+  -- Congruences for componentwise isomorphisms.
+  pm-iso-const : ∀ {n A B} → Iso A B → PolyIso {n} (const A) (const B)
+  pm-iso-const i .PolyIso.fwd     = const (i .Iso.fwd)
+  pm-iso-const i .PolyIso.bwd     = const (i .Iso.bwd)
+  pm-iso-const i .PolyIso.bwd∘fwd = const (i .Iso.bwd∘fwd≈id)
+  pm-iso-const i .PolyIso.fwd∘bwd = const (i .Iso.fwd∘bwd≈id)
+
+  pm-iso-var : ∀ {n} (i : Fin n) → PolyIso (var i) (var i)
+  pm-iso-var i .PolyIso.fwd     = var i
+  pm-iso-var i .PolyIso.bwd     = var i
+  pm-iso-var i .PolyIso.bwd∘fwd = var i
+  pm-iso-var i .PolyIso.fwd∘bwd = var i
+
+  pm-iso-sum : ∀ {n} {P P' Q Q' : Poly 𝒞 n} → PolyIso P P' → PolyIso Q Q' → PolyIso (P + Q) (P' + Q')
+  pm-iso-sum r s .PolyIso.fwd     = r .PolyIso.fwd + s .PolyIso.fwd
+  pm-iso-sum r s .PolyIso.bwd     = r .PolyIso.bwd + s .PolyIso.bwd
+  pm-iso-sum r s .PolyIso.bwd∘fwd = r .PolyIso.bwd∘fwd + s .PolyIso.bwd∘fwd
+  pm-iso-sum r s .PolyIso.fwd∘bwd = r .PolyIso.fwd∘bwd + s .PolyIso.fwd∘bwd
+
+  pm-iso-prod : ∀ {n} {P P' Q Q' : Poly 𝒞 n} → PolyIso P P' → PolyIso Q Q' → PolyIso (P × Q) (P' × Q')
+  pm-iso-prod r s .PolyIso.fwd     = r .PolyIso.fwd × s .PolyIso.fwd
+  pm-iso-prod r s .PolyIso.bwd     = r .PolyIso.bwd × s .PolyIso.bwd
+  pm-iso-prod r s .PolyIso.bwd∘fwd = r .PolyIso.bwd∘fwd × s .PolyIso.bwd∘fwd
+  pm-iso-prod r s .PolyIso.fwd∘bwd = r .PolyIso.fwd∘bwd × s .PolyIso.fwd∘bwd
+
+  pm-iso-μ : ∀ {n} {P P' : Poly 𝒞 (suc n)} → PolyIso P P' → PolyIso (μ P) (μ P')
+  pm-iso-μ r .PolyIso.fwd     = μ (r .PolyIso.fwd)
+  pm-iso-μ r .PolyIso.bwd     = μ (r .PolyIso.bwd)
+  pm-iso-μ r .PolyIso.bwd∘fwd = μ (r .PolyIso.bwd∘fwd)
+  pm-iso-μ r .PolyIso.fwd∘bwd = μ (r .PolyIso.fwd∘bwd)
+
+  -- Reindexing the context of the strong action and of catamorphisms:
+  -- precomposition with prod-m u id commutes with both.
+  ⦅⦆-reindex : ∀ {n Γ Γ' A} (P : Poly 𝒞 (suc n)) (δ : Fin n → obj) (u : Γ' ⇒ Γ)
+               (alg : prod Γ (fobj μ-obj P (extend δ A)) ⇒ A) →
+               (⦅_⦆ {P = P} {δ = δ} alg ∘ prod-m u (id _)) ≈ ⦅_⦆ {P = P} {δ = δ} (alg ∘ prod-m u (id _))
+
+  strong-fmor-reindex : ∀ {n Γ Γ'} (P : Poly 𝒞 n) {δ δ' : Fin n → obj} (u : Γ' ⇒ Γ)
+                        (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                        (strong-fmor P fs ∘ prod-m u (id _)) ≈ strong-fmor P (λ i → fs i ∘ prod-m u (id _))
+
+  strong-fmor-reindex (const A) u fs = ≈-trans (pair-p₂ _ _) id-left
+  strong-fmor-reindex (var i)   u fs = ≈-refl
+  strong-fmor-reindex (P + Q)   u fs =
+    ≈-trans (scopair-reindex u _ _)
+      (scopair-cong
+        (≈-trans (assoc _ _ _) (∘-cong ≈-refl (strong-fmor-reindex P u fs)))
+        (≈-trans (assoc _ _ _) (∘-cong ≈-refl (strong-fmor-reindex Q u fs))))
+  strong-fmor-reindex (P × Q)   u fs =
+    ≈-trans (∘-cong ≈-refl (prod-m-cong ≈-refl (≈-sym prod-m-id)))
+      (≈-trans (strong-prod-m-pre _ _ _ _ _)
+        (strong-prod-m-cong (strong-fmor-reindex P u fs) (strong-fmor-reindex Q u fs)))
+  strong-fmor-reindex (μ P) {δ} {δ'} u fs =
+    ≈-trans (⦅⦆-reindex P δ u _)
+      (⦅⦆-cong P δ
+        (≈-trans (assoc _ _ _)
+          (∘-cong ≈-refl
+            (≈-trans (strong-fmor-reindex P u (strong-extend-mor fs p₂))
+              (strong-fmor-cong P pointwise)))))
+    where
+      pointwise : ∀ i → (strong-extend-mor fs p₂ i ∘ prod-m u (id _))
+                        ≈ strong-extend-mor (λ j → fs j ∘ prod-m u (id _)) p₂ i
+      pointwise Fin.zero    = ≈-trans (pair-p₂ _ _) id-left
+      pointwise (Fin.suc i) = ≈-refl
+
+  ⦅⦆-reindex {n} {Γ} {Γ'} {A} P δ u alg =
+    ⦅⦆-η {P = P} {δ = δ} (alg ∘ prod-m u (id _)) (⦅_⦆ {P = P} {δ = δ} alg ∘ prod-m u (id _)) sq
+    where
+      h = ⦅_⦆ {P = P} {δ = δ} alg ∘ prod-m u (id _)
+
+      pointwise : ∀ i → (strong-extend-mor (λ j → p₂) (⦅_⦆ {P = P} {δ = δ} alg) i ∘ prod-m u (id _))
+                        ≈ strong-extend-mor (λ j → p₂) h i
+      pointwise Fin.zero    = ≈-refl
+      pointwise (Fin.suc i) = ≈-trans (pair-p₂ _ _) id-left
+
+      lhs-chain : (h ∘co (inMap P δ ∘ p₂)) ≈ (alg ∘ pair (u ∘ p₁) (strong-fmor P (strong-extend-mor (λ i → p₂) h)))
+      lhs-chain =
+        begin
+          (⦅_⦆ {P = P} {δ = δ} alg ∘ prod-m u (id _)) ∘ pair p₁ (inMap P δ ∘ p₂)
+        ≈⟨ assoc _ _ _ ⟩
+          ⦅_⦆ {P = P} {δ = δ} alg ∘ (prod-m u (id _) ∘ pair p₁ (inMap P δ ∘ p₂))
+        ≈⟨ ∘-cong ≈-refl (prodm-pair-interchange u (inMap P δ)) ⟩
+          ⦅_⦆ {P = P} {δ = δ} alg ∘ (pair p₁ (inMap P δ ∘ p₂) ∘ prod-m u (id _))
+        ≈˘⟨ assoc _ _ _ ⟩
+          (⦅_⦆ {P = P} {δ = δ} alg ∘ pair p₁ (inMap P δ ∘ p₂)) ∘ prod-m u (id _)
+        ≈⟨ ∘-cong (⦅⦆-β alg) ≈-refl ⟩
+          (alg ∘ pair p₁ (strong-fmor P (strong-extend-mor (λ i → p₂) (⦅_⦆ {P = P} {δ = δ} alg)))) ∘ prod-m u (id _)
+        ≈⟨ assoc _ _ _ ⟩
+          alg ∘ (pair p₁ (strong-fmor P (strong-extend-mor (λ i → p₂) (⦅_⦆ {P = P} {δ = δ} alg))) ∘ prod-m u (id _))
+        ≈⟨ ∘-cong ≈-refl (pair-natural _ _ _) ⟩
+          alg ∘ pair (p₁ ∘ prod-m u (id _)) (strong-fmor P (strong-extend-mor (λ i → p₂) (⦅_⦆ {P = P} {δ = δ} alg)) ∘ prod-m u (id _))
+        ≈⟨ ∘-cong ≈-refl (pair-cong (pair-p₁ _ _) (≈-trans (strong-fmor-reindex P u _) (strong-fmor-cong P pointwise))) ⟩
+          alg ∘ pair (u ∘ p₁) (strong-fmor P (strong-extend-mor (λ i → p₂) h))
+        ∎ where open ≈-Reasoning isEquiv
+
+
+      rhs-chain : ((alg ∘ prod-m u (id _)) ∘co strong-fmor P (strong-extend-mor (λ i → p₂) h))
+                  ≈ (alg ∘ pair (u ∘ p₁) (strong-fmor P (strong-extend-mor (λ i → p₂) h)))
+      rhs-chain =
+        begin
+          (alg ∘ prod-m u (id _)) ∘ pair p₁ (strong-fmor P (strong-extend-mor (λ i → p₂) h))
+        ≈⟨ assoc _ _ _ ⟩
+          alg ∘ (prod-m u (id _) ∘ pair p₁ (strong-fmor P (strong-extend-mor (λ i → p₂) h)))
+        ≈⟨ ∘-cong ≈-refl (pair-compose _ _ _ _) ⟩
+          alg ∘ pair (u ∘ p₁) (id _ ∘ strong-fmor P (strong-extend-mor (λ i → p₂) h))
+        ≈⟨ ∘-cong ≈-refl (pair-cong ≈-refl id-left) ⟩
+          alg ∘ pair (u ∘ p₁) (strong-fmor P (strong-extend-mor (λ i → p₂) h))
+        ∎ where open ≈-Reasoning isEquiv
+
+      sq : (h ∘co (inMap P δ ∘ p₂)) ≈ ((alg ∘ prod-m u (id _)) ∘co strong-fmor P (strong-extend-mor (λ i → p₂) h))
+      sq = ≈-trans lhs-chain (≈-sym rhs-chain)
diff --git a/agda/src/presheaf-predicate.agda b/agda/src/presheaf-predicate.agda
index 6e580d86..00d4e132 100644
--- a/agda/src/presheaf-predicate.agda
+++ b/agda/src/presheaf-predicate.agda
@@ -317,306 +317,190 @@ module Monad-hat-pred (M : Monad 𝒞) where
 -- FIXME: this ought to work for comonads too
 
 ------------------------------------------------------------------------------
--- Coproduct closure. This monad is "sheafification" monad for
--- Grothendieck logical relations a la Simpson and Fiore for the
--- “extensive topology” on 𝒞.
-
--- FIXME: move this to another file
-
-open import stable-coproducts
-
-module CoproductMonad (𝒞CP : HasCoproducts 𝒞) (stable : Stable 𝒞CP) where
-
-  private
-    module 𝒞CP = HasCoproducts 𝒞CP
+-- Closure operator generated by a coverage: each object carries a set of
+-- covers, a cover being an indexed family of injections, and covers pull back
+-- along any morphism. Covers enter the trees as codes, so the index data
+-- stays at the level of the predicates. The trees are Prop-valued: with
+-- infinitary covers, idempotence needs a subtree for each index out of a
+-- family of covering proofs, which a truncated tree cannot supply.
+module CoverMonad
+    (Cover : 𝒞.obj → Set ℓ)
+    (Ix : ∀ {y} → Cover y → Set ℓ)
+    (dom : ∀ {y} (c : Cover y) → Ix c → 𝒞.obj)
+    (inj : ∀ {y} (c : Cover y) (s : Ix c) → dom c s 𝒞.⇒ y)
+  where
 
   open Setoid
   open _⇒s_
   open setoid-predicate.Predicate
   open setoid-predicate._⊑_
-  open 𝒞.Iso
 
-  data Context (X : PSh.obj) (P : Predicate X) : (a : 𝒞.obj) → X .fobj a .Carrier → Set ℓ where
+  -- A cover of the target pulls back along any morphism to a cover of the
+  -- source, one leg per index.
+  record CoverPullback {x y} (c : Cover x) (g : y 𝒞.⇒ x) : Set ℓ where
+    field
+      cover : Cover y
+      reix  : Ix cover → Ix c
+      leg   : ∀ s → dom cover s 𝒞.⇒ dom c (reix s)
+      eq    : ∀ s → (inj c (reix s) 𝒞.∘ leg s) 𝒞.≈ (g 𝒞.∘ inj cover s)
+  open CoverPullback
+
+  data Context (X : PSh.obj) (P : Predicate X) : (a : 𝒞.obj) → X .fobj a .Carrier → Prop ℓ where
     leaf : ∀ {a x} → P .pred a .pred x → Context X P a x
-    node : ∀ a b {c} x y {z} (f : 𝒞.Iso (𝒞CP.coprod a b) c) →
-           Context X P a x →
-           Context X P b y →
-           X .fobj a ._≈_ x (X .fmor (f .fwd 𝒞.∘ 𝒞CP.in₁) .func z) →
-           X .fobj b ._≈_ y (X .fmor (f .fwd 𝒞.∘ 𝒞CP.in₂) .func z) →
-           Context X P c z
-
-  Context-reindex : ∀ {X : PSh.obj} (P : Predicate X) →
-                    ∀ {a b} {x} (f : b 𝒞.⇒ a) → Context X P a x → Context X P b (X .fmor f .func x)
-  Context-reindex {X} P {a} {b} {x} f (leaf p) =
-    leaf (P .pred-mor f .*⊑* x p)
-  Context-reindex {X} P {a} {b} {x} f (node a₁ a₂ y₁ y₂ g t₁ t₂ eq₁ eq₂) =
-    node (stbl .StableBits.y₁) (stbl .StableBits.y₂)
-         (X .fmor (stbl .StableBits.h₁) .func y₁)
-         (X .fmor (stbl .StableBits.h₂) .func y₂)
-         (stbl .StableBits.h)
-         (Context-reindex P (stbl .StableBits.h₁) t₁)
-         (Context-reindex P (stbl .StableBits.h₂) t₂)
-         eq₃
-         eq₄
-    where stbl = stable g f
-
-          eq₃ : X .fobj (stbl .StableBits.y₁) ._≈_ (X .fmor (stbl .StableBits.h₁) .func y₁) (X .fmor (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁) .func (X .fmor f .func x))
-          eq₃ = begin
-              X .fmor (stbl .StableBits.h₁) .func y₁
-            ≈⟨ X .fmor (stbl .StableBits.h₁) .func-resp-≈ eq₁ ⟩
-              X .fmor (stbl .StableBits.h₁) .func (X .fmor (g .fwd 𝒞.∘ 𝒞CP.in₁) .func x)
-            ≈˘⟨ X .fmor-comp _ _ .func-eq (X .fobj a .refl) ⟩
-              X .fmor ((g .fwd 𝒞.∘ 𝒞CP.in₁) 𝒞.∘ stbl .StableBits.h₁) .func x
-            ≈⟨ X .fmor-cong (𝒞.assoc _ _ _) .func-eq (X .fobj a .refl) ⟩
-              X .fmor (g .fwd 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)) .func x
-            ≈⟨ X .fmor-cong (stbl .StableBits.eq₁) .func-eq (X .fobj a .refl) ⟩
-              X .fmor (f 𝒞.∘ (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁)) .func x
-            ≈⟨ X .fmor-comp _ _ .func-eq (X .fobj a .refl) ⟩
-              X .fmor (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁) .func (X .fmor f .func x)
-            ∎
-            where open ≈-Reasoning (X .fobj (stbl .StableBits.y₁) .isEquivalence)
-
-          eq₄ : X .fobj (stbl .StableBits.y₂) ._≈_ (X .fmor (stbl .StableBits.h₂) .func y₂) (X .fmor (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂) .func (X .fmor f .func x))
-          eq₄ = begin
-              X .fmor (stbl .StableBits.h₂) .func y₂
-            ≈⟨ X .fmor (stbl .StableBits.h₂) .func-resp-≈ eq₂ ⟩
-              X .fmor (stbl .StableBits.h₂) .func (X .fmor (g .fwd 𝒞.∘ 𝒞CP.in₂) .func x)
-            ≈˘⟨ X .fmor-comp _ _ .func-eq (X .fobj a .refl) ⟩
-              X .fmor ((g .fwd 𝒞.∘ 𝒞CP.in₂) 𝒞.∘ stbl .StableBits.h₂) .func x
-            ≈⟨ X .fmor-cong (𝒞.assoc _ _ _) .func-eq (X .fobj a .refl) ⟩
-              X .fmor (g .fwd 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)) .func x
-            ≈⟨ X .fmor-cong (stbl .StableBits.eq₂) .func-eq (X .fobj a .refl) ⟩
-              X .fmor (f 𝒞.∘ (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂)) .func x
-            ≈⟨ X .fmor-comp _ _ .func-eq (X .fobj a .refl) ⟩
-              X .fmor (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂) .func (X .fmor f .func x)
-            ∎
-            where open ≈-Reasoning (X .fobj (stbl .StableBits.y₂) .isEquivalence)
+    node : ∀ {y z} (c : Cover y) (xs : ∀ s → X .fobj (dom c s) .Carrier) →
+           (∀ s → Context X P (dom c s) (xs s)) →
+           (∀ s → X .fobj (dom c s) ._≈_ (xs s) (X .fmor (inj c s) .func z)) →
+           Context X P y z
 
   Context-eq : ∀ {X} {P : Predicate X} {a x₁ x₂} → X .fobj a ._≈_ x₁ x₂ → Context X P a x₁ → Context X P a x₂
   Context-eq {X} {P} x₁≈x₂ (leaf p) = leaf (P .pred _ .pred-≃ x₁≈x₂ p)
-  Context-eq {X} {P} x₁≈x₂ (node a b x y f t₁ t₂ eq₁ eq₂) =
-    node a b x y f t₁ t₂
-         (X .fobj a .trans eq₁ (X .fmor _ .func-resp-≈ x₁≈x₂))
-         (X .fobj b .trans eq₂ (X .fmor _ .func-resp-≈ x₁≈x₂))
-
-  𝐂 : ∀ {X} → Predicate X → Predicate X
-  𝐂 P .pred a .pred x = LiftS ℓ (Context _ P a x)
-  𝐂 P .pred a .pred-≃ x₁≈x₂ (liftS t) = liftS (Context-eq x₁≈x₂ t)
-  𝐂 P .pred-mor f .*⊑* x (liftS p) = liftS (Context-reindex P f p)
-
-  Context-unit : ∀ {X : PSh.obj} {P : Predicate X} →
-                 ∀ {a x} → P .pred a .pred x → Context X P a x
-  Context-unit p = leaf p
-
-  Context-mono : ∀ {X : PSh.obj} {P Q : Predicate X} →
-                 ∀ (P⊑Q : P ⊑ Q) →
+  Context-eq {X} {P} x₁≈x₂ (node c xs ts eqs) =
+    node c xs ts (λ s → X .fobj (dom c s) .trans (eqs s) (X .fmor (inj c s) .func-resp-≈ x₁≈x₂))
+
+  Context-mono : ∀ {X : PSh.obj} {P Q : Predicate X} (P⊑Q : P ⊑ Q) →
                  ∀ {a x} → Context X P a x → Context X Q a x
   Context-mono P⊑Q (leaf p) = leaf (P⊑Q .*⊑* _ .*⊑* _ p)
-  Context-mono P⊑Q (node a b x y f t t₁ x₁ x₂) = node a b x y f (Context-mono P⊑Q t) (Context-mono P⊑Q t₁) x₁ x₂
+  Context-mono P⊑Q (node c xs ts eqs) = node c xs (λ s → Context-mono P⊑Q (ts s)) eqs
 
   Context-strong : ∀ {X : PSh.obj} {P Q : Predicate X} →
                    ∀ {a x} → Context X P a x → Q .pred a .pred x → Context X (P && Q) a x
   Context-strong (leaf p) q = leaf (p , q)
-  Context-strong {X} {P} {Q} (node a b x y f t₁ t₂ eq₁ eq₂) q =
-    node a b x y f
-         (Context-strong t₁ (Q .pred a .pred-≃ (X .fobj a .sym eq₁) (Q .pred-mor (f .fwd 𝒞.∘ 𝒞CP.in₁) .*⊑* _ q)))
-         (Context-strong t₂ (Q .pred b .pred-≃ (X .fobj b .sym eq₂) (Q .pred-mor (f .fwd 𝒞.∘ 𝒞CP.in₂) .*⊑* _ q)))
-         eq₁
-         eq₂
-
-  Context-join : ∀ {X : PSh.obj} {P : Predicate X} →
-                 ∀ {a x} → Context X (𝐂 P) a x → LiftS ℓ (Context X P a x)
-  Context-join {X} {P} {a} {x} (leaf (liftS t)) = liftS t
-  Context-join {X} {P} {a} {x} (node a₁ b x₁ y f t₁ t₂ eq₁ eq₂) with Context-join t₁
-  ... | liftS t₁' with Context-join t₂
-  ... | liftS t₂' = liftS (node a₁ b x₁ y f t₁' t₂' eq₁ eq₂)
-
-  𝐂-isClosure : ∀ {X} → IsClosureOp (⊑-isPreorder {X}) 𝐂
-  𝐂-isClosure .IsClosureOp.mono P⊑Q .*⊑* a .*⊑* x (liftS p) = liftS (Context-mono P⊑Q p)
-  𝐂-isClosure .IsClosureOp.unit .*⊑* a .*⊑* x p = liftS (Context-unit p)
-  𝐂-isClosure .IsClosureOp.closed .*⊑* a .*⊑* x (liftS p) = Context-join p
-
-  𝐂-strong : ∀ {X} {P Q : Predicate X} → (𝐂 P && Q) ⊑ 𝐂 (P && Q)
-  𝐂-strong .*⊑* a .*⊑* x (liftS p , q) = liftS (Context-strong p q)
+  Context-strong {X} {P} {Q} (node c xs ts eqs) q =
+    node c xs
+      (λ s → Context-strong (ts s)
+               (Q .pred (dom c s) .pred-≃ (X .fobj (dom c s) .sym (eqs s)) (Q .pred-mor (inj c s) .*⊑* _ q)))
+      eqs
 
   Context-[]⁻¹ : ∀ {X Y} {P : Predicate Y} {f : X PSh.⇒ Y} a x y →
                  Y .fobj a ._≈_ y (f .transf a .func x) →
                  Context Y P a y →
                  Context X (P [ f ]) a x
   Context-[]⁻¹ {X} {Y} {P} {f} a x y eq (leaf p) = leaf (P .pred a .pred-≃ eq p)
-  Context-[]⁻¹ {X} {Y} {P} {f} a x y eq (node a₁ a₂ y₁ y₂ i t₁ t₂ eq₁ eq₂) =
-    node a₁ a₂ x₁ x₂ i
-         (Context-[]⁻¹ a₁ x₁ y₁ eq₃ t₁)
-         (Context-[]⁻¹ a₂ x₂ y₂ eq₄ t₂)
-         (X .fobj a₁ .refl) (X .fobj a₂ .refl)
+  Context-[]⁻¹ {X} {Y} {P} {f} a x y eq (node c xs ts eqs) =
+    node c (λ s → X .fmor (inj c s) .func x)
+         (λ s → Context-[]⁻¹ (dom c s) (X .fmor (inj c s) .func x) (xs s) (eq' s) (ts s))
+         (λ s → X .fobj (dom c s) .refl)
     where
-      x₁ : X .fobj a₁ .Carrier
-      x₁ = X .fmor (i .fwd 𝒞.∘ 𝒞CP.in₁) .func x
-
-      x₂ : X .fobj a₂ .Carrier
-      x₂ = X .fmor (i .fwd 𝒞.∘ 𝒞CP.in₂) .func x
-
-      eq₃ : Y .fobj a₁ ._≈_ y₁ (f .transf a₁ .func x₁)
-      eq₃ = begin
-          y₁
-        ≈⟨ eq₁ ⟩
-          Y .fmor (i .fwd 𝒞.∘ 𝒞CP.in₁) .func y
-        ≈⟨ Y .fmor (i .fwd 𝒞.∘ 𝒞CP.in₁) .func-resp-≈ eq ⟩
-          Y .fmor (i .fwd 𝒞.∘ 𝒞CP.in₁) .func (f .transf a .func x)
-        ≈⟨ f .natural _ .func-eq (X .fobj a .refl) ⟩
-          f .transf a₁ .func (X .fmor (i .fwd 𝒞.∘ 𝒞CP.in₁) .func x)
-        ∎
-        where open ≈-Reasoning (Y .fobj a₁ .isEquivalence)
-
-      eq₄ : Y .fobj a₂ ._≈_ y₂ (f .transf a₂ .func x₂)
-      eq₄ = begin
-          y₂
-        ≈⟨ eq₂ ⟩
-          Y .fmor (i .fwd 𝒞.∘ 𝒞CP.in₂) .func y
-        ≈⟨ Y .fmor (i .fwd 𝒞.∘ 𝒞CP.in₂) .func-resp-≈ eq ⟩
-          Y .fmor (i .fwd 𝒞.∘ 𝒞CP.in₂) .func (f .transf a .func x)
+      eq' : ∀ s → Y .fobj (dom c s) ._≈_ (xs s) (f .transf (dom c s) .func (X .fmor (inj c s) .func x))
+      eq' s = begin
+          xs s
+        ≈⟨ eqs s ⟩
+          Y .fmor (inj c s) .func y
+        ≈⟨ Y .fmor (inj c s) .func-resp-≈ eq ⟩
+          Y .fmor (inj c s) .func (f .transf a .func x)
         ≈⟨ f .natural _ .func-eq (X .fobj a .refl) ⟩
-          f .transf a₂ .func (X .fmor (i .fwd 𝒞.∘ 𝒞CP.in₂) .func x)
+          f .transf (dom c s) .func (X .fmor (inj c s) .func x)
         ∎
-        where open ≈-Reasoning (Y .fobj a₂ .isEquivalence)
-
-  𝐂-[]⁻¹ : ∀ {X Y} {P : Predicate Y} {f : X PSh.⇒ Y} → (𝐂 P [ f ]) ⊑ 𝐂 (P [ f ])
-  𝐂-[]⁻¹ {X} {Y} {P} {f} .*⊑* a .*⊑* x (liftS t) =
-    liftS (Context-[]⁻¹ a x (f .transf a .func x) (Y .fobj a .refl) t)
+        where open ≈-Reasoning (Y .fobj (dom c s) .isEquivalence)
 
   Context-[] : ∀ {X Y} {P : Predicate Y} {f : X PSh.⇒ Y} a x →
                Context X (P [ f ]) a x →
                Context Y P a (f .transf a .func x)
   Context-[] a x (leaf p) = leaf p
-  Context-[] {X} {Y} {P} {f} a x (node a₁ a₂ x₁ x₂ i t₁ t₂ eq₁ eq₂) =
-    node a₁ a₂ (f .transf _ .func x₁) (f .transf _ .func x₂)
-         i
-         (Context-[] a₁ x₁ t₁) (Context-[] a₂ x₂ t₂)
-         (Y .fobj a₁ .trans (f .transf a₁ .func-resp-≈ eq₁) (Y .fobj a₁ .sym (f .natural _ .func-eq (X .fobj a .refl))))
-         (Y .fobj a₂ .trans (f .transf a₂ .func-resp-≈ eq₂) (Y .fobj a₂ .sym (f .natural _ .func-eq (X .fobj a .refl))))
-
-  𝐂-[] : ∀ {X Y} {P : Predicate Y} {f : X PSh.⇒ Y} → 𝐂 (P [ f ]) ⊑ (𝐂 P [ f ])
-  𝐂-[] {X} {Y} {P} {f} .*⊑* a .*⊑* x (liftS t) = liftS (Context-[] a x t)
-
-  closureOp : ClosureOp PSh products system
-  closureOp .ClosureOp.𝐂 = 𝐂
-  closureOp .ClosureOp.𝐂-isClosure = 𝐂-isClosure
-  closureOp .ClosureOp.𝐂-[] = 𝐂-[]
-  closureOp .ClosureOp.𝐂-[]⁻¹ = 𝐂-[]⁻¹
-  closureOp .ClosureOp.𝐂-strong = 𝐂-strong
-
-  -- Can't do this directly -- need an additional closure operator for
-  -- the monad that interleaves sum closure and functor lifting. Or to
-  -- assume that the functor 'F' preserves coproducts (a la the ◇
-  -- modality). Or we need to assume that it coproducts distribute
-  -- over the monad: M(x + y) → M x + M y, which isn't true for monads
-  -- in general, but is actually true for the lifting monad on Fam?
-
-  -- Given a predicate P on X : PSh, we define a predicate on M-hat F
-  -- P that interleaves binds with
-
-  open import finite-coproduct-functor using (preserve-chosen-coproducts; module preserve-chosen-coproducts-consequences)
-
-  -- If F preserves coproducts, then we get a distributive property
-  --
-  -- Presumably, this needs to also work with the rest of the
-  -- structure, like a real distributive law?
-  --
-  -- But we won't know that M-hat preserves coproducts? But maybe it does?!
-  --
-  -- And the lifting monad on Fam(LatGal) preserves coproducts,
-  -- because it acts component-wise on the lattices. This isn't true
-  -- for the category of Lposets and stable functions.
-  module _ (F : Functor 𝒞 𝒞) (F-preserve-coproducts : preserve-chosen-coproducts F 𝒞CP 𝒞CP) where
-
-    open preserve-chosen-coproducts-consequences F 𝒞CP 𝒞CP F-preserve-coproducts
-
-    open UnaryDay F
-    open F-hat-pred F renaming (endofunctor to FP)
-
-    open FunctorPred
-
-    distrib : ∀ {X} {P : Predicate X} → FP .liftF (𝐂 P) ⊑ 𝐂 (FP .liftF P)
-    distrib {X} {P} .*⊑* c .*⊑* (z , g , Xz) ((z' , g' , Xz') , liftS ϕ , liftS ψ) =
-      liftS (Context-eq (liftS (eq-sym ϕ)) (h c z' g' Xz' ψ))
+  Context-[] {X} {Y} {P} {f} a x (node c xs ts eqs) =
+    node c (λ s → f .transf (dom c s) .func (xs s))
+         (λ s → Context-[] (dom c s) (xs s) (ts s))
+         (λ s → Y .fobj (dom c s) .trans (f .transf (dom c s) .func-resp-≈ (eqs s))
+                  (Y .fobj (dom c s) .sym (f .natural _ .func-eq (X .fobj a .refl))))
+
+  -- The closure operator, for a coverage whose covers pull back.
+  module Closure (stable : ∀ {x y} (c : Cover x) (g : y 𝒞.⇒ x) → CoverPullback c g) where
+
+    Context-reindex : ∀ {X : PSh.obj} (P : Predicate X) →
+                      ∀ {a b} {x} (f : b 𝒞.⇒ a) → Context X P a x → Context X P b (X .fmor f .func x)
+    Context-reindex {X} P f (leaf p) =
+      leaf (P .pred-mor f .*⊑* _ p)
+    Context-reindex {X} P {a} {b} {x} f (node c xs ts eqs) =
+      node (pb .cover)
+           (λ s → X .fmor (pb .leg s) .func (xs (pb .reix s)))
+           (λ s → Context-reindex P (pb .leg s) (ts (pb .reix s)))
+           eq'
       where
-        h : ∀ c z g Xz → Context X P z Xz → Context (M-hat .fobj X) (FP .liftF P) c (z , g , Xz)
-        h c z g Xz (leaf ϕ) = leaf ((z , g , Xz) , M-hat-setoid X _ .refl , ϕ)
-        h c z g Xz (node a b Xa Xb f ctx₁ ctx₂ x₁ x₂) =
-          node (stbl .StableBits.y₁) (stbl .StableBits.y₂)
-               (a , stbl .StableBits.h₁ , Xa)
-               (b , stbl .StableBits.h₂ , Xb)
-               (stbl .StableBits.h)
-               (h _ _ _ _ ctx₁)
-               (h _ _ _ _ ctx₂)
-               (liftS (eq-step {Fy = X .fmor (f .fwd) .func Xz} 𝒞CP.in₁ (f .bwd)
-                               eqn₁
-                               (X .fobj _ .sym (X .fobj _ .trans x₁ (X .fmor-comp _ _ .func-eq (X .fobj _ .refl))))
-                               (X .fobj _ .trans  (X .fobj _ .sym (X .fmor-comp _ _ .func-eq (X .fobj _ .refl)))
-                                (X .fobj _ .trans (X .fmor-cong (f .fwd∘bwd≈id) .func-eq (X .fobj _ .refl))
-                                                  (X .fmor-id .func-eq (X .fobj _ .refl))))
-                               (eq-stop _)))
-               (liftS (eq-step {Fy = X .fmor (f .fwd) .func Xz}
-                               𝒞CP.in₂ (f .bwd)
-                               eqn₂
-                               (X .fobj _ .sym (X .fobj _ .trans x₂ (X .fmor-comp _ _ .func-eq (X .fobj _ .refl))))
-                               (X .fobj _ .trans (X .fobj _ .sym (X .fmor-comp _ _ .func-eq (X .fobj _ .refl)))
-                                (X .fobj _ .trans (X .fmor-cong (f .fwd∘bwd≈id) .func-eq (X .fobj _ .refl))
-                                                  (X .fmor-id .func-eq (X .fobj _ .refl))))
-                               (eq-stop _)))
-          where f' : 𝒞.Iso (𝒞CP.coprod (F .fobj a) (F .fobj b)) (F .fobj z)
-                f' = 𝒞.Iso-trans iso (functor-preserve-iso F f)
-
-                stbl = stable f' g
-
-                eqn₁ : (F .fmor 𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁) 𝒞.≈ (F .fmor (f .bwd) 𝒞.∘ (g 𝒞.∘ (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁)))
-                eqn₁ = begin
-                    F .fmor 𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁
-                  ≈˘⟨ 𝒞.∘-cong (𝒞CP.copair-in₁ _ _) 𝒞.≈-refl ⟩
-                    (𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒞.∘ 𝒞CP.in₁) 𝒞.∘ stbl .StableBits.h₁
-                  ≈⟨ 𝒞.assoc _ _ _ ⟩
-                    𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)
-                  ≈˘⟨ 𝒞.∘-cong 𝒞.id-left 𝒞.≈-refl ⟩
-                    (𝒞.id _ 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)
-                  ≈˘⟨ 𝒞.∘-cong (𝒞.∘-cong (F .fmor-id) 𝒞.≈-refl) 𝒞.≈-refl ⟩
-                    (F .fmor (𝒞.id _) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)
-                  ≈˘⟨ 𝒞.∘-cong (𝒞.∘-cong (F .fmor-cong (f .bwd∘fwd≈id)) 𝒞.≈-refl) 𝒞.≈-refl ⟩
-                    (F .fmor (f .bwd 𝒞.∘ f .fwd) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)
-                  ≈⟨ 𝒞.∘-cong (𝒞.∘-cong (F .fmor-comp _ _) 𝒞.≈-refl) 𝒞.≈-refl ⟩
-                    ((F .fmor (f .bwd) 𝒞.∘ F .fmor (f .fwd)) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)
-                  ≈⟨ 𝒞.∘-cong (𝒞.assoc _ _ _) 𝒞.≈-refl ⟩
-                    (F .fmor (f .bwd) 𝒞.∘ (F .fmor (f .fwd) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂))) 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)
-                  ≡⟨⟩
-                    (F .fmor (f .bwd) 𝒞.∘ f' .fwd) 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁)
-                  ≈⟨ 𝒞.assoc _ _ _ ⟩
-                    F .fmor (f .bwd) 𝒞.∘ (f' .fwd 𝒞.∘ (𝒞CP.in₁ 𝒞.∘ stbl .StableBits.h₁))
-                  ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (stbl .StableBits.eq₁) ⟩
-                    F .fmor (f .bwd) 𝒞.∘ (g 𝒞.∘ (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₁))
-                  ∎
-                  where open ≈-Reasoning 𝒞.isEquiv
-
-                eqn₂ : (F .fmor 𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂) 𝒞.≈ (F .fmor (f .bwd) 𝒞.∘ (g 𝒞.∘ (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂)))
-                eqn₂ = begin
-                    F .fmor 𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂
-                  ≈˘⟨ 𝒞.∘-cong (𝒞CP.copair-in₂ _ _) 𝒞.≈-refl ⟩
-                    (𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒞.∘ 𝒞CP.in₂) 𝒞.∘ stbl .StableBits.h₂
-                  ≈⟨ 𝒞.assoc _ _ _ ⟩
-                    𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂) 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)
-                  ≈˘⟨ 𝒞.∘-cong 𝒞.id-left 𝒞.≈-refl ⟩
-                    (𝒞.id _ 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)
-                  ≈˘⟨ 𝒞.∘-cong (𝒞.∘-cong (F .fmor-id) 𝒞.≈-refl) 𝒞.≈-refl ⟩
-                    (F .fmor (𝒞.id _) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)
-                  ≈˘⟨ 𝒞.∘-cong (𝒞.∘-cong (F .fmor-cong (f .bwd∘fwd≈id)) 𝒞.≈-refl) 𝒞.≈-refl ⟩
-                    (F .fmor (f .bwd 𝒞.∘ f .fwd) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)
-                  ≈⟨ 𝒞.∘-cong (𝒞.∘-cong (F .fmor-comp _ _) 𝒞.≈-refl) 𝒞.≈-refl ⟩
-                    ((F .fmor (f .bwd) 𝒞.∘ F .fmor (f .fwd)) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂)) 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)
-                  ≈⟨ 𝒞.∘-cong (𝒞.assoc _ _ _) 𝒞.≈-refl ⟩
-                    (F .fmor (f .bwd) 𝒞.∘ (F .fmor (f .fwd) 𝒞.∘ 𝒞CP.copair (F .fmor 𝒞CP.in₁) (F .fmor 𝒞CP.in₂))) 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)
-                  ≡⟨⟩
-                    (F .fmor (f .bwd) 𝒞.∘ f' .fwd) 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂)
-                  ≈⟨ 𝒞.assoc _ _ _ ⟩
-                    F .fmor (f .bwd) 𝒞.∘ (f' .fwd 𝒞.∘ (𝒞CP.in₂ 𝒞.∘ stbl .StableBits.h₂))
-                  ≈⟨ 𝒞.∘-cong 𝒞.≈-refl (stbl .StableBits.eq₂) ⟩
-                    F .fmor (f .bwd) 𝒞.∘ (g 𝒞.∘ (stbl .StableBits.h .fwd 𝒞.∘ 𝒞CP.in₂))
-                  ∎
-                  where open ≈-Reasoning 𝒞.isEquiv
+        pb = stable c f
+
+        eq' : ∀ s → X .fobj (dom (pb .cover) s) ._≈_
+                (X .fmor (pb .leg s) .func (xs (pb .reix s)))
+                (X .fmor (inj (pb .cover) s) .func (X .fmor f .func x))
+        eq' s = begin
+            X .fmor (pb .leg s) .func (xs (pb .reix s))
+          ≈⟨ X .fmor (pb .leg s) .func-resp-≈ (eqs (pb .reix s)) ⟩
+            X .fmor (pb .leg s) .func (X .fmor (inj c (pb .reix s)) .func x)
+          ≈˘⟨ X .fmor-comp _ _ .func-eq (X .fobj a .refl) ⟩
+            X .fmor (inj c (pb .reix s) 𝒞.∘ pb .leg s) .func x
+          ≈⟨ X .fmor-cong (pb .eq s) .func-eq (X .fobj a .refl) ⟩
+            X .fmor (f 𝒞.∘ inj (pb .cover) s) .func x
+          ≈⟨ X .fmor-comp _ _ .func-eq (X .fobj a .refl) ⟩
+            X .fmor (inj (pb .cover) s) .func (X .fmor f .func x)
+          ∎
+          where open ≈-Reasoning (X .fobj (dom (pb .cover) s) .isEquivalence)
+
+    𝐂 : ∀ {X} → Predicate X → Predicate X
+    𝐂 P .pred a .pred x = Context _ P a x
+    𝐂 P .pred a .pred-≃ = Context-eq
+    𝐂 P .pred-mor f .*⊑* x p = Context-reindex P f p
+
+    Context-join : ∀ {X : PSh.obj} {P : Predicate X} →
+                   ∀ {a x} → Context X (𝐂 P) a x → Context X P a x
+    Context-join (leaf p) = p
+    Context-join (node c xs ts eqs) = node c xs (λ s → Context-join (ts s)) eqs
+
+    𝐂-isClosure : ∀ {X} → IsClosureOp (⊑-isPreorder {X}) 𝐂
+    𝐂-isClosure .IsClosureOp.mono P⊑Q .*⊑* a .*⊑* x p = Context-mono P⊑Q p
+    𝐂-isClosure .IsClosureOp.unit .*⊑* a .*⊑* x p = leaf p
+    𝐂-isClosure .IsClosureOp.closed .*⊑* a .*⊑* x p = Context-join p
+
+    𝐂-strong : ∀ {X} {P Q : Predicate X} → (𝐂 P && Q) ⊑ 𝐂 (P && Q)
+    𝐂-strong .*⊑* a .*⊑* x (p , q) = Context-strong p q
+
+    𝐂-[]⁻¹ : ∀ {X Y} {P : Predicate Y} {f : X PSh.⇒ Y} → (𝐂 P [ f ]) ⊑ 𝐂 (P [ f ])
+    𝐂-[]⁻¹ {X} {Y} {P} {f} .*⊑* a .*⊑* x t =
+      Context-[]⁻¹ a x (f .transf a .func x) (Y .fobj a .refl) t
+
+    𝐂-[] : ∀ {X Y} {P : Predicate Y} {f : X PSh.⇒ Y} → 𝐂 (P [ f ]) ⊑ (𝐂 P [ f ])
+    𝐂-[] {X} {Y} {P} {f} .*⊑* a .*⊑* x t = Context-[] a x t
+
+    closureOp : ClosureOp PSh products system
+    closureOp .ClosureOp.𝐂 = 𝐂
+    closureOp .ClosureOp.𝐂-isClosure = 𝐂-isClosure
+    closureOp .ClosureOp.𝐂-[] = 𝐂-[]
+    closureOp .ClosureOp.𝐂-[]⁻¹ = 𝐂-[]⁻¹
+    closureOp .ClosureOp.𝐂-strong = 𝐂-strong
+
+    -- Lifting a predicate along an endofunctor distributes over the closure,
+    -- for endofunctors along whose images the covers pull back.
+    module Distrib (F : Functor 𝒞 𝒞) where
+
+      -- A cover of x pulls back along any morphism into the F-image of x,
+      -- one leg per index, each leg landing in the F-image of a summand.
+      record FCoverPullback {x y} (c : Cover x) (g : y 𝒞.⇒ F .fobj x) : Set ℓ where
+        field
+          cover : Cover y
+          reix  : Ix cover → Ix c
+          leg   : ∀ s → dom cover s 𝒞.⇒ F .fobj (dom c (reix s))
+          eq    : ∀ s → (F .fmor (inj c (reix s)) 𝒞.∘ leg s) 𝒞.≈ (g 𝒞.∘ inj cover s)
+      open FCoverPullback
+
+      module _ (Fpull : ∀ {x y} (c : Cover x) (g : y 𝒞.⇒ F .fobj x) → FCoverPullback c g) where
+
+        open UnaryDay F
+        open F-hat-pred F renaming (endofunctor to FP)
+        open FunctorPred
+
+        distrib : ∀ {X} {P : Predicate X} → FP .liftF (𝐂 P) ⊑ 𝐂 (FP .liftF P)
+        distrib {X} {P} .*⊑* a .*⊑* (z , g , Xz) ((z' , g' , Xz') , liftS ϕ , ψ) =
+          Context-eq (liftS (eq-sym ϕ)) (h a z' g' Xz' ψ)
+          where
+            h : ∀ a z (g : a 𝒞.⇒ F .fobj z) Xz →
+                Context X P z Xz → Context (M-hat .fobj X) (FP .liftF P) a (z , g , Xz)
+            h a z g Xz (leaf ϕ') = leaf ((z , g , Xz) , M-hat-setoid X _ .refl , ϕ')
+            h a z g Xz (node c xs ts eqs) =
+              node (fp .cover)
+                   (λ s → (dom c (fp .reix s) , fp .leg s , xs (fp .reix s)))
+                   (λ s → h _ _ _ _ (ts (fp .reix s)))
+                   (λ s → liftS (eq-step {Fy = Xz} (inj c (fp .reix s)) (𝒞.id z)
+                            (𝒞.≈-trans (fp .eq s)
+                              (𝒞.≈-sym (𝒞.≈-trans (𝒞.∘-cong (F .fmor-id) 𝒞.≈-refl) 𝒞.id-left)))
+                            (X .fobj _ .sym (eqs (fp .reix s)))
+                            (X .fmor-id .func-eq (X .fobj z .refl))
+                            (eq-stop _)))
+              where fp = Fpull c g
diff --git a/agda/src/primitives.agda b/agda/src/primitives.agda
new file mode 100644
index 00000000..9aaa7ab7
--- /dev/null
+++ b/agda/src/primitives.agda
@@ -0,0 +1,54 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (0ℓ; suc; _⊔_)
+open import Data.List using (List; []; _∷_)
+open import Data.Nat using (ℕ; _+_)
+import Data.Product as Product
+open import Data.Unit.Polymorphic using (⊤)
+open import categories using (Category)
+open import commutative-semiring using (CommutativeSemiring)
+import prop
+open import prop-setoid using (Setoid; ⊗-setoid; +-setoid; 𝟙; ⊤-isEquivalence)
+open import signature using (Signature)
+import matrix
+
+-- The primitives of a signature, as assumed by the operational semantics: for each sort a setoid
+-- of constants and a width, and for each operation a function on constants together with a dependency
+-- relation at each tuple of constants.
+module primitives where
+
+-- The setoid of tuples of constants.
+sort-vals-setoid : ∀ {ℓ} {sort : Set ℓ} (sort-index : sort → Setoid 0ℓ 0ℓ) → List sort → Setoid 0ℓ 0ℓ
+sort-vals-setoid si [] .Setoid.Carrier = ⊤
+sort-vals-setoid si [] .Setoid._≈_ _ _ = prop.⊤
+sort-vals-setoid si [] .Setoid.isEquivalence = ⊤-isEquivalence
+sort-vals-setoid si (σ ∷ σs) = ⊗-setoid (si σ) (sort-vals-setoid si σs)
+
+sorts-width : ∀ {ℓ} {A : Set ℓ} → (A → ℕ) → List A → ℕ
+sorts-width w []       = 0
+sorts-width w (s ∷ ss) = w s + sorts-width w ss
+
+record Primitives {ℓ} {A : Setoid 0ℓ 0ℓ} (S : CommutativeSemiring A) (Sig : Signature ℓ)
+                  : Set (ℓ ⊔ suc 0ℓ) where
+  open Signature Sig
+  field
+    sort-index : sort → Setoid 0ℓ 0ℓ
+    sort-width : sort → ℕ
+
+  sort-val : sort → Set
+  sort-val s = Setoid.Carrier (sort-index s)
+
+  sort-vals : List sort → Set
+  sort-vals is = Setoid.Carrier (sort-vals-setoid sort-index is)
+
+  bases-width : List sort → ℕ
+  bases-width = sorts-width sort-width
+
+  field
+    op-fun   : ∀ {is o} → op is o →
+               prop-setoid._⇒_ (sort-vals-setoid sort-index is) (sort-index o)
+    op-deps   : ∀ {is o'} → op is o' →
+               prop-setoid._⇒_ (sort-vals-setoid sort-index is)
+                 (Category.hom-setoid (matrix.Mat.cat S) (bases-width is) (sort-width o'))
+    rel-pred : ∀ {is} → rel is →
+               prop-setoid._⇒_ (sort-vals-setoid sort-index is) (+-setoid (𝟙 {0ℓ} {0ℓ}) 𝟙)
diff --git a/agda/src/product-category.agda b/agda/src/product-category.agda
index 035c476a..7867c1d4 100644
--- a/agda/src/product-category.agda
+++ b/agda/src/product-category.agda
@@ -2,12 +2,30 @@
 
 module product-category where
 
+open import Data.Fin using (Fin)
+open import Data.Nat using (ℕ)
 open import Level using (_⊔_)
 open import Data.Product using (_×_; _,_; proj₁; proj₂)
 open import prop using (_∧_; _,_; proj₁; proj₂)
 open import prop-setoid using (IsEquivalence)
 open import categories using (Category; HasProducts; HasTerminal)
-open import functor using (Functor; Limit; IsLimit; _∘F_; NatTrans; ≃-NatTrans)
+open import functor using (Functor; Limit; IsLimit; Colimit; IsColimit; _∘F_; NatTrans; ≃-NatTrans)
+
+open IsEquivalence
+
+_^_ : ∀ {o m e} → Category o m e → ℕ → Category o m e
+(𝒞 ^ n) .Category.obj           = Fin n → Category.obj 𝒞
+(𝒞 ^ n) .Category._⇒_ δ δ'      = ∀ i → Category._⇒_ 𝒞 (δ i) (δ' i)
+(𝒞 ^ n) .Category._≈_ fs gs     = ∀ i → Category._≈_ 𝒞 (fs i) (gs i)
+(𝒞 ^ n) .Category.isEquiv .refl                 i = Category.isEquiv 𝒞 .refl
+(𝒞 ^ n) .Category.isEquiv .sym fs≈gs            i = Category.isEquiv 𝒞 .sym (fs≈gs i)
+(𝒞 ^ n) .Category.isEquiv .trans fs≈gs gs≈hs    i = Category.isEquiv 𝒞 .trans (fs≈gs i) (gs≈hs i)
+(𝒞 ^ n) .Category.id δ                          i = Category.id 𝒞 (δ i)
+(𝒞 ^ n) .Category._∘_ fs gs                     i = Category._∘_ 𝒞 (fs i) (gs i)
+(𝒞 ^ n) .Category.∘-cong fs≈fs' gs≈gs'          i = Category.∘-cong 𝒞 (fs≈fs' i) (gs≈gs' i)
+(𝒞 ^ n) .Category.id-left                       i = Category.id-left 𝒞
+(𝒞 ^ n) .Category.id-right                      i = Category.id-right 𝒞
+(𝒞 ^ n) .Category.assoc fs gs hs                i = Category.assoc 𝒞 (fs i) (gs i) (hs i)
 
 module _ {o₁ m₁ e₁ o₂ m₂ e₂} (𝒞 : Category o₁ m₁ e₁) (𝒟 : Category o₂ m₂ e₂) where
 
@@ -64,12 +82,13 @@ module _ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟
 
   -- FIXME: natural isomorphisms to show that this is a product
 
-
-  -- Limits in product categories
+  -- Limits and colimits in product categories
   module _ {o₃ m₃ e₃} (𝒮 : Category o₃ m₃ e₃) where
 
     open Limit
     open IsLimit
+    open Colimit
+    open IsColimit
     open NatTrans
     open ≃-NatTrans
 
@@ -95,6 +114,28 @@ module _ {o₁ m₁ e₁ o₂ m₂ e₂} {𝒞 : Category o₁ m₁ e₁} {𝒟
        (limit𝒟 .lambda-cong (record { transf-eq = λ _ → 𝒟.≈-refl }))
        (limit𝒟 .lambda-ext (f .proj₂))
 
+    product-colimit : (D : Functor 𝒮 (product 𝒞 𝒟)) →
+                      Colimit (project₁ ∘F D) → Colimit (project₂ ∘F D) → Colimit D
+    product-colimit D colimit𝒞 colimit𝒟 .apex = colimit𝒞 .apex , colimit𝒟 .apex
+    product-colimit D colimit𝒞 colimit𝒟 .cocone .transf s = colimit𝒞 .cocone .transf s , colimit𝒟 .cocone .transf s
+    product-colimit D colimit𝒞 colimit𝒟 .cocone .natural f = colimit𝒞 .cocone .natural f , colimit𝒟 .cocone .natural f
+    product-colimit D colimit𝒞 colimit𝒟 .isColimit .colambda (x , y) α =
+      colimit𝒞 .colambda x (record { transf = λ s → α .transf s .proj₁ ; natural = λ f → α .natural f .proj₁ }) ,
+      colimit𝒟 .colambda y (record { transf = λ s → α .transf s .proj₂ ; natural = λ f → α .natural f .proj₂ })
+    product-colimit D colimit𝒞 colimit𝒟 .isColimit .colambda-cong α≃β =
+      colimit𝒞 .colambda-cong (record { transf-eq = λ s → α≃β .transf-eq s .proj₁ }) ,
+      colimit𝒟 .colambda-cong (record { transf-eq = λ s → α≃β .transf-eq s .proj₂ })
+    product-colimit D colimit𝒞 colimit𝒟 .isColimit .colambda-coeval (x , y) α .transf-eq s =
+      colimit𝒞 .colambda-coeval x (record { transf = λ s → α .transf s .proj₁ ; natural = _ }) .transf-eq s ,
+      colimit𝒟 .colambda-coeval y (record { transf = λ s → α .transf s .proj₂ ; natural = _ }) .transf-eq s
+    product-colimit D colimit𝒞 colimit𝒟 .isColimit .colambda-ext (x , y) f =
+      𝒞.≈-trans
+       (colimit𝒞 .colambda-cong (record { transf-eq = λ _ → 𝒞.≈-refl }))
+       (colimit𝒞 .colambda-ext x (f .proj₁)) ,
+      𝒟.≈-trans
+       (colimit𝒟 .colambda-cong (record { transf-eq = λ _ → 𝒟.≈-refl }))
+       (colimit𝒟 .colambda-ext y (f .proj₂))
+
   -- Products as a special case
   module _ (𝒞P : HasProducts 𝒞) (𝒟P : HasProducts 𝒟) where
 
diff --git a/agda/src/product-cocontinuity.agda b/agda/src/product-cocontinuity.agda
new file mode 100644
index 00000000..a2d0b388
--- /dev/null
+++ b/agda/src/product-cocontinuity.agda
@@ -0,0 +1,191 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Products preserve colimits in the presence of exponentials: (− × B) is left
+-- adjoint to exp B −, so the product of a colimit with a fixed object is again
+-- a colimit.
+
+open import prop-setoid using (module ≈-Reasoning)
+open import categories using (Category; HasProducts; HasExponentials)
+open import functor
+  using (Functor; Colimit; IsColimit; NatTrans; constF; constFmor; ≃-NatTrans)
+  renaming (_∘_ to _∘N_)
+
+module product-cocontinuity
+  {o m e} {𝒞 : Category o m e} (P : HasProducts 𝒞) (E : HasExponentials 𝒞 P)
+  where
+
+open Category 𝒞
+private
+  module P = HasProducts P
+  module E = HasExponentials E
+open Functor
+open NatTrans
+open ≃-NatTrans
+open Colimit
+open IsColimit
+
+module _ {o₁ m₁ e₁} {𝒮 : Category o₁ m₁ e₁} (D : Functor 𝒮 𝒞) (B : obj) (C : Colimit D) where
+
+  D×B : Functor 𝒮 𝒞
+  D×B .fobj s = P.prod (D .fobj s) B
+  D×B .fmor f = P.prod-m (D .fmor f) (id _)
+  D×B .fmor-cong e = P.prod-m-cong (D .fmor-cong e) ≈-refl
+  D×B .fmor-id = ≈-trans (P.prod-m-cong (D .fmor-id) ≈-refl) P.prod-m-id
+  D×B .fmor-comp f g =
+    ≈-trans (P.prod-m-cong (D .fmor-comp f g) (≈-sym id-left)) (P.prod-m-comp _ _ _ _)
+
+  ×B-cocone : NatTrans D×B (constF 𝒮 (P.prod (C .apex) B))
+  ×B-cocone .transf s = P.prod-m (C .cocone .transf s) (id _)
+  ×B-cocone .natural {s₁} {s₂} f =
+    begin
+      id _ ∘ P.prod-m (C .cocone .transf s₁) (id _)
+    ≈⟨ id-left ⟩
+      P.prod-m (C .cocone .transf s₁) (id _)
+    ≈⟨ P.prod-m-cong (≈-trans (≈-sym id-left) (C .cocone .natural f)) (≈-sym id-left) ⟩
+      P.prod-m (C .cocone .transf s₂ ∘ D .fmor f) (id _ ∘ id _)
+    ≈⟨ P.prod-m-comp _ _ _ _ ⟩
+      P.prod-m (C .cocone .transf s₂) (id _) ∘ P.prod-m (D .fmor f) (id _)
+    ∎ where open ≈-Reasoning isEquiv
+
+  private
+    -- Transpose a cocone on D×B to a cocone on D.
+    curry : ∀ x → NatTrans D×B (constF 𝒮 x) → NatTrans D (constF 𝒮 (E.exp B x))
+    curry x α .transf s = E.lambda (α .transf s)
+    curry x α .natural {s₁} {s₂} f =
+      begin
+        id _ ∘ E.lambda (α .transf s₁)
+      ≈⟨ id-left ⟩
+        E.lambda (α .transf s₁)
+      ≈⟨ E.lambda-cong (≈-trans (≈-sym id-left) (α .natural f)) ⟩
+        E.lambda (α .transf s₂ ∘ P.prod-m (D .fmor f) (id _))
+      ≈˘⟨ E.lambda-natural _ _ ⟩
+        E.lambda (α .transf s₂) ∘ D .fmor f
+      ∎ where open ≈-Reasoning isEquiv
+
+  ×B-preserves-colimit : IsColimit D×B (P.prod (C .apex) B) ×B-cocone
+  ×B-preserves-colimit .colambda x α =
+    E.eval ∘ P.prod-m (C .isColimit .colambda (E.exp B x) (curry x α)) (id _)
+  ×B-preserves-colimit .colambda-cong {x} {α} {β} α≃β =
+    ∘-cong ≈-refl (P.prod-m-cong (C .isColimit .colambda-cong eq) ≈-refl)
+    where
+      eq : ≃-NatTrans (curry x α) (curry x β)
+      eq .transf-eq s = E.lambda-cong (α≃β .transf-eq s)
+  ×B-preserves-colimit .colambda-coeval x α .transf-eq s =
+    begin
+      (E.eval ∘ P.prod-m (C .isColimit .colambda _ (curry x α)) (id _)) ∘ P.prod-m (C .cocone .transf s) (id _)
+    ≈⟨ assoc _ _ _ ⟩
+      E.eval ∘ (P.prod-m (C .isColimit .colambda _ (curry x α)) (id _) ∘ P.prod-m (C .cocone .transf s) (id _))
+    ≈˘⟨ ∘-cong ≈-refl (P.prod-m-comp _ _ _ _) ⟩
+      E.eval ∘ P.prod-m (C .isColimit .colambda _ (curry x α) ∘ C .cocone .transf s) (id _ ∘ id _)
+    ≈⟨ ∘-cong ≈-refl (P.prod-m-cong (C .isColimit .colambda-coeval _ (curry x α) .transf-eq s) id-left) ⟩
+      E.eval ∘ P.prod-m (E.lambda (α .transf s)) (id _)
+    ≈⟨ E.eval-lambda _ ⟩
+      α .transf s
+    ∎ where open ≈-Reasoning isEquiv
+  ×B-preserves-colimit .colambda-ext x f =
+    begin
+      E.eval ∘ P.prod-m (C .isColimit .colambda _ (curry x (constFmor f ∘N ×B-cocone))) (id _)
+    ≈⟨ ∘-cong ≈-refl (P.prod-m-cong (C .isColimit .colambda-cong eq) ≈-refl) ⟩
+      E.eval ∘ P.prod-m (C .isColimit .colambda _ (constFmor (E.lambda f) ∘N C .cocone)) (id _)
+    ≈⟨ ∘-cong ≈-refl (P.prod-m-cong (C .isColimit .colambda-ext _ (E.lambda f)) ≈-refl) ⟩
+      E.eval ∘ P.prod-m (E.lambda f) (id _)
+    ≈⟨ E.eval-lambda _ ⟩
+      f
+    ∎
+    where
+      eq : ≃-NatTrans (curry x (constFmor f ∘N ×B-cocone)) (constFmor (E.lambda f) ∘N C .cocone)
+      eq .transf-eq s = ≈-sym (E.lambda-natural (C .cocone .transf s) f)
+
+      open ≈-Reasoning isEquiv
+
+-- The left-handed variant: (B × −) preserves colimits, by transposing through
+-- the symmetry of the product.
+module _ {o₁ m₁ e₁} {𝒮 : Category o₁ m₁ e₁} (B : obj) (D : Functor 𝒮 𝒞) (C : Colimit D) where
+
+  B×D' : Functor 𝒮 𝒞
+  B×D' .fobj s = P.prod B (D .fobj s)
+  B×D' .fmor f = P.prod-m (id _) (D .fmor f)
+  B×D' .fmor-cong e = P.prod-m-cong ≈-refl (D .fmor-cong e)
+  B×D' .fmor-id = ≈-trans (P.prod-m-cong ≈-refl (D .fmor-id)) P.prod-m-id
+  B×D' .fmor-comp f g =
+    ≈-trans (P.prod-m-cong (≈-sym id-left) (D .fmor-comp f g)) (P.prod-m-comp _ _ _ _)
+
+  private
+    swapN : ∀ x → NatTrans B×D' (constF 𝒮 x) → NatTrans (D×B D B C) (constF 𝒮 x)
+    swapN x α .transf s = α .transf s ∘ P.swap
+    swapN x α .natural {s₁} {s₂} f =
+      begin
+        id _ ∘ (α .transf s₁ ∘ P.swap)
+      ≈˘⟨ assoc _ _ _ ⟩
+        (id _ ∘ α .transf s₁) ∘ P.swap
+      ≈⟨ ∘-cong (α .natural f) ≈-refl ⟩
+        (α .transf s₂ ∘ P.prod-m (id _) (D .fmor f)) ∘ P.swap
+      ≈⟨ assoc _ _ _ ⟩
+        α .transf s₂ ∘ (P.prod-m (id _) (D .fmor f) ∘ P.swap)
+      ≈˘⟨ ∘-cong ≈-refl (P.swap-natural _ _) ⟩
+        α .transf s₂ ∘ (P.swap ∘ P.prod-m (D .fmor f) (id _))
+      ≈˘⟨ assoc _ _ _ ⟩
+        (α .transf s₂ ∘ P.swap) ∘ P.prod-m (D .fmor f) (id _)
+      ∎ where open ≈-Reasoning isEquiv
+
+  B×-cocone : NatTrans B×D' (constF 𝒮 (P.prod B (C .apex)))
+  B×-cocone .transf s = P.prod-m (id _) (C .cocone .transf s)
+  B×-cocone .natural {s₁} {s₂} f =
+    begin
+      id _ ∘ P.prod-m (id _) (C .cocone .transf s₁)
+    ≈⟨ id-left ⟩
+      P.prod-m (id _) (C .cocone .transf s₁)
+    ≈⟨ P.prod-m-cong (≈-sym id-left) (≈-trans (≈-sym id-left) (C .cocone .natural f)) ⟩
+      P.prod-m (id _ ∘ id _) (C .cocone .transf s₂ ∘ D .fmor f)
+    ≈⟨ P.prod-m-comp _ _ _ _ ⟩
+      P.prod-m (id _) (C .cocone .transf s₂) ∘ P.prod-m (id _) (D .fmor f)
+    ∎ where open ≈-Reasoning isEquiv
+
+  B×-preserves-colimit : IsColimit B×D' (P.prod B (C .apex)) B×-cocone
+  B×-preserves-colimit .colambda x α =
+    ×B-preserves-colimit D B C .colambda x (swapN x α) ∘ P.swap
+  B×-preserves-colimit .colambda-cong {x} {α} {β} α≃β =
+    ∘-cong (×B-preserves-colimit D B C .colambda-cong eq) ≈-refl
+    where
+      eq : ≃-NatTrans (swapN x α) (swapN x β)
+      eq .transf-eq s = ∘-cong (α≃β .transf-eq s) ≈-refl
+  B×-preserves-colimit .colambda-coeval x α .transf-eq s =
+    begin
+      (×B-preserves-colimit D B C .colambda x (swapN x α) ∘ P.swap) ∘ P.prod-m (id _) (C .cocone .transf s)
+    ≈⟨ assoc _ _ _ ⟩
+      ×B-preserves-colimit D B C .colambda x (swapN x α) ∘ (P.swap ∘ P.prod-m (id _) (C .cocone .transf s))
+    ≈⟨ ∘-cong ≈-refl (P.swap-natural _ _) ⟩
+      ×B-preserves-colimit D B C .colambda x (swapN x α) ∘ (P.prod-m (C .cocone .transf s) (id _) ∘ P.swap)
+    ≈˘⟨ assoc _ _ _ ⟩
+      (×B-preserves-colimit D B C .colambda x (swapN x α) ∘ P.prod-m (C .cocone .transf s) (id _)) ∘ P.swap
+    ≈⟨ ∘-cong (×B-preserves-colimit D B C .colambda-coeval x (swapN x α) .transf-eq s) ≈-refl ⟩
+      (α .transf s ∘ P.swap) ∘ P.swap
+    ≈⟨ assoc _ _ _ ⟩
+      α .transf s ∘ (P.swap ∘ P.swap)
+    ≈⟨ ∘-cong ≈-refl P.swap-involutive ⟩
+      α .transf s ∘ id _
+    ≈⟨ id-right ⟩
+      α .transf s
+    ∎ where open ≈-Reasoning isEquiv
+  B×-preserves-colimit .colambda-ext x f =
+    begin
+      ×B-preserves-colimit D B C .colambda x (swapN x (constFmor f ∘N B×-cocone)) ∘ P.swap
+    ≈⟨ ∘-cong (×B-preserves-colimit D B C .colambda-cong eq) ≈-refl ⟩
+      ×B-preserves-colimit D B C .colambda x (constFmor (f ∘ P.swap) ∘N ×B-cocone D B C) ∘ P.swap
+    ≈⟨ ∘-cong (×B-preserves-colimit D B C .colambda-ext x (f ∘ P.swap)) ≈-refl ⟩
+      (f ∘ P.swap) ∘ P.swap
+    ≈⟨ assoc _ _ _ ⟩
+      f ∘ (P.swap ∘ P.swap)
+    ≈⟨ ∘-cong ≈-refl P.swap-involutive ⟩
+      f ∘ id _
+    ≈⟨ id-right ⟩
+      f
+    ∎
+    where
+      open ≈-Reasoning isEquiv
+
+      eq : ≃-NatTrans (swapN x (constFmor f ∘N B×-cocone)) (constFmor (f ∘ P.swap) ∘N ×B-cocone D B C)
+      eq .transf-eq s =
+        ≈-trans (assoc _ _ _)
+          (≈-trans (∘-cong ≈-refl (≈-sym (P.swap-natural (C .cocone .transf s) (id B))))
+            (≈-sym (assoc _ _ _)))
diff --git a/agda/src/prop-setoid.agda b/agda/src/prop-setoid.agda
index 40865836..9b9512a3 100644
--- a/agda/src/prop-setoid.agda
+++ b/agda/src/prop-setoid.agda
@@ -6,7 +6,7 @@ open import Level
 open import prop
 open import Data.Unit using (tt) renaming (⊤ to 𝟙S)
 open import Data.Sum using (_⊎_; inj₁; inj₂)
-open import Data.Empty using () renaming (⊥ to 𝟘)
+open import Data.Empty using () renaming (⊥ to 𝟘S)
 open import Data.Product using (_×_; proj₁; proj₂; _,_)
 open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)
 
@@ -153,6 +153,20 @@ module _ {o e} where
   const X x .func _ = x
   const X x .func-resp-≈ tt = X .refl
 
+  𝟘 : Setoid o e
+  𝟘 .Carrier = Lift _ 𝟘S
+  𝟘 ._≈_ _ _ = ⊤
+  𝟘 .isEquivalence .refl = tt
+  𝟘 .isEquivalence .sym _ = tt
+  𝟘 .isEquivalence .trans _ _ = tt
+
+  from-𝟘 : ∀ {X : Setoid o e} → 𝟘 ⇒ X
+  from-𝟘 .func (lift ())
+  from-𝟘 .func-resp-≈ {lift ()}
+
+  from-𝟘-unique : ∀ {X : Setoid o e} (f g : 𝟘 ⇒ X) → f ≃m g
+  from-𝟘-unique f g ._≃m_.func-eq {lift ()}
+
 open _≃m_
 
 +-setoid : ∀ {a b} (X : Setoid a b) (Y : Setoid a b) → Setoid a b
@@ -234,68 +248,6 @@ case f g .func (w , inj₂ y) = g .func (w , y)
 case f g .func-resp-≈ {w₁ , inj₁ x₁} {w₂ , inj₁ x₂} (w₁≈w₂ , x₁≈x₂) = f .func-resp-≈ (w₁≈w₂ , x₁≈x₂)
 case f g .func-resp-≈ {w₁ , inj₂ y₁} {w₂ , inj₂ y₂} (w₁≈w₂ , y₁≈y₂) = g .func-resp-≈ (w₁≈w₂ , y₁≈y₂)
 
--- Lists
---
--- FIXME: do this for a larger range of inductive datatypes
-module _ {o e} where
-
-  open import Data.List using (List; []; _∷_)
-
-  List-≈ : (A : Setoid o e) → List (A .Carrier) → List (A .Carrier) → Prop e
-  List-≈ A [] [] = ⊤
-  List-≈ A [] (_ ∷ _) = ⊥
-  List-≈ A (x ∷ xs) [] = ⊥
-  List-≈ A (x ∷ xs) (y ∷ ys) = A ._≈_ x y ∧ List-≈ A xs ys
-
-  List-≈-refl : ∀ A {xs : List (A .Carrier)} → List-≈ A xs xs
-  List-≈-refl A {[]} = tt
-  List-≈-refl A {x ∷ xs} = A .refl , List-≈-refl A
-
-  List-≈-sym : ∀ A {xs ys : List (A .Carrier)} → List-≈ A xs ys → List-≈ A ys xs
-  List-≈-sym A {[]} {[]} tt = tt
-  List-≈-sym A {x ∷ xs} {y ∷ ys} (x≈y , xs≈ys)  = A .sym x≈y , List-≈-sym A xs≈ys
-
-  List-≈-trans : ∀ A {xs ys zs : List (A .Carrier)} → List-≈ A xs ys → List-≈ A ys zs → List-≈ A xs zs
-  List-≈-trans A {[]} {[]} {[]} tt tt = tt
-  List-≈-trans A {x ∷ xs} {y ∷ ys} {z ∷ zs} (x≈y , xs≈ys) (y≈z , ys≈zs) =
-    A .trans x≈y y≈z , List-≈-trans A xs≈ys ys≈zs
-
-  ListS : Setoid o e → Setoid o e
-  ListS A .Carrier = List (A .Carrier)
-  ListS A ._≈_ = List-≈ A
-  ListS A .isEquivalence .refl = List-≈-refl A
-  ListS A .isEquivalence .sym = List-≈-sym A
-  ListS A .isEquivalence .trans = List-≈-trans A
-
-  nil : ∀ {A : Setoid o e} → (𝟙 {o} {e}) ⇒ ListS A
-  nil .func _ = []
-  nil .func-resp-≈ _ = tt
-
-  cons : ∀ {A : Setoid o e} → ⊗-setoid A (ListS A) ⇒ ListS A
-  cons .func (x , xs) = x ∷ xs
-  cons .func-resp-≈ e = e
-
-  foldr : ∀ {A B : Setoid o e} →
-          𝟙 {o} {e} ⇒ B →
-          ⊗-setoid A B ⇒ B →
-          ListS A ⇒ B
-  foldr nilCase consCase .func [] = nilCase .func (lift tt)
-  foldr nilCase consCase .func (x ∷ xs) = consCase .func (x , foldr nilCase consCase .func xs)
-  foldr nilCase consCase .func-resp-≈ {[]} {[]} tt = nilCase .func-resp-≈ tt
-  foldr nilCase consCase .func-resp-≈ {x₁ ∷ xs₁} {x₂ ∷ xs₂} (x₁≈x₂ , xs₁≈xs₂) =
-    consCase .func-resp-≈ (x₁≈x₂ , (foldr nilCase consCase .func-resp-≈ xs₁≈xs₂))
-
-  foldrP : ∀ {A B C : Setoid o e} →
-           C ⇒ B →
-           ⊗-setoid (⊗-setoid C A) B ⇒ B →
-           ⊗-setoid C (ListS A) ⇒ B
-  foldrP nilCase consCase .func (c , []) = nilCase .func c
-  foldrP nilCase consCase .func (c , x ∷ xs) = consCase .func ((c , x) , foldrP nilCase consCase .func (c , xs))
-  foldrP nilCase consCase .func-resp-≈ {c₁ , []}       {c₂ , []}        (c₁≈c₂ , tt) = nilCase .func-resp-≈ c₁≈c₂
-  foldrP nilCase consCase .func-resp-≈ {c₁ , x₁ ∷ xs₁} {c₂ , x₂ ∷ xs₂} (c₁≈c₂ , x₁≈x₂ , xs₁≈xs₂) =
-    consCase .func-resp-≈ ((c₁≈c₂ , x₁≈x₂) , foldrP nilCase consCase .func-resp-≈ (c₁≈c₂ , xs₁≈xs₂))
-
-  -- FIXME: the equations...
 
 -- Equivalence relations from relations
 module _ {o e} (A : Set o) (R : A → A → Prop e) where
diff --git a/agda/src/prop.agda b/agda/src/prop.agda
index 7f5bf2a9..6bb892ea 100644
--- a/agda/src/prop.agda
+++ b/agda/src/prop.agda
@@ -4,6 +4,11 @@ module prop where
 
 open import Level
 open import Data.Sum using (_⊎_; inj₁; inj₂)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl)
+
+-- Prop-variant of Relation.Binary.PropositionalEquality.subst (which requires a Set-valued motive).
+substP : ∀ {a b} {A : Set a} (Q : A → Prop b) {x y : A} → x ≡ y → Q x → Q y
+substP _ refl q = q
 
 data ⊥ {ℓ} : Prop ℓ where
 
@@ -35,6 +40,11 @@ data _∨_ {a b} (P : Prop a) (Q : Prop b) : Prop (a ⊔ b) where
   inj₁ : P → P ∨ Q
   inj₂ : Q → P ∨ Q
 
+-- Decidability of a Prop. Set-level so it can be branched on; proofs inside are Prop.
+data Dec {ℓ} (P : Prop ℓ) : Set ℓ where
+  yes : P → Dec P
+  no  : (P → ⊥ {ℓ}) → Dec P
+
 record ∃ₚ {a b} (A : Prop a)(B : A → Prop b) : Prop (a ⊔ b) where
   constructor _,_
   field
diff --git a/agda/src/sd-semimodule.agda b/agda/src/sd-semimodule.agda
index 78694c84..b2590c5c 100644
--- a/agda/src/sd-semimodule.agda
+++ b/agda/src/sd-semimodule.agda
@@ -317,6 +317,10 @@ module _ where
     ⊕-lunit-≅sd {Y} .iso = SemiMod.⊕-lunit-iso
     ⊕-lunit-≅sd {Y} .pairing-iso = S.sym (S.trans (pairing-⊕ (𝟘-sd .dual) (Y .dual)) S.+-lunit)
 
+    ⊕-runit-≅sd : ∀ {X} → ⊕-sd X 𝟘-sd ≅sd X
+    ⊕-runit-≅sd {X} .iso = SemiMod.⊕-runit-iso
+    ⊕-runit-≅sd {X} .pairing-iso = S.sym (S.trans (pairing-⊕ (X .dual) (𝟘-sd .dual)) (S.trans S.+-comm S.+-lunit))
+
     ⊕-assoc-≅sd : ∀ {X Y Z} → ⊕-sd (⊕-sd X Y) Z ≅sd ⊕-sd X (⊕-sd Y Z)
     ⊕-assoc-≅sd {X} {Y} {Z} .iso = SemiMod.⊕-assoc-iso
     ⊕-assoc-≅sd {X} {Y} {Z} .pairing-iso =
@@ -330,13 +334,17 @@ module _ where
     infix 30 S^_
     S^_ : ℕ → SelfDual
     S^ Nat.zero = 𝟘-sd
-    S^ (Nat.suc n) = ⊕-sd 𝕀-sd (S^ n)
+    S^ (Nat.suc Nat.zero) = 𝕀-sd
+    S^ (Nat.suc (Nat.suc n)) = ⊕-sd 𝕀-sd (S^ (Nat.suc n))
 
     -- The biproduct of free objects is free.
     S^-+ : ∀ m n → ⊕-sd (S^ m) (S^ n) ≅sd (S^ (m Nat.+ n))
     S^-+ Nat.zero n = ⊕-lunit-≅sd
-    S^-+ (Nat.suc m) n =
-      ≅sd-trans (⊕-assoc-≅sd {𝕀-sd} {S^ m} {S^ n}) (⊕-≅sd (≅sd-refl {𝕀-sd}) (S^-+ m n))
+    S^-+ (Nat.suc Nat.zero) Nat.zero = ⊕-runit-≅sd
+    S^-+ (Nat.suc Nat.zero) (Nat.suc n) = ≅sd-refl
+    S^-+ (Nat.suc (Nat.suc m)) n =
+      ≅sd-trans (⊕-assoc-≅sd {𝕀-sd} {S^ (Nat.suc m)} {S^ n})
+                (⊕-≅sd (≅sd-refl {𝕀-sd}) (S^-+ (Nat.suc m) n))
 
 open SelfDual
 
diff --git a/agda/src/semimodule.agda b/agda/src/semimodule.agda
index 4dd7b90e..944db9ba 100644
--- a/agda/src/semimodule.agda
+++ b/agda/src/semimodule.agda
@@ -202,6 +202,20 @@ module _ where
   ⊕-lunit-iso {N} .Iso.fwd∘bwd≈id .*≈* ._≈s_.func-eq e = e
   ⊕-lunit-iso {N} .Iso.bwd∘fwd≈id .*≈* ._≈s_.func-eq (_ , e) = tt , e
 
+  ⊕-runit-iso : ∀ {M} → Iso (M ⊕ 𝟘) M
+  ⊕-runit-iso {M} .Iso.fwd .*→* ._⇒s_.func (m , _) = m
+  ⊕-runit-iso {M} .Iso.fwd .*→* ._⇒s_.func-resp-≈ (e , _) = e
+  ⊕-runit-iso {M} .Iso.fwd .preserve-ze = refl M
+  ⊕-runit-iso {M} .Iso.fwd .preserve-+ = refl M
+  ⊕-runit-iso {M} .Iso.fwd .preserve-· = refl M
+  ⊕-runit-iso {M} .Iso.bwd .*→* ._⇒s_.func m = m , Level.lift Agda.Builtin.Unit.tt
+  ⊕-runit-iso {M} .Iso.bwd .*→* ._⇒s_.func-resp-≈ e = e , tt
+  ⊕-runit-iso {M} .Iso.bwd .preserve-ze = refl M , tt
+  ⊕-runit-iso {M} .Iso.bwd .preserve-+ = refl M , tt
+  ⊕-runit-iso {M} .Iso.bwd .preserve-· = refl M , tt
+  ⊕-runit-iso {M} .Iso.fwd∘bwd≈id .*≈* ._≈s_.func-eq e = e
+  ⊕-runit-iso {M} .Iso.bwd∘fwd≈id .*≈* ._≈s_.func-eq (e , _) = e , tt
+
   ⊕-assoc-iso : ∀ {M N P} → Iso ((M ⊕ N) ⊕ P) (M ⊕ (N ⊕ P))
   ⊕-assoc-iso {M} {N} {P} .Iso.fwd .*→* ._⇒s_.func ((m , n) , p) = m , (n , p)
   ⊕-assoc-iso {M} {N} {P} .Iso.fwd .*→* ._⇒s_.func-resp-≈ ((em , en) , ep) = em , (en , ep)
diff --git a/agda/src/stable-coproducts-indexed.agda b/agda/src/stable-coproducts-indexed.agda
new file mode 100644
index 00000000..fa01da5b
--- /dev/null
+++ b/agda/src/stable-coproducts-indexed.agda
@@ -0,0 +1,48 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Level using (_⊔_; suc)
+open import categories using (Category; setoid→category)
+open import prop-setoid using (Setoid)
+open import functor using (Functor; HasColimits; Colimit; NatTrans)
+
+-- Stability of set-indexed coproducts: pulling a coproduct decomposition back
+-- along a morphism yields a decomposition over the same index, one summand
+-- pulled back per index. This is the set-indexed form of the binary stability
+-- of `stable-coproducts`, the finite case being the two-element index.
+module stable-coproducts-indexed
+  {o m e os es} {𝒞 : Category o m e}
+  (LC : ∀ (S : Setoid os es) → HasColimits (setoid→category S) 𝒞)
+  where
+
+private
+  module 𝒞 = Category 𝒞
+
+open 𝒞.Iso
+open Colimit
+open NatTrans
+open Functor
+
+-- The coproduct object of an index-setoid diagram, and its injections.
+∐ : ∀ (S : Setoid os es) (D : Functor (setoid→category S) 𝒞) → 𝒞.obj
+∐ S D = LC S D .apex
+
+inj : ∀ {S} (D : Functor (setoid→category S) 𝒞) (s : S .Setoid.Carrier) →
+      D .fobj s 𝒞.⇒ ∐ S D
+inj {S} D s = LC S D .cocone .transf s
+
+record IdxStableBits
+    {S : Setoid os es} {D : Functor (setoid→category S) 𝒞} {x y}
+    (f : 𝒞.Iso (∐ S D) x) (g : y 𝒞.⇒ x) : Set (o ⊔ m ⊔ e ⊔ os ⊔ es) where
+  field
+    -- The summands of y, over the same index as those of x.
+    E   : Functor (setoid→category S) 𝒞
+    -- Each summand of y maps into the corresponding summand of x.
+    leg : ∀ (s : S .Setoid.Carrier) → E .fobj s 𝒞.⇒ D .fobj s
+    -- y is the coproduct of its summands.
+    h   : 𝒞.Iso (∐ S E) y
+    -- g restricted to the s-th summand factors through leg s.
+    eq  : ∀ (s : S .Setoid.Carrier) →
+          (f .fwd 𝒞.∘ (inj D s 𝒞.∘ leg s)) 𝒞.≈ (g 𝒞.∘ (h .fwd 𝒞.∘ inj E s))
+
+IdxStable : Set (o ⊔ m ⊔ e ⊔ suc os ⊔ suc es)
+IdxStable = ∀ {S D x y} f g → IdxStableBits {S} {D} {x} {y} f g
diff --git a/agda/src/test/all.agda b/agda/src/test/all.agda
new file mode 100644
index 00000000..8f13c33b
--- /dev/null
+++ b/agda/src/test/all.agda
@@ -0,0 +1,6 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+module test.all where
+
+import test.dependency
+import test.interaction
diff --git a/agda/src/example/dependency-total.agda b/agda/src/test/dependency.agda
similarity index 69%
rename from agda/src/example/dependency-total.agda
rename to agda/src/test/dependency.agda
index 2d4c787e..18abb800 100644
--- a/agda/src/example/dependency-total.agda
+++ b/agda/src/test/dependency.agda
@@ -3,15 +3,17 @@
 -- Boolean dependency analysis of the weighted-sum query from the introduction. Where the rational
 -- derivative of the price entry cancels to 0, the Boolean analysis reports ⊤, because disjunction
 -- can't cancel.
-module example.dependency-total where
+module test.dependency where
 
 open import example.dependency
+import Data.Fin as Fin
 
-input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty .idx .Carrier
-input = (3 , (a , + 3 / 1) , (b , 1ℚ) , (a , -[1+ 2 ] / 1) , _) , (+ 2 / 1 , + 5 / 1)
+input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty (λ ()) .idx .Carrier
+input = T.sup (inj₂ ((a , + 3 / 1) , T.sup (inj₂ ((b , 1ℚ) , T.sup (inj₂ ((a , -[1+ 2 ] / 1) , T.sup (inj₁ (lift ·))))))))
+        , (+ 2 / 1 , + 5 / 1)
 
-input-ty : first-order-data ((list (base label [×] base number)) [×] (base number [×] base number))
-input-ty = list (base label [×] base number) [×] (base number [×] base number)
+input-ty : first-order ((list (base label [×] base number)) [×] (base number [×] base number))
+input-ty = μ (unit [+] ((base label [×] base number) [×] var Fin.zero)) [×] (base number [×] base number)
 
 -- ∂₂/∂q₁ = ⊤: the output may depend on the first quantity.
 test-q₁ : fwd (total a) (_ , input)
@@ -33,8 +35,8 @@ test-q₂ = refl
 
 -- The backward derivative applied to the selected output: the inputs the output may depend on,
 -- (1 0 1 1 0), still including the cancelled price a.
-test-bwd : SDSemiMod-𝟚.conjugate (selfDual (ty (unit [×] input-ty) (_ , input)))
-             (selfDual (ty (base number) 0ℚ))
+test-bwd : HM.SDSemiMod.conjugate (ty₀ (unit [×] input-ty) (_ , input))
+             (ty₀ (base number) 0ℚ)
              (mor (total a) (_ , input)) .func ⊤
-           ≡ (lift · , ((lift · , ⊤) , (lift · , ⊥) , (lift · , ⊤) , lift ·) , (⊤ , ⊥))
+           ≡ (lift · , ((lift · , ⊤) , (lift · , ⊥) , (lift · , ⊤) , _) , (⊤ , ⊥))
 test-bwd = refl
diff --git a/agda/src/test/interaction.agda b/agda/src/test/interaction.agda
new file mode 100644
index 00000000..0b8674b2
--- /dev/null
+++ b/agda/src/test/interaction.agda
@@ -0,0 +1,73 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Hide and reveal on a run with rewiring: case (inl x) of inl x₁ → x₁ | inr y → y. The branch is
+-- evaluated under the extended environment, so its env edges are redistributed to env and the
+-- scrutinee root, giving the chain env → inl payload → scrutinee root → branch root → root.
+-- Initially the three intermediates form one hidden region; revealing the scrutinee root splits it
+-- in two, and hiding it again merges them back.
+module test.interaction where
+
+open import Data.Fin using (zero; suc)
+open import Data.Rational using (ℚ; 1ℚ)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl)
+import two
+
+open import example.signature ℚ using (Sig; number)
+import example.dependency as Dep
+
+open import language-syntax Sig using (_⊢_; _∋_; zero; base; var; inl; case; ctxt; emp)
+  renaming (_,_ to _▸_)
+open import language-operational.evaluation Sig Dep.primitives
+open import language-operational.path Sig Dep.primitives
+open import language-operational.graph Sig Dep.primitives
+open import language-operational.hide Sig Dep.primitives
+
+γ₀ : Env (emp ▸ base number)
+γ₀ = emp · const 1ℚ
+
+D : γ₀ , case (inl (var zero)) (var zero) (var zero) ⇓ const 1ℚ [ _ ]
+D = ⇓-case-l (⇓-inl (⇓-var zero)) (⇓-var zero)
+
+-- The scrutinee root, mid-chain.
+scrut : Path D
+scrut = case-l₁ ε
+
+K₀ : Config D
+K₀ = initial D
+
+K₁ : Config D
+K₁ = reveal-at D scrut K₀
+
+K₂ : Config D
+K₂ = hide-at D scrut K₁
+
+-- Everything hidden: the output depends on the input, through the whole chain.
+init-dep : visible-graph D K₀ env (at ε) zero zero ≡ two.I
+init-dep = refl
+
+-- Scrutinee root revealed: its region splits, dependence routes through the revealed vertex, and
+-- the direct env-to-root entry disappears.
+reveal-in : visible-graph D K₁ env (at scrut) zero zero ≡ two.I
+reveal-in = refl
+
+reveal-out : visible-graph D K₁ (at scrut) (at ε) zero zero ≡ two.I
+reveal-out = refl
+
+reveal-no-direct : visible-graph D K₁ env (at ε) zero zero ≡ two.O
+reveal-no-direct = refl
+
+-- The rewired env column of the branch is zero: the branch body uses only the bound variable.
+reveal-no-env-branch : fo-graph D env (at (case-l₂ ε)) zero zero ≡ two.O
+reveal-no-env-branch = refl
+
+-- The scrutinee slice of the branch environment carries the dependence instead.
+rewired-scrut-branch : fo-graph D (at scrut) (at (case-l₂ ε)) zero zero ≡ two.I
+rewired-scrut-branch = refl
+
+-- Hidden again: the regions merge back and the initial view returns.
+rehide-dep : visible-graph D K₂ env (at ε) zero zero ≡ two.I
+rehide-dep = refl
+
+-- Collapsing the whole derivation recovers the run's dependency relation.
+collapse-agrees : collapse D zero zero ≡ two.I
+collapse-agrees = refl
diff --git a/agda/src/two.agda b/agda/src/two.agda
index 6dc40e28..dc985990 100644
--- a/agda/src/two.agda
+++ b/agda/src/two.agda
@@ -2,6 +2,11 @@
 module two where
 
 open import prop using (⊤; ⊥; tt; _∨_; inj₁; inj₂; _,_)
+open import Relation.Binary.PropositionalEquality using (_≡_)
+  renaming (refl to ≡-refl; sym to ≡-sym; trans to ≡-trans; cong to ≡-cong; cong₂ to ≡-cong₂)
+import Data.Empty as Empty
+import Data.Product as Product
+import Data.Sum as Sum
 open import basics using (IsPreorder; IsMeet; IsJoin; IsBottom; IsTop)
 
 data Two : Set where
@@ -66,6 +71,13 @@ I ⊓ x = x
 ⊓-isMeet .IsMeet.π₂ = ⊓-lower₂
 ⊓-isMeet .IsMeet.⟨_,_⟩ = ⊓-greatest
 
+-- Equality form of I-isTop: a meet is I only when both parts are.
+⊓-I : ∀ x y → (x ⊓ y) ≡ I → (x ≡ I) Product.× (y ≡ I)
+⊓-I I y h = ≡-refl Product., h
+
+⊓-I-pair : ∀ {x y} → x ≡ I → y ≡ I → (x ⊓ y) ≡ I
+⊓-I-pair ≡-refl h = h
+
 ------------------------------------------------------------------------------
 O-isBottom : IsBottom ≤-isPreorder O
 O-isBottom .IsBottom.≤-bottom = tt
@@ -91,6 +103,86 @@ I ⊔ x = I
 ⊔-isJoin .IsJoin.inr = ⊔-upper₂
 ⊔-isJoin .IsJoin.[_,_] = ⊔-least
 
+⊔-idem : ∀ {x} → (x ⊔ x) ≡ x
+⊔-idem {O} = ≡-refl
+⊔-idem {I} = ≡-refl
+
+⊔-runit : ∀ {x} → (x ⊔ O) ≡ x
+⊔-runit {O} = ≡-refl
+⊔-runit {I} = ≡-refl
+
+⊔-comm : ∀ x y → (x ⊔ y) ≡ (y ⊔ x)
+⊔-comm O O = ≡-refl
+⊔-comm O I = ≡-refl
+⊔-comm I O = ≡-refl
+⊔-comm I I = ≡-refl
+
+⊔-assoc : ∀ x y z → ((x ⊔ y) ⊔ z) ≡ (x ⊔ (y ⊔ z))
+⊔-assoc O y z = ≡-refl
+⊔-assoc I y z = ≡-refl
+
+-- I is join-prime, so a join is I only when some part is.
+⊔-I : ∀ x y → (x ⊔ y) ≡ I → (x ≡ I) Sum.⊎ (y ≡ I)
+⊔-I O y h = Sum.inj₂ h
+⊔-I I y h = Sum.inj₁ ≡-refl
+
+⊔-I-inl : ∀ {x y} → x ≡ I → (x ⊔ y) ≡ I
+⊔-I-inl ≡-refl = ≡-refl
+
+⊔-I-inr : ∀ x {y} → y ≡ I → (x ⊔ y) ≡ I
+⊔-I-inr O h = h
+⊔-I-inr I h = ≡-refl
+
+O≢I : O ≡ I → Empty.⊥
+O≢I ()
+
+-- Antisymmetry at the equality level: mutual implication at I gives equality.
+I-antisym : ∀ {x y} → (x ≡ I → y ≡ I) → (y ≡ I → x ≡ I) → x ≡ y
+I-antisym {O} {O} f g = ≡-refl
+I-antisym {O} {I} f g with g ≡-refl
+... | ()
+I-antisym {I} {O} f g with f ≡-refl
+... | ()
+I-antisym {I} {I} f g = ≡-refl
+
+------------------------------------------------------------------------------
+-- Folds of joins over lists.
+
+open import Data.List using (List; []; _∷_; foldr)
+open import Data.List.Relation.Unary.All using (All; []; _∷_)
+open import Data.List.Relation.Unary.Any using (Any; here; there)
+
+⊔-swap : ∀ x y z → (x ⊔ (y ⊔ z)) ≡ (y ⊔ (x ⊔ z))
+⊔-swap O y z = ≡-refl
+⊔-swap I O z = ≡-refl
+⊔-swap I I z = ≡-refl
+
+foldr-⊔-base : ∀ (b : Two) (ts : List Two) → foldr _⊔_ b ts ≡ (b ⊔ foldr _⊔_ O ts)
+foldr-⊔-base b []       = ≡-sym ⊔-runit
+foldr-⊔-base b (t ∷ ts) =
+  ≡-trans (≡-cong (t ⊔_) (foldr-⊔-base b ts)) (⊔-swap t b (foldr _⊔_ O ts))
+
+foldr-⊔-I : ∀ (b : Two) (ts : List Two) → foldr _⊔_ b ts ≡ I →
+            (b ≡ I) Sum.⊎ Any (_≡ I) ts
+foldr-⊔-I b []       h = Sum.inj₁ h
+foldr-⊔-I b (t ∷ ts) h with ⊔-I t (foldr _⊔_ b ts) h
+... | Sum.inj₁ e = Sum.inj₂ (here e)
+... | Sum.inj₂ e with foldr-⊔-I b ts e
+...   | Sum.inj₁ e' = Sum.inj₁ e'
+...   | Sum.inj₂ a  = Sum.inj₂ (there a)
+
+foldr-⊔-at : ∀ (b : Two) {ts : List Two} → Any (_≡ I) ts → foldr _⊔_ b ts ≡ I
+foldr-⊔-at b {t ∷ ts} (here e)  = ⊔-I-inl e
+foldr-⊔-at b {t ∷ ts} (there a) = ⊔-I-inr t (foldr-⊔-at b a)
+
+foldr-⊔-here : ∀ {b : Two} (ts : List Two) → b ≡ I → foldr _⊔_ b ts ≡ I
+foldr-⊔-here []       e = e
+foldr-⊔-here (t ∷ ts) e = ⊔-I-inr t (foldr-⊔-here ts e)
+
+foldr-⊔-zeros : ∀ {b : Two} {ts : List Two} → All (_≡ O) ts → foldr _⊔_ b ts ≡ b
+foldr-⊔-zeros []       = ≡-refl
+foldr-⊔-zeros (e ∷ es) = ≡-cong₂ _⊔_ e (foldr-⊔-zeros es)
+
 ------------------------------------------------------------------------------
 ¬ : Two → Two
 ¬ O = I
diff --git a/agda/src/type-substitution.agda b/agda/src/type-substitution.agda
new file mode 100644
index 00000000..f90f219a
--- /dev/null
+++ b/agda/src/type-substitution.agda
@@ -0,0 +1,174 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+open import Data.Fin using (Fin; zero; suc)
+open import Data.Nat using (ℕ; suc; _+_; _<_; _≤_; s≤s)
+open import Data.Nat.Properties using (≤-refl; ≤-trans; m≤m+n; m≤n+m; n≤1+n)
+open import Data.Product using (_×_; _,_)
+open import Data.Unit using (⊤; tt)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong; cong₂)
+open import signature using (Signature)
+
+-- Fusion laws for type-level renaming and substitution, and the unfolding law used to traverse values of
+-- nested inductive types.
+module type-substitution {ℓ} (Sig : Signature ℓ) where
+
+open import language-syntax Sig hiding (_,_)
+
+ren-cong : ∀ {Δ Δ'} {ρ ρ' : TyRen Δ Δ'} (τ : type Δ) → (∀ i → ρ i ≡ ρ' i) → ρ *ᵗ τ ≡ ρ' *ᵗ τ
+ren-cong (var i)     e = cong var (e i)
+ren-cong unit        e = refl
+ren-cong (base s)    e = refl
+ren-cong (τ₁ [+] τ₂) e = cong₂ _[+]_ (ren-cong τ₁ e) (ren-cong τ₂ e)
+ren-cong (τ₁ [×] τ₂) e = cong₂ _[×]_ (ren-cong τ₁ e) (ren-cong τ₂ e)
+ren-cong (τ₁ [→] τ₂) e = refl
+ren-cong (μ τ)       e = cong μ (ren-cong τ λ { zero → refl ; (suc i) → cong suc (e i) })
+
+ren-ren : ∀ {Δ₁ Δ₂ Δ₃} (ρ₁ : TyRen Δ₂ Δ₃) (ρ₂ : TyRen Δ₁ Δ₂) (τ : type Δ₁) →
+          ρ₁ *ᵗ (ρ₂ *ᵗ τ) ≡ (λ i → ρ₁ (ρ₂ i)) *ᵗ τ
+ren-ren ρ₁ ρ₂ (var i)     = refl
+ren-ren ρ₁ ρ₂ unit        = refl
+ren-ren ρ₁ ρ₂ (base s)    = refl
+ren-ren ρ₁ ρ₂ (τ₁ [+] τ₂) = cong₂ _[+]_ (ren-ren ρ₁ ρ₂ τ₁) (ren-ren ρ₁ ρ₂ τ₂)
+ren-ren ρ₁ ρ₂ (τ₁ [×] τ₂) = cong₂ _[×]_ (ren-ren ρ₁ ρ₂ τ₁) (ren-ren ρ₁ ρ₂ τ₂)
+ren-ren ρ₁ ρ₂ (τ₁ [→] τ₂) = refl
+ren-ren ρ₁ ρ₂ (μ τ)       =
+  cong μ (trans (ren-ren (extᵗ ρ₁) (extᵗ ρ₂) τ)
+                (ren-cong τ λ { zero → refl ; (suc i) → refl }))
+
+sub-ren : ∀ {Δ₁ Δ₂ Δ₃} (σ : TySub Δ₂ Δ₃) (ρ : TyRen Δ₁ Δ₂) (τ : type Δ₁) →
+          sub σ (ρ *ᵗ τ) ≡ sub (λ i → σ (ρ i)) τ
+sub-ren σ ρ (var i)     = refl
+sub-ren σ ρ unit        = refl
+sub-ren σ ρ (base s)    = refl
+sub-ren σ ρ (τ₁ [+] τ₂) = cong₂ _[+]_ (sub-ren σ ρ τ₁) (sub-ren σ ρ τ₂)
+sub-ren σ ρ (τ₁ [×] τ₂) = cong₂ _[×]_ (sub-ren σ ρ τ₁) (sub-ren σ ρ τ₂)
+sub-ren σ ρ (τ₁ [→] τ₂) = refl
+sub-ren σ ρ (μ τ)       =
+  cong μ (trans (sub-ren (sub-lift σ) (extᵗ ρ) τ)
+                (sub-cong τ λ { zero → refl ; (suc i) → refl }))
+
+ren-sub : ∀ {Δ₁ Δ₂ Δ₃} (ρ : TyRen Δ₂ Δ₃) (σ : TySub Δ₁ Δ₂) (τ : type Δ₁) →
+          ρ *ᵗ sub σ τ ≡ sub (λ i → ρ *ᵗ σ i) τ
+ren-sub ρ σ (var i)     = refl
+ren-sub ρ σ unit        = refl
+ren-sub ρ σ (base s)    = refl
+ren-sub ρ σ (τ₁ [+] τ₂) = cong₂ _[+]_ (ren-sub ρ σ τ₁) (ren-sub ρ σ τ₂)
+ren-sub ρ σ (τ₁ [×] τ₂) = cong₂ _[×]_ (ren-sub ρ σ τ₁) (ren-sub ρ σ τ₂)
+ren-sub ρ σ (τ₁ [→] τ₂) = refl
+ren-sub ρ σ (μ τ)       =
+  cong μ (trans (ren-sub (extᵗ ρ) (sub-lift σ) τ)
+                (sub-cong τ λ { zero → refl
+                              ; (suc i) → trans (ren-ren (extᵗ ρ) suc (σ i))
+                                                (sym (ren-ren suc ρ (σ i))) }))
+
+sub-sub : ∀ {Δ₁ Δ₂ Δ₃} (σ₁ : TySub Δ₂ Δ₃) (σ₂ : TySub Δ₁ Δ₂) (τ : type Δ₁) →
+          sub σ₁ (sub σ₂ τ) ≡ sub (λ i → sub σ₁ (σ₂ i)) τ
+sub-sub σ₁ σ₂ (var i)     = refl
+sub-sub σ₁ σ₂ unit        = refl
+sub-sub σ₁ σ₂ (base s)    = refl
+sub-sub σ₁ σ₂ (τ₁ [+] τ₂) = cong₂ _[+]_ (sub-sub σ₁ σ₂ τ₁) (sub-sub σ₁ σ₂ τ₂)
+sub-sub σ₁ σ₂ (τ₁ [×] τ₂) = cong₂ _[×]_ (sub-sub σ₁ σ₂ τ₁) (sub-sub σ₁ σ₂ τ₂)
+sub-sub σ₁ σ₂ (τ₁ [→] τ₂) = refl
+sub-sub σ₁ σ₂ (μ τ)       =
+  cong μ (trans (sub-sub (sub-lift σ₁) (sub-lift σ₂) τ)
+                (sub-cong τ λ { zero → refl
+                              ; (suc i) → trans (sub-ren (sub-lift σ₁) suc (σ₂ i))
+                                                (sym (ren-sub suc σ₁ (σ₂ i))) }))
+
+sub-id : ∀ {Δ} (τ : type Δ) → sub var τ ≡ τ
+sub-id (var i)     = refl
+sub-id unit        = refl
+sub-id (base s)    = refl
+sub-id (τ₁ [+] τ₂) = cong₂ _[+]_ (sub-id τ₁) (sub-id τ₂)
+sub-id (τ₁ [×] τ₂) = cong₂ _[×]_ (sub-id τ₁) (sub-id τ₂)
+sub-id (τ₁ [→] τ₂) = refl
+sub-id (μ τ)       = cong μ (trans (sub-cong τ λ { zero → refl ; (suc i) → refl }) (sub-id τ))
+
+unfold₁-sub : type 2 → TySub 2 1
+unfold₁-sub τ zero    = μ τ
+unfold₁-sub τ (suc i) = var i
+
+unfold₁ : type 2 → type 1
+unfold₁ τ = sub (unfold₁-sub τ) τ
+
+unfold₁-inst : ∀ (τ : type 2) (ρ : type 0) →
+               sub (push ρ) (unfold₁ τ) ≡
+               sub (sub-lift (push ρ)) τ [ μ (sub (sub-lift (push ρ)) τ) ]
+unfold₁-inst τ ρ =
+  trans (sub-sub (push ρ) (unfold₁-sub τ) τ)
+        (trans (sub-cong τ pw)
+               (sym (sub-sub (push (μ A)) (sub-lift (push ρ)) τ)))
+  where
+    A : type 1
+    A = sub (sub-lift (push ρ)) τ
+
+    pw : ∀ i → sub (push ρ) (unfold₁-sub τ i) ≡
+               sub (push (μ A)) (sub-lift (push ρ) i)
+    pw zero          = refl
+    pw (suc zero)    =
+      sym (trans (sub-ren (push (μ A)) suc ρ)
+                 (trans (sub-cong ρ λ ()) (sub-id ρ)))
+    pw (suc (suc ()))
+
+size : ∀ {Δ} → type Δ → ℕ
+size (var i)   = 1
+size unit      = 1
+size (base s)  = 1
+size (σ [+] τ) = suc (size σ + size τ)
+size (σ [×] τ) = suc (size σ + size τ)
+size (σ [→] τ) = suc (size σ + size τ)
+size (μ τ)     = suc (size τ)
+
+-- All arrow leaves have size below the bound. Substitution preserves arrow leaves verbatim, so the bound
+-- survives renaming, substitution and unfolding.
+arr-bound : ∀ {Δ} → ℕ → type Δ → Set
+arr-bound n (var i)     = ⊤
+arr-bound n unit        = ⊤
+arr-bound n (base s)    = ⊤
+arr-bound n (τ₁ [+] τ₂) = arr-bound n τ₁ × arr-bound n τ₂
+arr-bound n (τ₁ [×] τ₂) = arr-bound n τ₁ × arr-bound n τ₂
+arr-bound n (τ₁ [→] τ₂) = suc (size τ₁ + size τ₂) < n
+arr-bound n (μ τ)       = arr-bound n τ
+
+arr-mono : ∀ {Δ m n} (τ : type Δ) → m ≤ n → arr-bound m τ → arr-bound n τ
+arr-mono (var i)     e b        = tt
+arr-mono unit        e b        = tt
+arr-mono (base s)    e b        = tt
+arr-mono (τ₁ [+] τ₂) e (b , b') = arr-mono τ₁ e b , arr-mono τ₂ e b'
+arr-mono (τ₁ [×] τ₂) e (b , b') = arr-mono τ₁ e b , arr-mono τ₂ e b'
+arr-mono (τ₁ [→] τ₂) e b        = ≤-trans b e
+arr-mono (μ τ)       e b        = arr-mono τ e b
+
+arr-self : ∀ {Δ} (τ : type Δ) → arr-bound (suc (size τ)) τ
+arr-self (var i)     = tt
+arr-self unit        = tt
+arr-self (base s)    = tt
+arr-self (τ₁ [+] τ₂) = arr-mono τ₁ (s≤s (≤-trans (m≤m+n (size τ₁) (size τ₂)) (n≤1+n _))) (arr-self τ₁) ,
+                       arr-mono τ₂ (s≤s (≤-trans (m≤n+m (size τ₂) (size τ₁)) (n≤1+n _))) (arr-self τ₂)
+arr-self (τ₁ [×] τ₂) = arr-mono τ₁ (s≤s (≤-trans (m≤m+n (size τ₁) (size τ₂)) (n≤1+n _))) (arr-self τ₁) ,
+                       arr-mono τ₂ (s≤s (≤-trans (m≤n+m (size τ₂) (size τ₁)) (n≤1+n _))) (arr-self τ₂)
+arr-self (τ₁ [→] τ₂) = ≤-refl
+arr-self (μ τ)       = arr-mono τ (s≤s (n≤1+n _)) (arr-self τ)
+
+ren-arr : ∀ {Δ Δ' n} (ρ : TyRen Δ Δ') (τ : type Δ) → arr-bound n τ → arr-bound n (ρ *ᵗ τ)
+ren-arr ρ (var i)     b        = tt
+ren-arr ρ unit        b        = tt
+ren-arr ρ (base s)    b        = tt
+ren-arr ρ (τ₁ [+] τ₂) (b , b') = ren-arr ρ τ₁ b , ren-arr ρ τ₂ b'
+ren-arr ρ (τ₁ [×] τ₂) (b , b') = ren-arr ρ τ₁ b , ren-arr ρ τ₂ b'
+ren-arr ρ (τ₁ [→] τ₂) b        = b
+ren-arr ρ (μ τ)       b        = ren-arr (extᵗ ρ) τ b
+
+sub-arr : ∀ {Δ Δ' n} (σ : TySub Δ Δ') (τ : type Δ) →
+          (∀ i → arr-bound n (σ i)) → arr-bound n τ → arr-bound n (sub σ τ)
+sub-arr σ (var i)     bσ b        = bσ i
+sub-arr σ unit        bσ b        = tt
+sub-arr σ (base s)    bσ b        = tt
+sub-arr σ (τ₁ [+] τ₂) bσ (b , b') = sub-arr σ τ₁ bσ b , sub-arr σ τ₂ bσ b'
+sub-arr σ (τ₁ [×] τ₂) bσ (b , b') = sub-arr σ τ₁ bσ b , sub-arr σ τ₂ bσ b'
+sub-arr σ (τ₁ [→] τ₂) bσ b        = b
+sub-arr σ (μ τ)       bσ b        =
+  sub-arr (sub-lift σ) τ (λ { zero → tt ; (suc i) → ren-arr suc (σ i) (bσ i) }) b
+
+unfold₁-arr : ∀ {n} (τ : type 2) → arr-bound n τ → arr-bound n (unfold₁ τ)
+unfold₁-arr τ b = sub-arr (unfold₁-sub τ) τ (λ { zero → b ; (suc i) → tt }) b
diff --git a/agda/src/boolalg-sd-semimodule.agda b/agda/src/unused/boolalg-sd-semimodule.agda
similarity index 96%
rename from agda/src/boolalg-sd-semimodule.agda
rename to agda/src/unused/boolalg-sd-semimodule.agda
index 8d0bce01..fc19dcc9 100644
--- a/agda/src/boolalg-sd-semimodule.agda
+++ b/agda/src/unused/boolalg-sd-semimodule.agda
@@ -2,6 +2,7 @@
 
 open import Level using (0ℓ; suc)
 open import prop-setoid using (Setoid; IsEquivalence)
+import Data.Nat as Nat
 open import categories using (Category; HasTerminal; IsTerminal; HasInitial; IsInitial; HasProducts)
 open import commutative-semiring using (CommutativeSemiring; BooleanAlgebra)
 open import cmon-enriched using (CMonEnriched; Biproduct; biproducts→products)
@@ -59,6 +60,14 @@ _⊕_ : SelfDualBooleanAlgebra → SelfDualBooleanAlgebra → SelfDualBooleanAlg
 (X ⊕ Y) .SelfDualBooleanAlgebra.boolean .lattice.BooleanAlgebra.compl-∧ {a , b} = SelfDualBooleanAlgebra.compl-∧ X , SelfDualBooleanAlgebra.compl-∧ Y
 (X ⊕ Y) .SelfDualBooleanAlgebra.boolean .lattice.BooleanAlgebra.compl-∨ {a , b} = SelfDualBooleanAlgebra.compl-∨ X , SelfDualBooleanAlgebra.compl-∨ Y
 
+-- The free self-dual Boolean algebras: iterated biproducts of the scalars, normalised so that the
+-- object of width one is 𝕀 itself.
+infix 30 S^_
+S^_ : Nat.ℕ → SelfDualBooleanAlgebra
+S^ Nat.zero = 𝟘
+S^ (Nat.suc Nat.zero) = 𝕀
+S^ (Nat.suc (Nat.suc n)) = 𝕀 ⊕ S^ (Nat.suc n)
+
 cat : Category (suc 0ℓ) 0ℓ 0ℓ
 cat .Category.obj = SelfDualBooleanAlgebra
 cat .Category._⇒_ X Y = obj X ⇒ obj Y
diff --git a/agda/src/cbn-translation.agda b/agda/src/unused/cbn-translation.agda
similarity index 100%
rename from agda/src/cbn-translation.agda
rename to agda/src/unused/cbn-translation.agda
diff --git a/agda/src/unused/colimit-mu-types.agda b/agda/src/unused/colimit-mu-types.agda
new file mode 100644
index 00000000..172ef70b
--- /dev/null
+++ b/agda/src/unused/colimit-mu-types.agda
@@ -0,0 +1,892 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- μ-types (parameterised initial algebras of polynomial functors) in a category 𝒟 with an initial
+-- object and colimits of ω-chains, via the initial-algebra chain 0 → F0 → F²0 → ⋯ . Counterpart of
+-- fam-mu-types, which builds them in Fam(𝒞) via W-types.
+
+import Data.Fin as Fin
+open Fin using (Fin)
+open import Data.Nat using (ℕ; zero; suc; _≤′_; ≤′-refl; ≤′-step)
+open import categories
+  using (Category; HasTerminal; HasProducts; HasCoproducts; HasStrongCoproducts;
+         strong-coproducts→coproducts; HasInitial; IsInitial)
+open import Level using (_⊔_)
+open import functor
+  using (Functor; HasColimits; Colimit; IsColimit; NatTrans; ≃-NatTrans; constF; constFmor;
+         colambda-unique)
+  renaming (_∘_ to _∘NT_)
+open IsColimit
+open Colimit
+open import omega-chains
+  using (ω; chain; chain-map; colim-map; colim-map-cong; colim-map-comp; colim-map-id; square-comp;
+         step-cocone; cocone-step; const-chain-colimit; module interchange)
+open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong; cong₂)
+import polynomial-functor
+
+module colimit-mu-types
+  {o m e} {𝒟 : Category o m e}
+  (𝒟T : HasTerminal 𝒟) (𝒟P : HasProducts 𝒟) (𝒟SC : HasStrongCoproducts 𝒟 𝒟P)
+  (𝒟I : HasInitial 𝒟)
+  (colimits : HasColimits ω 𝒟)
+  where
+
+open Category 𝒟
+open HasProducts 𝒟P
+open HasCoproducts (strong-coproducts→coproducts 𝒟T 𝒟SC)
+  using (coprod; coprod-m; coprod-m-cong; coprod-m-comp; coprod-m-id; in₁; in₂;
+         copair; copair-cong; copair-in₁; copair-in₂; copair-ext; copair-coprod)
+open HasStrongCoproducts 𝒟SC using () renaming (copair to scopair; copair-cong to scopair-cong;
+       copair-in₁ to scopair-in₁; copair-in₂ to scopair-in₂; copair-ext to scopair-ext)
+open HasInitial 𝒟I renaming (witness to 𝟘)
+open polynomial-functor 𝒟T 𝒟P 𝒟SC using (Poly; extend; fobj; _∘co_; HasMu; HasMuLaws)
+open Poly
+
+-- The strong copair absorbs a coproduct reindexing precomposed in the recursion coordinate.
+scopair-fuse : ∀ {Γ X Y X' Y' Z} (f : prod Γ X' ⇒ Z) (g : prod Γ Y' ⇒ Z) (h : X ⇒ X') (k : Y ⇒ Y') →
+  scopair f g ∘ prod-m (id Γ) (coprod-m h k)
+    ≈ scopair (f ∘ prod-m (id Γ) h) (g ∘ prod-m (id Γ) k)
+scopair-fuse {Γ} f g h k =
+  ≈-trans (≈-sym (scopair-ext (scopair f g ∘ prod-m (id Γ) (coprod-m h k))))
+          (scopair-cong branch₁ branch₂)
+  where
+    commute₁ : prod-m (id Γ) (coprod-m h k) ∘ pair p₁ (in₁ ∘ p₂)
+                 ≈ pair p₁ (in₁ ∘ p₂) ∘ prod-m (id Γ) h
+    commute₁ =
+      ≈-trans (≈-trans (pair-compose _ _ _ _)
+                       (pair-cong₂ (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (copair-in₁ _ _)))))
+              (≈-sym (≈-trans (pair-natural _ _ _)
+                              (pair-cong (pair-p₁ _ _)
+                                         (≈-trans (assoc _ _ _)
+                                         (≈-trans (∘-cong₂ (pair-p₂ _ _)) (≈-sym (assoc _ _ _)))))))
+    commute₂ : prod-m (id Γ) (coprod-m h k) ∘ pair p₁ (in₂ ∘ p₂) ≈ pair p₁ (in₂ ∘ p₂) ∘ prod-m (id Γ) k
+    commute₂ =
+      ≈-trans (≈-trans (pair-compose _ _ _ _)
+                       (pair-cong₂ (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (copair-in₂ _ _)))))
+              (≈-sym (≈-trans (pair-natural _ _ _)
+                              (pair-cong (pair-p₁ _ _)
+                                         (≈-trans (assoc _ _ _)
+                                         (≈-trans (∘-cong₂ (pair-p₂ _ _)) (≈-sym (assoc _ _ _)))))))
+    branch₁ = ≈-trans (assoc _ _ _)
+              (≈-trans (∘-cong₂ commute₁)
+              (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (scopair-in₁ _ _))))
+    branch₂ = ≈-trans (assoc _ _ _)
+              (≈-trans (∘-cong₂ commute₂)
+              (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (scopair-in₂ _ _))))
+
+-- The strong copair is natural in the target: post-composition distributes over it.
+scopair-natural : ∀ {Γ X Y Z Z'} (h : Z ⇒ Z') (f : prod Γ X ⇒ Z) (g : prod Γ Y ⇒ Z) →
+                  h ∘ scopair f g ≈ scopair (h ∘ f) (h ∘ g)
+scopair-natural h f g =
+  ≈-trans (≈-sym (scopair-ext (h ∘ scopair f g)))
+          (scopair-cong (≈-trans (assoc _ _ _) (∘-cong₂ (scopair-in₁ _ _)))
+                        (≈-trans (assoc _ _ _) (∘-cong₂ (scopair-in₂ _ _))))
+
+-- Congruence and a prod-m absorption law for co-Kleisli composition.
+∘co-cong₂ : ∀ {Γ X Y Z} {f : prod Γ Y ⇒ Z} {g g' : prod Γ X ⇒ Y} → g ≈ g' → f ∘co g ≈ f ∘co g'
+∘co-cong₂ e = ∘-cong₂ (pair-cong₂ e)
+
+∘co-prod-m : ∀ {Γ A X Y X'} (f : prod Γ Y ⇒ A) (g : prod Γ X ⇒ Y) (h : X' ⇒ X) →
+             (f ∘co g) ∘ prod-m (id Γ) h ≈ f ∘co (g ∘ prod-m (id Γ) h)
+∘co-prod-m f g h =
+  ≈-trans (assoc _ _ _)
+          (∘-cong₂ (≈-trans (pair-natural _ _ _)
+                            (pair-cong₁ (≈-trans (pair-p₁ _ _) id-left))))
+
+-- The interpretation of a polynomial, by structural recursion: at μ, the colimit of the
+-- initial-algebra chain. (fobj cannot be used directly: it takes the complete μ-obj as an argument,
+-- which would not be structurally recursive. That fobj μ-carrier and ⟦_⟧ agree is ⟦⟧-fobj below.)
+mutual
+  ⟦_⟧ : ∀ {n} → Poly n → (Fin n → obj) → obj
+  ⟦ const A ⟧ δ = A
+  ⟦ var i ⟧   δ = δ i
+  ⟦ P + Q ⟧   δ = coprod (⟦ P ⟧ δ) (⟦ Q ⟧ δ)
+  ⟦ P × Q ⟧   δ = prod (⟦ P ⟧ δ) (⟦ Q ⟧ δ)
+  ⟦ μ P ⟧     δ = μ-carrier P δ
+
+  μ-carrier : ∀ {n} → Poly (suc n) → (Fin n → obj) → obj
+  μ-carrier P δ = colimits (chain (iter P δ) (step P δ)) .apex
+
+  -- The initial-algebra chain for P at parameters δ.
+  iter : ∀ {n} → Poly (suc n) → (Fin n → obj) → ℕ → obj
+  iter P δ zero    = 𝟘
+  iter P δ (suc k) = ⟦ P ⟧ (extend δ (iter P δ k))
+
+  step : ∀ {n} (P : Poly (suc n)) (δ : Fin n → obj) (k : ℕ) → iter P δ k ⇒ iter P δ (suc k)
+  step P δ zero    = from-initial
+  step P δ (suc k) = ⟦ P ⟧mor (extend-fam (step P δ k))
+
+  -- Carrier-shaped morphism family: f at position 0, id at positions 1..n.
+  extend-fam : ∀ {n} {δ : Fin n → obj} {X Y} → (X ⇒ Y) → ∀ i → extend δ X i ⇒ extend δ Y i
+  extend-fam f Fin.zero    = f
+  extend-fam f (Fin.suc i) = id _
+
+  -- Two-family version: fs on the parameters, f at the recursion slot.
+  extend-mor : ∀ {n} {δ δ' : Fin n → obj} {X Y} →
+               (∀ i → δ i ⇒ δ' i) → (X ⇒ Y) → ∀ i → extend δ X i ⇒ extend δ' Y i
+  extend-mor fs f Fin.zero    = f
+  extend-mor fs f (Fin.suc i) = fs i
+
+  -- Stage maps between the chains at different parameters.
+  iter-mor : ∀ {n} (P : Poly (suc n)) {δ δ' : Fin n → obj} →
+             (∀ i → δ i ⇒ δ' i) → ∀ k → iter P δ k ⇒ iter P δ' k
+  iter-mor P fs zero    = id 𝟘
+  iter-mor P fs (suc k) = ⟦ P ⟧mor (extend-mor fs (iter-mor P fs k))
+
+  -- The stage maps commute with the chain steps.
+  iter-mor-step : ∀ {n} (P : Poly (suc n)) {δ δ' : Fin n → obj} (fs : ∀ i → δ i ⇒ δ' i) (k : ℕ) →
+                  iter-mor P fs (suc k) ∘ step P δ k ≈ step P δ' k ∘ iter-mor P fs k
+  iter-mor-step P fs zero = ≈-trans (≈-sym (from-initial-ext _)) (from-initial-ext _)
+  iter-mor-step P {δ} {δ'} fs (suc k) =
+    ≈-trans (≈-sym (⟦ P ⟧mor-comp (extend-mor fs (iter-mor P fs (suc k))) (extend-fam (step P δ k))))
+    (≈-trans (⟦ P ⟧mor-cong pointwise)
+             (⟦ P ⟧mor-comp (extend-fam (step P δ' k)) (extend-mor fs (iter-mor P fs k))))
+    where
+      pointwise : ∀ i → extend-mor fs (iter-mor P fs (suc k)) i ∘ extend-fam (step P δ k) i
+                      ≈ extend-fam (step P δ' k) i ∘ extend-mor fs (iter-mor P fs k) i
+      pointwise Fin.zero    = iter-mor-step P fs k
+      pointwise (Fin.suc i) = id-swap'
+
+  -- The stage maps respect pointwise-equal parameter families, and compose.
+  iter-mor-cong : ∀ {n} (P : Poly (suc n)) {δ δ' : Fin n → obj} {fs gs : ∀ i → δ i ⇒ δ' i} →
+                  (∀ i → fs i ≈ gs i) → ∀ k → iter-mor P fs k ≈ iter-mor P gs k
+  iter-mor-cong P fs≈gs zero    = ≈-refl
+  iter-mor-cong P {fs = fs} {gs} fs≈gs (suc k) = ⟦ P ⟧mor-cong pointwise
+    where
+      pointwise : ∀ i → extend-mor fs (iter-mor P fs k) i ≈ extend-mor gs (iter-mor P gs k) i
+      pointwise Fin.zero    = iter-mor-cong P fs≈gs k
+      pointwise (Fin.suc i) = fs≈gs i
+
+  iter-mor-comp : ∀ {n} (P : Poly (suc n)) {δ δ' δ'' : Fin n → obj}
+                  (fs : ∀ i → δ' i ⇒ δ'' i) (gs : ∀ i → δ i ⇒ δ' i) →
+                  ∀ k → iter-mor P (λ i → fs i ∘ gs i) k ≈ iter-mor P fs k ∘ iter-mor P gs k
+  iter-mor-comp P fs gs zero    = ≈-sym id-left
+  iter-mor-comp P fs gs (suc k) =
+    ≈-trans (⟦ P ⟧mor-cong pointwise)
+            (⟦ P ⟧mor-comp (extend-mor fs (iter-mor P fs k)) (extend-mor gs (iter-mor P gs k)))
+    where
+      pointwise : ∀ i → extend-mor (λ j → fs j ∘ gs j) (iter-mor P (λ j → fs j ∘ gs j) k) i ≈
+                        extend-mor fs (iter-mor P fs k) i ∘ extend-mor gs (iter-mor P gs k) i
+      pointwise Fin.zero    = iter-mor-comp P fs gs k
+      pointwise (Fin.suc i) = ≈-refl
+
+  -- Functorial action of ⟦ P ⟧.
+  ⟦_⟧mor : ∀ {n} (P : Poly n) {δ δ' : Fin n → obj} → (∀ i → δ i ⇒ δ' i) → ⟦ P ⟧ δ ⇒ ⟦ P ⟧ δ'
+  ⟦ const A ⟧mor fs = id A
+  ⟦ var i ⟧mor   fs = fs i
+  ⟦ P + Q ⟧mor   fs = coprod-m (⟦ P ⟧mor fs) (⟦ Q ⟧mor fs)
+  ⟦ P × Q ⟧mor   fs = prod-m (⟦ P ⟧mor fs) (⟦ Q ⟧mor fs)
+  ⟦ μ P ⟧mor {δ} {δ'} fs =
+    colim-map (step P δ) (step P δ') (iter-mor P fs) (iter-mor-step P fs)
+      (colimits (chain (iter P δ) (step P δ))) (colimits (chain (iter P δ') (step P δ')))
+
+  iter-mor-id : ∀ {n} (P : Poly (suc n)) {δ : Fin n → obj} (k : ℕ) →
+                iter-mor P (λ i → id (δ i)) k ≈ id (iter P δ k)
+  iter-mor-id P zero        = ≈-refl
+  iter-mor-id P {δ} (suc k) = ≈-trans (⟦ P ⟧mor-cong pointwise) ⟦ P ⟧mor-id
+    where
+      pointwise : ∀ i → extend-mor (λ j → id (δ j)) (iter-mor P (λ j → id (δ j)) k) i ≈
+                        id (extend δ (iter P δ k) i)
+      pointwise Fin.zero    = iter-mor-id P k
+      pointwise (Fin.suc i) = ≈-refl
+
+  ⟦_⟧mor-id : ∀ {n} (P : Poly n) {δ : Fin n → obj} → ⟦ P ⟧mor (λ i → id (δ i)) ≈ id (⟦ P ⟧ δ)
+  ⟦ const A ⟧mor-id = ≈-refl
+  ⟦ var i ⟧mor-id   = ≈-refl
+  ⟦ P + Q ⟧mor-id   = ≈-trans (coprod-m-cong ⟦ P ⟧mor-id ⟦ Q ⟧mor-id) coprod-m-id
+  ⟦ P × Q ⟧mor-id   = ≈-trans (prod-m-cong ⟦ P ⟧mor-id ⟦ Q ⟧mor-id) prod-m-id
+  ⟦ μ P ⟧mor-id {δ} =
+    ≈-trans (colim-map-cong {h'-step = λ k → id-swap} (iter-mor-id P) (colimits _) (colimits _))
+            (colim-map-id (colimits _))
+
+  ⟦_⟧mor-cong : ∀ {n} (P : Poly n) {δ δ' : Fin n → obj} {fs gs : ∀ i → δ i ⇒ δ' i} →
+                (∀ i → fs i ≈ gs i) → ⟦ P ⟧mor fs ≈ ⟦ P ⟧mor gs
+  ⟦ const A ⟧mor-cong fs≈gs = ≈-refl
+  ⟦ var i ⟧mor-cong   fs≈gs = fs≈gs i
+  ⟦ P + Q ⟧mor-cong   fs≈gs = coprod-m-cong (⟦ P ⟧mor-cong fs≈gs) (⟦ Q ⟧mor-cong fs≈gs)
+  ⟦ P × Q ⟧mor-cong   fs≈gs = prod-m-cong (⟦ P ⟧mor-cong fs≈gs) (⟦ Q ⟧mor-cong fs≈gs)
+  ⟦ μ P ⟧mor-cong     fs≈gs = colim-map-cong (iter-mor-cong P fs≈gs) (colimits _) (colimits _)
+
+  ⟦_⟧mor-comp : ∀ {n} (P : Poly n) {δ δ' δ'' : Fin n → obj}
+                (fs : ∀ i → δ' i ⇒ δ'' i) (gs : ∀ i → δ i ⇒ δ' i) →
+                ⟦ P ⟧mor (λ i → fs i ∘ gs i) ≈ ⟦ P ⟧mor fs ∘ ⟦ P ⟧mor gs
+  ⟦ const A ⟧mor-comp fs gs = ≈-sym id-left
+  ⟦ var i ⟧mor-comp   fs gs = ≈-refl
+  ⟦ P + Q ⟧mor-comp   fs gs =
+    ≈-trans (coprod-m-cong (⟦ P ⟧mor-comp fs gs) (⟦ Q ⟧mor-comp fs gs)) (coprod-m-comp _ _ _ _)
+  ⟦ P × Q ⟧mor-comp   fs gs =
+    ≈-trans (prod-m-cong (⟦ P ⟧mor-comp fs gs) (⟦ Q ⟧mor-comp fs gs)) (prod-m-comp _ _ _ _)
+  ⟦ μ P ⟧mor-comp {δ = δ} {δ'} {δ''} fs gs =
+    ≈-trans (colim-map-cong {h'-step = comp-sq} (iter-mor-comp P fs gs) (colimits _) (colimits _))
+            (colim-map-comp (colimits _) (colimits _) (colimits _))
+    where
+      comp-sq : ∀ k → (iter-mor P fs (suc k) ∘ iter-mor P gs (suc k)) ∘ step P δ k
+                    ≈ step P δ'' k ∘ (iter-mor P fs k ∘ iter-mor P gs k)
+      comp-sq = square-comp {𝒞 = 𝒟} (iter-mor-step P gs) (iter-mor-step P fs)
+
+-- ⟦_⟧ agrees with fobj at μ-carrier: the two are defined by matching clauses, so every case is a congruence.
+⟦⟧-fobj : ∀ {n} (P : Poly n) (δ : Fin n → obj) → ⟦ P ⟧ δ ≡ fobj μ-carrier P δ
+⟦⟧-fobj (const A) δ = refl
+⟦⟧-fobj (var i)   δ = refl
+⟦⟧-fobj (P + Q)   δ = cong₂ coprod (⟦⟧-fobj P δ) (⟦⟧-fobj Q δ)
+⟦⟧-fobj (P × Q)   δ = cong₂ prod (⟦⟧-fobj P δ) (⟦⟧-fobj Q δ)
+⟦⟧-fobj (μ P)     δ = refl
+
+-- An environment chain: a chain of environments with a coordinatewise colimit. A record (with η)
+-- rather than a Fin-indexed family of packaged chains: the μ case extends an environment chain
+-- with the recursion coordinate, and needs the stage-k environment of the extension to reduce
+-- definitionally to an extend.
+record EnvChain (n : ℕ) : Set (o ⊔ m ⊔ e) where
+  field
+    obs      : ℕ → Fin n → obj
+    steps    : ∀ k i → obs k i ⇒ obs (suc k) i
+    apex     : Fin n → obj
+    inj      : ∀ k i → obs k i ⇒ apex i
+    inj-step : ∀ k i → inj k i ≈ inj (suc k) i ∘ steps k i
+    colimiting : ∀ i → IsColimit (chain {𝒞 = 𝒟} (λ k → obs k i) (λ k → steps k i)) (apex i)
+                                 (step-cocone (λ k → inj k i) (λ k → inj-step k i))
+open EnvChain
+
+-- The image of an environment chain under ⟦ P ⟧, and the statement that ⟦ P ⟧ preserves its
+-- colimit. (Cocontinuity must be joint in all coordinates: the chain defining a μ varies the
+-- recursion coordinate together with the parameters.)
+module _ {n} (P : Poly n) (E : EnvChain n) where
+
+  img-step : ∀ k → ⟦ P ⟧ (obs E k) ⇒ ⟦ P ⟧ (obs E (suc k))
+  img-step k = ⟦ P ⟧mor (steps E k)
+
+  img-chain : Functor ω 𝒟
+  img-chain = chain (λ k → ⟦ P ⟧ (obs E k)) img-step
+
+  img-inj : ∀ k → ⟦ P ⟧ (obs E k) ⇒ ⟦ P ⟧ (apex E)
+  img-inj k = ⟦ P ⟧mor (inj E k)
+
+  img-inj-step : ∀ k → img-inj k ≈ img-inj (suc k) ∘ img-step k
+  img-inj-step k =
+    ≈-trans (⟦ P ⟧mor-cong (inj-step E k)) (⟦ P ⟧mor-comp (inj E (suc k)) (steps E k))
+
+  img-cocone : NatTrans img-chain (constF ω (⟦ P ⟧ (apex E)))
+  img-cocone = step-cocone img-inj img-inj-step
+
+  -- ⟦ P ⟧ preserves the environment-chain colimit when the image cocone is itself colimiting.
+  PreservesChain : Set (o ⊔ m ⊔ e)
+  PreservesChain = IsColimit img-chain (⟦ P ⟧ (apex E)) img-cocone
+
+-- Canonical cocones: the pointwise product, coproduct and T-image of cocones, over the
+-- corresponding pointwise chains. Built with step-cocone so that they align definitionally with
+-- the image cocones of the corresponding polynomials.
+module _ {X Y : ℕ → obj} {f : ∀ k → X k ⇒ X (suc k)} {g : ∀ k → Y k ⇒ Y (suc k)} {a b : obj}
+         (cX : NatTrans (chain {𝒞 = 𝒟} X f) (constF ω a))
+         (cY : NatTrans (chain {𝒞 = 𝒟} Y g) (constF ω b)) where
+
+  open NatTrans
+
+  prod-cocone : NatTrans (chain {𝒞 = 𝒟} (λ k → prod (X k) (Y k)) (λ k → prod-m (f k) (g k)))
+                         (constF ω (prod a b))
+  prod-cocone =
+    step-cocone (λ k → prod-m (cX .transf k) (cY .transf k))
+      (λ k → ≈-trans (prod-m-cong (cocone-step cX k) (cocone-step cY k)) (prod-m-comp _ _ _ _))
+
+  coprod-cocone : NatTrans (chain {𝒞 = 𝒟} (λ k → coprod (X k) (Y k)) (λ k → coprod-m (f k) (g k)))
+                           (constF ω (coprod a b))
+  coprod-cocone =
+    step-cocone (λ k → coprod-m (cX .transf k) (cY .transf k))
+      (λ k → ≈-trans (coprod-m-cong (cocone-step cX k) (cocone-step cY k)) (coprod-m-comp _ _ _ _))
+
+-- Coproducts preserve chain colimits: no assumption needed. A cocone over the coproduct chain
+-- restricts along each injection, and the copairing of the mediated maps mediates.
+module _ {X Y : ℕ → obj} {f : ∀ k → X k ⇒ X (suc k)} {g : ∀ k → Y k ⇒ Y (suc k)} {a b : obj}
+         {cX : NatTrans (chain {𝒞 = 𝒟} X f) (constF ω a)}
+         {cY : NatTrans (chain {𝒞 = 𝒟} Y g) (constF ω b)} where
+
+  open NatTrans
+
+  private
+    module _ {x : obj} (β : NatTrans (chain {𝒞 = 𝒟} (λ k → coprod (X k) (Y k)) (λ k → coprod-m (f k) (g k)))
+                                     (constF ω x)) where
+
+      restrict₁ : NatTrans (chain {𝒞 = 𝒟} X f) (constF ω x)
+      restrict₁ = step-cocone (λ k → β .transf k ∘ in₁)
+        (λ k → ≈-trans (∘-cong₁ (cocone-step β k))
+               (≈-trans (assoc _ _ _)
+               (≈-trans (∘-cong₂ (copair-in₁ _ _)) (≈-sym (assoc _ _ _)))))
+
+      restrict₂ : NatTrans (chain {𝒞 = 𝒟} Y g) (constF ω x)
+      restrict₂ = step-cocone (λ k → β .transf k ∘ in₂)
+        (λ k → ≈-trans (∘-cong₁ (cocone-step β k))
+               (≈-trans (assoc _ _ _)
+               (≈-trans (∘-cong₂ (copair-in₂ _ _)) (≈-sym (assoc _ _ _)))))
+
+  +-cocont : IsColimit (chain {𝒞 = 𝒟} X f) a cX → IsColimit (chain {𝒞 = 𝒟} Y g) b cY →
+             IsColimit (chain {𝒞 = 𝒟} (λ k → coprod (X k) (Y k)) (λ k → coprod-m (f k) (g k)))
+                       (coprod a b) (coprod-cocone cX cY)
+  +-cocont LX LY .colambda x β =
+    copair (LX .colambda x (restrict₁ β)) (LY .colambda x (restrict₂ β))
+  +-cocont LX LY .colambda-cong β≃γ =
+    copair-cong
+      (LX .colambda-cong (record { transf-eq = λ k → ∘-cong₁ (β≃γ .≃-NatTrans.transf-eq k) }))
+      (LY .colambda-cong (record { transf-eq = λ k → ∘-cong₁ (β≃γ .≃-NatTrans.transf-eq k) }))
+  +-cocont LX LY .colambda-coeval x β .≃-NatTrans.transf-eq k =
+    ≈-trans (≈-sym (copair-coprod _ _ _ _))
+    (≈-trans (copair-cong (LX .colambda-coeval x (restrict₁ β) .≃-NatTrans.transf-eq k)
+                          (LY .colambda-coeval x (restrict₂ β) .≃-NatTrans.transf-eq k))
+             (copair-ext _))
+  +-cocont LX LY .colambda-ext x h =
+    ≈-trans (copair-cong
+              (≈-trans (LX .colambda-cong E₁) (LX .colambda-ext x (h ∘ in₁)))
+              (≈-trans (LY .colambda-cong E₂) (LY .colambda-ext x (h ∘ in₂))))
+            (copair-ext h)
+    where
+      E₁ : ≃-NatTrans (restrict₁ (constFmor h ∘NT coprod-cocone cX cY)) (constFmor (h ∘ in₁) ∘NT cX)
+      E₁ .≃-NatTrans.transf-eq k =
+        ≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (copair-in₁ _ _)) (≈-sym (assoc _ _ _)))
+
+      E₂ : ≃-NatTrans (restrict₂ (constFmor h ∘NT coprod-cocone cX cY)) (constFmor (h ∘ in₂) ∘NT cY)
+      E₂ .≃-NatTrans.transf-eq k =
+        ≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (copair-in₂ _ _)) (≈-sym (assoc _ _ _)))
+
+-- Cocontinuity of the interpretation: assuming products and T preserve chain colimits, every
+-- ⟦ P ⟧ (extend δ −) does. Coproducts need no assumption (they commute with all colimits, proved below), and
+-- the μ case is the interchange of colimits.
+module cocont
+  (×-cocont : ∀ {X Y : ℕ → obj} {f : ∀ k → X k ⇒ X (suc k)} {g : ∀ k → Y k ⇒ Y (suc k)} {a b : obj}
+              {cX : NatTrans (chain {𝒞 = 𝒟} X f) (constF ω a)}
+              {cY : NatTrans (chain {𝒞 = 𝒟} Y g) (constF ω b)} →
+              IsColimit (chain {𝒞 = 𝒟} X f) a cX → IsColimit (chain {𝒞 = 𝒟} Y g) b cY →
+              IsColimit _ (prod a b) (prod-cocone cX cY))
+  -- The catamorphism's base leg prod Γ 𝟘 ⇒ A needs prod Γ 𝟘 to be initial. (Automatic with
+  -- exponentials, and holds in Fam 𝒟 since the index of prod Γ 𝟘 is empty.)
+  (prod𝟘-initial : ∀ {Γ} → IsInitial 𝒟 (prod Γ 𝟘))
+  where
+
+  open functor using (IsColimit-cong)
+
+  ⟦_⟧-cocont : ∀ {n} (P : Poly n) (E : EnvChain n) → PreservesChain P E
+  ⟦ const A ⟧-cocont E =
+    IsColimit-cong (record { transf-eq = λ k → ≈-refl }) (const-chain-colimit A .isColimit)
+  ⟦ var i ⟧-cocont   E =
+    IsColimit-cong (record { transf-eq = λ k → ≈-refl }) (colimiting E i)
+  ⟦ P + Q ⟧-cocont   E = +-cocont (⟦ P ⟧-cocont E) (⟦ Q ⟧-cocont E)
+  ⟦ P × Q ⟧-cocont   E = ×-cocont (⟦ P ⟧-cocont E) (⟦ Q ⟧-cocont E)
+  ⟦_⟧-cocont {n} (μ P) E = IsColimit-cong (record { transf-eq = legs-eq }) IC.is-colimit
+    where
+      Rk : ∀ k → Colimit (chain {𝒞 = 𝒟} (iter P (obs E k)) (step P (obs E k)))
+      Rk k = colimits (chain (iter P (obs E k)) (step P (obs E k)))
+
+      -- Column cocone legs commute with the horizontal steps, and with the vertical steps.
+      ℓ-step : ∀ k j → iter-mor P (inj E k) j ≈ iter-mor P (inj E (suc k)) j ∘ iter-mor P (steps E k) j
+      ℓ-step k j =
+        ≈-trans (iter-mor-cong P (inj-step E k) j) (iter-mor-comp P (inj E (suc k)) (steps E k) j)
+
+      ℓ-v : ∀ k j → step P (apex E) j ∘ iter-mor P (inj E k) j ≈
+                    iter-mor P (inj E k) (suc j) ∘ step P (obs E k) j
+      ℓ-v k j = ≈-sym (iter-mor-step P (inj E k) j)
+
+      -- Column j has colimit iter P (apex E) j, by induction on j: column 0 is constantly 𝟘, and
+      -- column j+1 is the ⟦ P ⟧-image of the environment chain extended with column j.
+      extend-env : ℕ → EnvChain (suc n)
+      columns : ∀ j → IsColimit (chain {𝒞 = 𝒟} (λ k → iter P (obs E k) j) (λ k → iter-mor P (steps E k) j))
+                                (iter P (apex E) j)
+                                (step-cocone (λ k → iter-mor P (inj E k) j) (λ k → ℓ-step k j))
+
+      extend-env j .obs k      = extend (obs E k) (iter P (obs E k) j)
+      extend-env j .steps k    = extend-mor (steps E k) (iter-mor P (steps E k) j)
+      extend-env j .apex       = extend (apex E) (iter P (apex E) j)
+      extend-env j .inj k      = extend-mor (inj E k) (iter-mor P (inj E k) j)
+      extend-env j .inj-step k Fin.zero    = ℓ-step k j
+      extend-env j .inj-step k (Fin.suc i) = inj-step E k i
+      extend-env j .colimiting Fin.zero    = columns j
+      extend-env j .colimiting (Fin.suc i) = colimiting E i
+
+      columns zero    = IsColimit-cong (record { transf-eq = λ k → ≈-refl }) (const-chain-colimit 𝟘 .isColimit)
+      columns (suc j) = ⟦ P ⟧-cocont (extend-env j)
+
+      module IC = interchange {𝒞 = 𝒟}
+        (λ k j → iter P (obs E k) j)
+        (λ k j → step P (obs E k) j)
+        (λ k j → iter-mor P (steps E k) j)
+        (λ k j → iter-mor-step P (steps E k) j)
+        Rk
+        (iter P (apex E)) (step P (apex E))
+        (λ k j → iter-mor P (inj E k) j)
+        ℓ-step ℓ-v columns
+        (colimits (chain (iter P (apex E)) (step P (apex E))))
+
+      -- The interchange cocone legs agree with the canonical ones (both mediate the same legs).
+      legs-eq : ∀ k → IC.ρ-inj k ≈ ⟦ μ P ⟧mor (inj E k)
+      legs-eq k = Rk k .colambda-cong (record { transf-eq = λ j → ≈-refl })
+
+  -- The initial-algebra colimit and its injections.
+  μ-colim : ∀ {n} (P : Poly (suc n)) (δ : Fin n → obj) → Colimit (chain {𝒞 = 𝒟} (iter P δ) (step P δ))
+  μ-colim P δ = colimits (chain (iter P δ) (step P δ))
+
+  μ-inj : ∀ {n} (P : Poly (suc n)) (δ : Fin n → obj) (k : ℕ) → iter P δ k ⇒ μ-carrier P δ
+  μ-inj P δ k = μ-colim P δ .cocone .NatTrans.transf k
+
+  -- The constant environment δ, extended in the recursion coordinate by the initial-algebra
+  -- chain and its colimit.
+  carrier-env : ∀ {n} (P : Poly (suc n)) (δ : Fin n → obj) → EnvChain (suc n)
+  carrier-env P δ .obs k   = extend δ (iter P δ k)
+  carrier-env P δ .steps k = extend-fam (step P δ k)
+  carrier-env P δ .apex    = extend δ (μ-carrier P δ)
+  carrier-env P δ .inj k   = extend-fam (μ-inj P δ k)
+  carrier-env P δ .inj-step k Fin.zero    = cocone-step (μ-colim P δ .cocone) k
+  carrier-env P δ .inj-step k (Fin.suc i) = ≈-sym id-left
+  carrier-env P δ .colimiting Fin.zero    =
+    IsColimit-cong (record { transf-eq = λ k → ≈-refl }) (μ-colim P δ .isColimit)
+  carrier-env P δ .colimiting (Fin.suc i) =
+    IsColimit-cong (record { transf-eq = λ k → ≈-refl }) (const-chain-colimit (δ i) .isColimit)
+
+  -- The shifted cocone whose mediator is the algebra map.
+  shifted-cocone : ∀ {n} (P : Poly (suc n)) (δ : Fin n → obj) →
+                   NatTrans (chain {𝒞 = 𝒟} (λ k → iter P δ (suc k)) (λ k → step P δ (suc k)))
+                            (constF ω (μ-carrier P δ))
+  shifted-cocone P δ = step-cocone (λ k → μ-inj P δ (suc k)) (λ k → cocone-step (μ-colim P δ .cocone) (suc k))
+
+  -- The algebra map: by cocontinuity, ⟦ P ⟧ at the carrier is the colimit of the shifted
+  -- initial-algebra chain, which the shifted injections mediate back into the carrier.
+  α : ∀ {n} (P : Poly (suc n)) (δ : Fin n → obj) → ⟦ P ⟧ (extend δ (μ-carrier P δ)) ⇒ μ-carrier P δ
+  α P δ = ⟦ P ⟧-cocont (carrier-env P δ) .colambda (μ-carrier P δ) (shifted-cocone P δ)
+
+  -- α mediates the shifted injections: precomposing with the k-th image leg gives the (k+1)-th.
+  α-coeval : ∀ {n} (P : Poly (suc n)) (δ : Fin n → obj) (k : ℕ) →
+             α P δ ∘ ⟦ P ⟧mor (extend-fam (μ-inj P δ k)) ≈ μ-inj P δ (suc k)
+  α-coeval P δ k =
+    ⟦ P ⟧-cocont (carrier-env P δ) .colambda-coeval (μ-carrier P δ) (shifted-cocone P δ) .≃-NatTrans.transf-eq k
+
+  -- The μ-functorial action mediates the injections: it sends the m-th δ-leg to the m-th δ'-leg
+  -- precomposed with the stage map.
+  μ-mor-coeval : ∀ {n} (P : Poly (suc n)) {δ δ' : Fin n → obj} (fs : ∀ i → δ i ⇒ δ' i) (m : ℕ) →
+                 ⟦ μ P ⟧mor fs ∘ μ-inj P δ m ≈ μ-inj P δ' m ∘ iter-mor P fs m
+  μ-mor-coeval P {δ} {δ'} fs m =
+    μ-colim P δ .colambda-coeval _
+      (μ-colim P δ' .cocone ∘NT chain-map (step P δ) (step P δ') (iter-mor P fs) (iter-mor-step P fs))
+      .≃-NatTrans.transf-eq m
+
+  -- Context-Γ version of extend-mor, for the strong action below.
+  strong-extend-mor : ∀ {n Γ} {δ δ' : Fin n → obj} {X Y} →
+                      (∀ i → prod Γ (δ i) ⇒ δ' i) → (prod Γ X ⇒ Y) →
+                      ∀ i → prod Γ (extend δ X i) ⇒ extend δ' Y i
+  strong-extend-mor fs f Fin.zero    = f
+  strong-extend-mor fs f (Fin.suc i) = fs i
+
+  -- The (Γ, left/right) projection of a strong product commutes past a product reindexing.
+  q₁-nat : ∀ {Γ X Y X' Y'} (a : X ⇒ X') (b : Y ⇒ Y') →
+           pair p₁ (p₁ ∘ p₂) ∘ prod-m (id Γ) (prod-m a b) ≈ prod-m (id Γ) a ∘ pair p₁ (p₁ ∘ p₂)
+  q₁-nat a b =
+    ≈-trans (pair-natural _ _ _)
+    (≈-trans (pair-cong (≈-trans (pair-p₁ _ _) id-left)
+                        (≈-trans (assoc _ _ _)
+                        (≈-trans (∘-cong₂ (pair-p₂ _ _))
+                        (≈-trans (≈-sym (assoc _ _ _))
+                        (≈-trans (∘-cong₁ (pair-p₁ _ _)) (assoc _ _ _))))))
+             (≈-sym (≈-trans (pair-compose _ _ _ _) (pair-cong₁ id-left))))
+
+  q₂-nat : ∀ {Γ X Y X' Y'} (a : X ⇒ X') (b : Y ⇒ Y') →
+           pair p₁ (p₂ ∘ p₂) ∘ prod-m (id Γ) (prod-m a b) ≈ prod-m (id Γ) b ∘ pair p₁ (p₂ ∘ p₂)
+  q₂-nat a b =
+    ≈-trans (pair-natural _ _ _)
+    (≈-trans (pair-cong (≈-trans (pair-p₁ _ _) id-left)
+                        (≈-trans (assoc _ _ _)
+                        (≈-trans (∘-cong₂ (pair-p₂ _ _))
+                        (≈-trans (≈-sym (assoc _ _ _))
+                        (≈-trans (∘-cong₁ (pair-p₂ _ _)) (assoc _ _ _))))))
+             (≈-sym (≈-trans (pair-compose _ _ _ _) (pair-cong₁ id-left))))
+
+  mutual
+    -- Fold legs: leg 0 out of the initial prod Γ 𝟘, leg (k+1) by the algebra after folding the
+    -- children. These form a cocone over the Γ-product of the initial-algebra chain (legs-step).
+    legs : ∀ {n Γ A} {P : Poly (suc n)} {δ : Fin n → obj} →
+           (prod Γ (⟦ P ⟧ (extend δ A)) ⇒ A) → ∀ k → prod Γ (iter P δ k) ⇒ A
+    legs alg zero             = prod𝟘-initial .IsInitial.from-initial
+    legs {P = P} alg (suc k)  = alg ∘co ⟦ P ⟧ˢ (strong-extend-mor (λ i → p₂) (legs alg k))
+
+    legs-step : ∀ {n Γ A} {P : Poly (suc n)} {δ : Fin n → obj}
+                (alg : prod Γ (⟦ P ⟧ (extend δ A)) ⇒ A) →
+                ∀ k → legs alg k ≈ legs alg (suc k) ∘ prod-m (id Γ) (step P δ k)
+    legs-step alg zero    = prod𝟘-initial .IsInitial.from-initial-ext _
+    legs-step {Γ = Γ} {P = P} {δ = δ} alg (suc k) =
+      ≈-trans (∘-cong₂ (pair-cong₂
+        (≈-trans (⟦ P ⟧ˢ-cong pointwise)
+                 (≈-sym (⟦ P ⟧ˢ-fuse (strong-extend-mor (λ i → p₂) (legs alg (suc k)))
+                                     (extend-fam (step P δ k)))))))
+        (≈-sym rhs-rewrite)
+      where
+        Z  = prod-m (id Γ) (step P δ (suc k))
+        G' = ⟦ P ⟧ˢ (strong-extend-mor (λ i → p₂) (legs alg (suc k)))
+
+        pointwise : ∀ i → strong-extend-mor (λ i → p₂) (legs alg k) i ≈
+                          strong-extend-mor (λ i → p₂) (legs alg (suc k)) i ∘ prod-m (id Γ) (extend-fam (step P δ k) i)
+        pointwise Fin.zero    = legs-step alg k
+        pointwise (Fin.suc i) = ≈-sym (≈-trans (∘-cong₂ prod-m-id) id-right)
+
+        -- Move the outer chain step inside the co-Kleisli composition.
+        rhs-rewrite : (alg ∘ pair p₁ G') ∘ Z ≈ alg ∘ pair p₁ (G' ∘ Z)
+        rhs-rewrite =
+          ≈-trans (assoc _ _ _)
+                  (∘-cong₂ (≈-trans (pair-natural _ _ _)
+                                    (pair-cong₁ (≈-trans (pair-p₁ _ _) id-left))))
+
+    -- Congruence of the fold legs in the algebra.
+    legs-cong : ∀ {n Γ A} (P : Poly (suc n)) (δ : Fin n → obj)
+                {alg alg' : prod Γ (⟦ P ⟧ (extend δ A)) ⇒ A} →
+                alg ≈ alg' → ∀ k → legs {P = P} {δ = δ} alg k ≈ legs {P = P} {δ = δ} alg' k
+    legs-cong P δ alg≈ zero    = ≈-refl
+    legs-cong P δ alg≈ (suc k) =
+      ∘-cong alg≈ (pair-cong ≈-refl
+        (⟦ P ⟧ˢ-cong (λ { Fin.zero → legs-cong P δ alg≈ k ; (Fin.suc i) → ≈-refl })))
+
+    -- The catamorphism in context Γ: mediate the cocone of fold legs out of the Γ-product of the
+    -- initial-algebra chain (a colimit by ×-cocont at the constant-Γ and initial-algebra chains).
+    ⦅_⦆ : ∀ {n Γ A} {P : Poly (suc n)} {δ : Fin n → obj} →
+          (prod Γ (⟦ P ⟧ (extend δ A)) ⇒ A) → prod Γ (μ-carrier P δ) ⇒ A
+    ⦅_⦆ {Γ = Γ} {A = A} {P = P} {δ = δ} alg =
+      ×-cocont (const-chain-colimit Γ .isColimit)
+               (colimits (chain (iter P δ) (step P δ)) .isColimit) .colambda A
+        (step-cocone (legs alg) (legs-step alg))
+
+    -- Congruence of the catamorphism in the algebra, by colimit uniqueness.
+    cata-cong : ∀ {n Γ A} {P : Poly (suc n)} {δ : Fin n → obj}
+                {alg alg' : prod Γ (⟦ P ⟧ (extend δ A)) ⇒ A} →
+                alg ≈ alg' → ⦅ alg ⦆ ≈ ⦅ alg' ⦆
+    cata-cong {Γ = Γ} {A = A} {P = P} {δ = δ} {alg = alg} {alg' = alg'} alg≈ =
+      ×-cocont (const-chain-colimit Γ .isColimit)
+               (colimits (chain (iter P δ) (step P δ)) .isColimit) .colambda-cong cocone-eq
+      where
+        cocone-eq : ≃-NatTrans (step-cocone (legs alg) (legs-step alg))
+                               (step-cocone (legs alg') (legs-step alg'))
+        cocone-eq .≃-NatTrans.transf-eq k = legs-cong P δ alg≈ k
+
+    -- Strong (context-Γ) functorial action of ⟦ P ⟧, as needed for the catamorphism legs. The μ case
+    -- is the catamorphism formula, mutually with the catamorphism itself (structurally decreasing:
+    -- the catamorphism at P uses the strong action of P's body).
+    ⟦_⟧ˢ : ∀ {n Γ} (P : Poly n) {δ δ' : Fin n → obj} →
+           (∀ i → prod Γ (δ i) ⇒ δ' i) → prod Γ (⟦ P ⟧ δ) ⇒ ⟦ P ⟧ δ'
+    ⟦ const A ⟧ˢ fs = p₂
+    ⟦ var i ⟧ˢ   fs = fs i
+    ⟦ P + Q ⟧ˢ   fs = scopair (in₁ ∘ ⟦ P ⟧ˢ fs) (in₂ ∘ ⟦ Q ⟧ˢ fs)
+    ⟦ P × Q ⟧ˢ   fs = pair (⟦ P ⟧ˢ fs ∘ pair p₁ (p₁ ∘ p₂)) (⟦ Q ⟧ˢ fs ∘ pair p₁ (p₂ ∘ p₂))
+    ⟦ μ P ⟧ˢ {δ = δ} {δ' = δ'} fs = ⦅_⦆ {P = P} {δ = δ} (α P δ' ∘ ⟦ P ⟧ˢ (strong-extend-mor fs p₂))
+
+    -- Congruence for the strong action.
+    ⟦_⟧ˢ-cong : ∀ {n Γ} (P : Poly n) {δ δ' : Fin n → obj} {fs gs : ∀ i → prod Γ (δ i) ⇒ δ' i} →
+                (∀ i → fs i ≈ gs i) → ⟦ P ⟧ˢ fs ≈ ⟦ P ⟧ˢ gs
+    ⟦ const A ⟧ˢ-cong fs≈gs = ≈-refl
+    ⟦ var i ⟧ˢ-cong   fs≈gs = fs≈gs i
+    ⟦ P + Q ⟧ˢ-cong   fs≈gs = scopair-cong (∘-cong₂ (⟦ P ⟧ˢ-cong fs≈gs)) (∘-cong₂ (⟦ Q ⟧ˢ-cong fs≈gs))
+    ⟦ P × Q ⟧ˢ-cong   fs≈gs = pair-cong (∘-cong₁ (⟦ P ⟧ˢ-cong fs≈gs)) (∘-cong₁ (⟦ Q ⟧ˢ-cong fs≈gs))
+    ⟦ μ P ⟧ˢ-cong     fs≈gs =
+      cata-cong (∘-cong₂ (⟦ P ⟧ˢ-cong (λ { Fin.zero → ≈-refl ; (Fin.suc i) → fs≈gs i })))
+
+    -- Fusion: the strong action absorbs a precomposed Γ-image of a reindexing.
+    ⟦_⟧ˢ-fuse : ∀ {n} (P : Poly n) {Γ} {δ δ' δ'' : Fin n → obj}
+                (fs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (gs : ∀ i → δ i ⇒ δ' i) →
+                ⟦ P ⟧ˢ fs ∘ prod-m (id Γ) (⟦ P ⟧mor gs) ≈ ⟦ P ⟧ˢ (λ i → fs i ∘ prod-m (id Γ) (gs i))
+    ⟦ const A ⟧ˢ-fuse fs gs = ≈-trans (∘-cong₂ prod-m-id) id-right
+    ⟦ var i ⟧ˢ-fuse   fs gs = ≈-refl
+    ⟦ P + Q ⟧ˢ-fuse   fs gs =
+      ≈-trans (scopair-fuse _ _ _ _)
+              (scopair-cong (≈-trans (assoc _ _ _) (∘-cong₂ (⟦ P ⟧ˢ-fuse fs gs)))
+                            (≈-trans (assoc _ _ _) (∘-cong₂ (⟦ Q ⟧ˢ-fuse fs gs))))
+    ⟦ P × Q ⟧ˢ-fuse {Γ = Γ} fs gs = ≈-trans (pair-natural _ _ _) (pair-cong P-comp Q-comp)
+      where
+        A' = ⟦ P ⟧mor gs
+        B' = ⟦ Q ⟧mor gs
+        P-comp = ≈-trans (assoc _ _ _)
+                 (≈-trans (∘-cong₂ (q₁-nat A' B'))
+                 (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (⟦ P ⟧ˢ-fuse fs gs))))
+        Q-comp = ≈-trans (assoc _ _ _)
+                 (≈-trans (∘-cong₂ (q₂-nat A' B'))
+                 (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (⟦ Q ⟧ˢ-fuse fs gs))))
+    ⟦ μ P ⟧ˢ-fuse {Γ = Γ} {δ = δ} {δ' = δ'} {δ'' = δ''} fs gs =
+      colambda-unique Rδ (λ k →
+        ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (≈-sym (prod-m-comp _ _ _ _)))
+        (≈-trans (∘-cong₂ (prod-m-cong ≈-refl
+                   (colimits (chain (iter P δ) (step P δ)) .colambda-coeval _ _ .≃-NatTrans.transf-eq k)))
+        (≈-trans (∘-cong₂ (prod-m-comp _ _ _ _))
+        (≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong₁ (Rδ' .colambda-coeval _ _ .≃-NatTrans.transf-eq k))
+        (≈-trans (legs-fuse P δ δ' δ'' fs gs k)
+                 (≈-sym (Rδ .colambda-coeval _ _ .≃-NatTrans.transf-eq k)))))))))
+      where
+        Rδ  = ×-cocont (const-chain-colimit Γ .isColimit)
+                       (colimits (chain (iter P δ) (step P δ)) .isColimit)
+        Rδ' = ×-cocont (const-chain-colimit Γ .isColimit)
+                       (colimits (chain (iter P δ') (step P δ')) .isColimit)
+
+    -- Left fusion: the plain action absorbs into the strong action on the left.
+    ⟦_⟧ˢ-fuse-left : ∀ {n} (P : Poly n) {Γ} {δ δ' δ'' : Fin n → obj}
+                     (fs : ∀ i → δ' i ⇒ δ'' i) (gs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                     ⟦ P ⟧mor fs ∘ ⟦ P ⟧ˢ gs ≈ ⟦ P ⟧ˢ (λ i → fs i ∘ gs i)
+    ⟦ const A ⟧ˢ-fuse-left fs gs = id-left
+    ⟦ var i ⟧ˢ-fuse-left fs gs = ≈-refl
+    ⟦ P + Q ⟧ˢ-fuse-left fs gs =
+      ≈-trans (scopair-natural _ _ _)
+              (scopair-cong (≈-trans (≈-sym (assoc _ _ _))
+                            (≈-trans (∘-cong₁ (copair-in₁ _ _))
+                            (≈-trans (assoc _ _ _) (∘-cong₂ (⟦ P ⟧ˢ-fuse-left fs gs)))))
+                            (≈-trans (≈-sym (assoc _ _ _))
+                            (≈-trans (∘-cong₁ (copair-in₂ _ _))
+                            (≈-trans (assoc _ _ _) (∘-cong₂ (⟦ Q ⟧ˢ-fuse-left fs gs))))))
+    ⟦ P × Q ⟧ˢ-fuse-left fs gs =
+      ≈-trans (pair-compose _ _ _ _)
+              (pair-cong (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (⟦ P ⟧ˢ-fuse-left fs gs)))
+                         (≈-trans (≈-sym (assoc _ _ _)) (∘-cong₁ (⟦ Q ⟧ˢ-fuse-left fs gs))))
+    ⟦ μ P ⟧ˢ-fuse-left {Γ = Γ} {δ = δ} {δ' = δ'} {δ'' = δ''} fs gs =
+      colambda-unique Rδ (λ k →
+        ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (Rδ .colambda-coeval _ _ .≃-NatTrans.transf-eq k))
+        (≈-trans (legs-left-fuse P δ δ' δ'' fs gs k)
+                 (≈-sym (Rδ .colambda-coeval _ _ .≃-NatTrans.transf-eq k)))))
+      where
+        Rδ = ×-cocont (const-chain-colimit Γ .isColimit)
+                      (colimits (chain (iter P δ) (step P δ)) .isColimit)
+
+    -- Fold-leg fusion: folding the δ-chain directly equals mapping δ→δ' then folding the δ'-chain.
+    legs-fuse : ∀ {n Γ} (P : Poly (suc n)) (δ δ' δ'' : Fin n → obj)
+                (fs : ∀ i → prod Γ (δ' i) ⇒ δ'' i) (gs : ∀ i → δ i ⇒ δ' i) (k : ℕ) →
+                legs {P = P} {δ = δ'} (α P δ'' ∘ ⟦ P ⟧ˢ (strong-extend-mor fs p₂)) k ∘ prod-m (id Γ) (iter-mor P gs k) ≈
+                legs (α P δ'' ∘ ⟦ P ⟧ˢ (strong-extend-mor (λ i → fs i ∘ prod-m (id Γ) (gs i)) p₂)) k
+    legs-fuse P δ δ' δ'' fs gs zero =
+      ≈-trans (≈-sym (prod𝟘-initial .IsInitial.from-initial-ext _))
+              (prod𝟘-initial .IsInitial.from-initial-ext _)
+    legs-fuse {Γ = Γ} P δ δ' δ'' fs gs (suc k) =
+      ≈-trans (∘co-prod-m _ _ _)
+        (≈-trans (∘co-cong₂ (⟦ P ⟧ˢ-fuse (strong-extend-mor (λ i → p₂) (legs alg-fs k))
+                                         (extend-mor gs (iter-mor P gs k))))
+          (≈-trans (∘co-cong₂ (⟦ P ⟧ˢ-cong {gs = λ i → extend-mor gs (id _) i ∘ leg i} leg-ih))
+            (≈-trans (∘co-cong₂ (≈-sym (⟦ P ⟧ˢ-fuse-left (extend-mor gs (id _)) leg)))
+              (≈-trans (∘-cong₂ (≈-sym (≈-trans (pair-compose _ _ _ _) (pair-cong₁ id-left))))
+                (≈-trans (≈-sym (assoc _ _ _))
+                  (∘-cong₁
+                    (≈-trans (assoc _ _ _)
+                      (∘-cong₂
+                        (≈-trans (⟦ P ⟧ˢ-fuse (strong-extend-mor fs p₂) (extend-mor gs (id _)))
+                          (⟦ P ⟧ˢ-cong route-gs))))))))))
+      where
+        alg-fs = α P δ'' ∘ ⟦ P ⟧ˢ (strong-extend-mor fs p₂)
+        alg-fg = α P δ'' ∘ ⟦ P ⟧ˢ (strong-extend-mor (λ i → fs i ∘ prod-m (id Γ) (gs i)) p₂)
+
+        leg : ∀ i → prod Γ (extend δ (iter P δ k) i) ⇒ extend δ (μ-carrier P δ'') i
+        leg = strong-extend-mor (λ i → p₂) (legs alg-fg k)
+
+        leg-ih : ∀ i → strong-extend-mor (λ i → p₂) (legs alg-fs k) i ∘ prod-m (id Γ) (extend-mor gs (iter-mor P gs k) i) ≈
+                       extend-mor gs (id _) i ∘ leg i
+        leg-ih Fin.zero    = ≈-trans (legs-fuse P δ δ' δ'' fs gs k) (≈-sym id-left)
+        leg-ih (Fin.suc j) = pair-p₂ _ _
+
+        route-gs : ∀ i → strong-extend-mor fs p₂ i ∘ prod-m (id Γ) (extend-mor gs (id _) i) ≈
+                         strong-extend-mor (λ i → fs i ∘ prod-m (id Γ) (gs i)) p₂ i
+        route-gs Fin.zero    = ≈-trans (∘-cong₂ prod-m-id) id-right
+        route-gs (Fin.suc j) = ≈-refl
+
+    -- α is natural: the algebra commutes with the μ-functorial action.
+    α-nat : ∀ {n} (P : Poly (suc n)) (δ δ' : Fin n → obj) (fs : ∀ i → δ i ⇒ δ' i) →
+            ⟦ μ P ⟧mor fs ∘ α P δ ≈ α P δ' ∘ ⟦ P ⟧mor (extend-mor fs (⟦ μ P ⟧mor fs))
+    α-nat P δ δ' fs = colambda-unique (⟦ P ⟧-cocont (carrier-env P δ)) (λ k →
+      ≈-trans (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (α-coeval P δ k)) (μ-mor-coeval P fs (suc k))))
+              (≈-sym (≈-trans (assoc _ _ _)
+                      (≈-trans (∘-cong₂ (≈-sym (⟦ P ⟧mor-comp _ _)))
+                      (≈-trans (∘-cong₂ (⟦ P ⟧mor-cong (famR k)))
+                      (≈-trans (∘-cong₂ (⟦ P ⟧mor-comp _ _))
+                      (≈-trans (≈-sym (assoc _ _ _))
+                               (∘-cong₁ (α-coeval P δ' k)))))))))
+      where
+        famR : ∀ k i → extend-mor fs (⟦ μ P ⟧mor fs) i ∘ extend-fam (μ-inj P δ k) i ≈
+                       extend-fam (μ-inj P δ' k) i ∘ extend-mor fs (iter-mor P fs k) i
+        famR k Fin.zero    = μ-mor-coeval P fs k
+        famR k (Fin.suc j) = id-swap'
+
+    -- Left fusion at the level of fold legs: post-composing a leg with the μ-functorial action.
+    legs-left-fuse : ∀ {n Γ} (P : Poly (suc n)) (δ δ' δ'' : Fin n → obj)
+                     (fs : ∀ i → δ' i ⇒ δ'' i) (gs : ∀ i → prod Γ (δ i) ⇒ δ' i) (k : ℕ) →
+                     ⟦ μ P ⟧mor fs ∘ legs {P = P} {δ = δ} (α P δ' ∘ ⟦ P ⟧ˢ (strong-extend-mor gs p₂)) k ≈
+                     legs {P = P} {δ = δ} (α P δ'' ∘ ⟦ P ⟧ˢ (strong-extend-mor (λ i → fs i ∘ gs i) p₂)) k
+    legs-left-fuse P δ δ' δ'' fs gs zero =
+      ≈-trans (≈-sym (prod𝟘-initial .IsInitial.from-initial-ext _))
+              (prod𝟘-initial .IsInitial.from-initial-ext _)
+    legs-left-fuse {Γ = Γ} P δ δ' δ'' fs gs (suc k) =
+      ≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong₁ (≈-sym (assoc _ _ _)))
+          (≈-trans (∘-cong₁ (∘-cong₁ (α-nat P δ' δ'' fs)))
+            (≈-trans (∘-cong₁ (assoc _ _ _))
+              (≈-trans (assoc _ _ _)
+                (≈-trans
+                  (∘-cong₂
+                    (≈-trans
+                      (∘-cong₁
+                        (≈-trans (⟦ P ⟧ˢ-fuse-left (extend-mor fs (⟦ μ P ⟧mor fs)) (strong-extend-mor gs p₂))
+                          (≈-trans (⟦ P ⟧ˢ-cong route-fs)
+                            (≈-sym (⟦ P ⟧ˢ-fuse (strong-extend-mor (λ i → fs i ∘ gs i) p₂) (extend-fam (⟦ μ P ⟧mor fs)))))))
+                      (≈-trans (assoc _ _ _)
+                        (∘-cong₂
+                          (≈-trans (pair-compose _ _ _ _)
+                            (≈-trans (pair-cong₁ id-left)
+                              (pair-cong₂
+                                (≈-trans
+                                  (⟦ P ⟧ˢ-fuse-left (extend-fam (⟦ μ P ⟧mor fs))
+                                    (strong-extend-mor (λ i → p₂)
+                                      (legs (α P δ' ∘ ⟦ P ⟧ˢ (strong-extend-mor gs p₂)) k)))
+                                  (⟦ P ⟧ˢ-cong leg-ih)))))))))
+                  (≈-sym (assoc _ _ _)))))))
+      where
+        route-fs : ∀ i → extend-mor fs (⟦ μ P ⟧mor fs) i ∘ strong-extend-mor gs p₂ i ≈
+                         strong-extend-mor (λ i → fs i ∘ gs i) p₂ i ∘ prod-m (id Γ) (extend-fam (⟦ μ P ⟧mor fs) i)
+        route-fs Fin.zero    = ≈-sym (pair-p₂ _ _)
+        route-fs (Fin.suc j) = ≈-sym (≈-trans (∘-cong₂ prod-m-id) id-right)
+
+        leg-ih : ∀ i → extend-fam (⟦ μ P ⟧mor fs) i ∘ strong-extend-mor (λ i → p₂) (legs (α P δ' ∘ ⟦ P ⟧ˢ (strong-extend-mor gs p₂)) k) i ≈
+                       strong-extend-mor (λ i → p₂) (legs (α P δ'' ∘ ⟦ P ⟧ˢ (strong-extend-mor (λ i → fs i ∘ gs i) p₂)) k) i
+        leg-ih Fin.zero    = legs-left-fuse P δ δ' δ'' fs gs k
+        leg-ih (Fin.suc j) = id-left
+
+  -- The catamorphism mediates the product injections: folding the k-th carrier leg gives the k-th fold leg.
+  cata-coeval : ∀ {n Γ A} {P : Poly (suc n)} {δ : Fin n → obj}
+                (alg : prod Γ (⟦ P ⟧ (extend δ A)) ⇒ A) (k : ℕ) →
+                ⦅ alg ⦆ ∘ prod-m (id Γ) (μ-inj P δ k) ≈ legs alg k
+  cata-coeval {Γ = Γ} {P = P} {δ = δ} alg k =
+    ×-cocont (const-chain-colimit Γ .isColimit) (colimits (chain (iter P δ) (step P δ)) .isColimit)
+      .colambda-coeval _ (step-cocone (legs alg) (legs-step alg)) .≃-NatTrans.transf-eq k
+
+  -- Catamorphism β: folding an α-image is the same as applying the algebra to the folded children.
+  cata-β : ∀ {n Γ A} {P : Poly (suc n)} {δ : Fin n → obj}
+           (alg : prod Γ (⟦ P ⟧ (extend δ A)) ⇒ A) →
+           ⦅ alg ⦆ ∘co (α P δ ∘ p₂) ≈ alg ∘co ⟦ P ⟧ˢ (strong-extend-mor (λ i → p₂) ⦅ alg ⦆)
+  cata-β {Γ = Γ} {P = P} {δ = δ} alg =
+    colambda-unique (×-cocont (const-chain-colimit Γ .isColimit) (⟦ P ⟧-cocont (carrier-env P δ)))
+      (λ k → ≈-trans (∘co-prod-m _ _ _)
+             (≈-trans (∘co-cong₂
+                        (≈-trans (assoc _ _ _)
+                        (≈-trans (∘-cong₂ (pair-p₂ _ _))
+                        (≈-trans (≈-sym (assoc _ _ _))
+                                 (∘-cong₁ (α-coeval P δ k))))))
+                      (≈-trans (∘-cong₂ (pair-cong₁ (≈-sym id-left)))
+                      (≈-trans (cata-coeval alg (suc k))
+                      (≈-sym (≈-trans (∘co-prod-m _ _ _)
+                      (≈-trans (∘co-cong₂ (⟦ P ⟧ˢ-fuse (strong-extend-mor (λ i → p₂) ⦅ alg ⦆) (extend-fam (μ-inj P δ k))))
+                               (∘co-cong₂ (⟦ P ⟧ˢ-cong (λ { Fin.zero → cata-coeval alg k
+                                                         ; (Fin.suc j) → ≈-trans (∘-cong₂ prod-m-id) id-right }))))))))))
+
+  hasMu : HasMu
+  hasMu .HasMu.μ-obj = μ-carrier
+  hasMu .HasMu.α P δ = α P δ ∘ ≡-to-⇒ (sym (⟦⟧-fobj P (extend δ (μ-carrier P δ))))
+  hasMu .HasMu.⦅_⦆ {_} {Γ} {A} {P} {δ} alg =
+    ⦅ alg ∘ prod-m (id Γ) (≡-to-⇒ (⟦⟧-fobj P (extend δ A))) ⦆
+
+  -- Some ≡-to-⇒ helpers.
+  ≡⇒-coprod : ∀ {X₁ X₂ Y₁ Y₂} (e₁ : X₁ ≡ X₂) (e₂ : Y₁ ≡ Y₂) →
+              ≡-to-⇒ (cong₂ coprod e₁ e₂) ≈ coprod-m (≡-to-⇒ e₁) (≡-to-⇒ e₂)
+  ≡⇒-coprod refl refl = ≈-sym coprod-m-id
+
+  ≡⇒-coprod-sym : ∀ {X₁ X₂ Y₁ Y₂} (e₁ : X₁ ≡ X₂) (e₂ : Y₁ ≡ Y₂) →
+                  ≡-to-⇒ (sym (cong₂ coprod e₁ e₂)) ≈ coprod-m (≡-to-⇒ (sym e₁)) (≡-to-⇒ (sym e₂))
+  ≡⇒-coprod-sym refl refl = ≈-sym coprod-m-id
+
+  ≡⇒-prod : ∀ {X₁ X₂ Y₁ Y₂} (e₁ : X₁ ≡ X₂) (e₂ : Y₁ ≡ Y₂) →
+            ≡-to-⇒ (cong₂ prod e₁ e₂) ≈ prod-m (≡-to-⇒ e₁) (≡-to-⇒ e₂)
+  ≡⇒-prod refl refl = ≈-sym prod-m-id
+
+  ≡⇒-prod-sym : ∀ {X₁ X₂ Y₁ Y₂} (e₁ : X₁ ≡ X₂) (e₂ : Y₁ ≡ Y₂) →
+                ≡-to-⇒ (sym (cong₂ prod e₁ e₂)) ≈ prod-m (≡-to-⇒ (sym e₁)) (≡-to-⇒ (sym e₂))
+  ≡⇒-prod-sym refl refl = ≈-sym prod-m-id
+
+  strong-fmor-⟦⟧ˢ : ∀ {n Γ} (P : Poly n) {δ δ' : Fin n → obj} (fs : ∀ i → prod Γ (δ i) ⇒ δ' i) →
+                    HasMu.strong-fmor hasMu P fs ≈
+                    ≡-to-⇒ (⟦⟧-fobj P δ') ∘ ⟦ P ⟧ˢ fs ∘ prod-m (id Γ) (≡-to-⇒ (sym (⟦⟧-fobj P δ)))
+  strong-fmor-⟦⟧ˢ (const A) fs = ≈-sym (≈-trans (∘-cong₁ id-left) (≈-trans (∘-cong₂ prod-m-id) id-right))
+  strong-fmor-⟦⟧ˢ (var i)   fs = ≈-sym (≈-trans (∘-cong₁ id-left) (≈-trans (∘-cong₂ prod-m-id) id-right))
+  strong-fmor-⟦⟧ˢ (P + Q) {δ = δ} {δ' = δ'} fs =
+    ≈-trans (scopair-cong (∘-cong₂ (strong-fmor-⟦⟧ˢ P fs)) (∘-cong₂ (strong-fmor-⟦⟧ˢ Q fs)))
+    (≈-sym
+    (≈-trans (≈-trans (∘-cong₁ (∘-cong₁ (≡⇒-coprod (⟦⟧-fobj P δ') (⟦⟧-fobj Q δ'))))
+                      (∘-cong₂ (prod-m-cong ≈-refl (≡⇒-coprod-sym (⟦⟧-fobj P δ) (⟦⟧-fobj Q δ)))))
+    (≈-trans (∘-cong₁ (scopair-natural _ _ _))
+    (≈-trans (scopair-fuse _ _ _ _)
+    (scopair-cong
+      (≈-trans (∘-cong₁ (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (copair-in₁ _ _)) (assoc _ _ _))))
+               (assoc _ _ _))
+      (≈-trans (∘-cong₁ (≈-trans (≈-sym (assoc _ _ _)) (≈-trans (∘-cong₁ (copair-in₂ _ _)) (assoc _ _ _))))
+               (assoc _ _ _)))))))
+  strong-fmor-⟦⟧ˢ (P × Q) {δ = δ} {δ' = δ'} fs =
+    ≈-trans (pair-cong (∘-cong₁ (strong-fmor-⟦⟧ˢ P fs)) (∘-cong₁ (strong-fmor-⟦⟧ˢ Q fs)))
+    (≈-sym
+    (≈-trans (≈-trans (∘-cong₁ (∘-cong₁ (≡⇒-prod (⟦⟧-fobj P δ') (⟦⟧-fobj Q δ'))))
+                      (∘-cong₂ (prod-m-cong ≈-refl (≡⇒-prod-sym (⟦⟧-fobj P δ) (⟦⟧-fobj Q δ)))))
+    (≈-trans (∘-cong₁ (pair-compose _ _ _ _))
+    (≈-trans (pair-natural _ _ _)
+    (pair-cong
+      (≈-trans (assoc _ _ _)
+      (≈-trans (∘-cong₂ (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (q₁-nat _ _)) (≈-sym (assoc _ _ _)))))
+      (≈-trans (≈-sym (assoc _ _ _))
+               (∘-cong₁ (≈-sym (assoc _ _ _))))))
+      (≈-trans (assoc _ _ _)
+      (≈-trans (∘-cong₂ (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (q₂-nat _ _)) (≈-sym (assoc _ _ _)))))
+      (≈-trans (≈-sym (assoc _ _ _))
+               (∘-cong₁ (≈-sym (assoc _ _ _)))))))))))
+  strong-fmor-⟦⟧ˢ (μ P) {δ = δ} {δ' = δ'} fs =
+    ≈-trans (cata-cong
+      (≈-trans (∘-cong₁ (∘-cong₂ (strong-fmor-⟦⟧ˢ P _)))
+      (≈-trans (≈-trans (assoc _ _ _) (assoc _ _ _))
+               (∘-cong₂
+                 (≈-trans (∘-cong₂ (≈-trans (∘-cong₁ (assoc _ _ _)) (assoc _ _ _)))
+                 (≈-trans (≈-sym (assoc _ _ _))
+                 (≈-trans (∘-cong₁ (≡-to-⇒-sym-l (⟦⟧-fobj P (extend δ' (μ-carrier P δ')))))
+                 (≈-trans id-left
+                 (≈-trans (assoc _ _ _)
+                 (≈-trans (∘-cong₂ (≈-trans (≈-sym (prod-m-comp _ _ _ _))
+                                   (≈-trans (prod-m-cong id-left (≡-to-⇒-sym-l (⟦⟧-fobj P (extend δ (μ-carrier P δ')))))
+                                            prod-m-id)))
+                 (≈-trans id-right
+                          (⟦ P ⟧ˢ-cong (λ { Fin.zero → ≈-refl ; (Fin.suc j) → ≈-refl })))))))))))))
+    (≈-sym (≈-trans (∘-cong₁ id-left) (≈-trans (∘-cong₂ prod-m-id) id-right)))
+
+  hasMuLaws : HasMuLaws hasMu
+  hasMuLaws .HasMuLaws.⦅⦆-β {P = P} alg =
+    ≈-trans (∘co-cong₂ (assoc _ _ _))
+    (≈-trans (∘co-cong₂ (∘-cong₂ (≈-sym (pair-p₂ (id _ ∘ p₁) _))))
+    (≈-trans (∘co-cong₂ (≈-sym (assoc _ _ _)))
+    (≈-trans (≈-sym (∘co-prod-m _ _ _))
+    (≈-trans (∘-cong₁ (cata-β _))
+    (≈-trans (∘co-prod-m _ _ _)
+    (≈-trans (assoc _ _ _)
+    (≈-trans (∘-cong₂ (pair-compose _ _ _ _))
+    (≈-trans (∘-cong₂ (pair-cong id-left ≈-refl))
+    (∘co-cong₂
+      (≈-trans (∘-cong₂ (∘-cong₁ (⟦ P ⟧ˢ-cong (λ { Fin.zero → ≈-refl ; (Fin.suc i) → ≈-refl }))))
+      (≈-trans (≈-sym (assoc _ _ _))
+               (≈-sym (strong-fmor-⟦⟧ˢ P _)))))))))))))
+  hasMuLaws .HasMuLaws.⦅⦆-η {Γ = Γ} {A = A} {P = P} {δ = δ} alg h eq =
+    colambda-unique
+      (×-cocont (const-chain-colimit Γ .isColimit) (colimits (chain (iter P δ) (step P δ)) .isColimit))
+      (λ k → ≈-trans (h-leg k) (≈-sym (cata-coeval _ k)))
+    where
+      h-leg : ∀ k → h ∘ prod-m (id Γ) (μ-inj P δ k) ≈ legs (alg ∘ prod-m (id Γ) (≡-to-⇒ (⟦⟧-fobj P (extend δ A)))) k
+      h-leg zero    = ≈-sym (prod𝟘-initial .IsInitial.from-initial-ext _)
+      h-leg (suc j) =
+        ≈-trans (∘-cong₂ (prod-m-cong ≈-refl (≈-sym (α-coeval P δ j))))
+        (≈-trans (∘-cong₂ (≈-trans (prod-m-cong (≈-sym id-left) ≈-refl) (prod-m-comp _ _ _ _)))
+        (≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong₁ (∘-cong₂ (pair-cong id-left ≈-refl)))
+        (≈-trans (∘-cong₂ (≈-trans (prod-m-cong (≈-sym id-left)
+                                      (≈-trans (≈-sym id-left)
+                                      (≈-trans (∘-cong₁ (≈-sym (≡-to-⇒-sym-l (⟦⟧-fobj P (extend δ (μ-carrier P δ))))))
+                                               (assoc _ _ _))))
+                                   (prod-m-comp _ _ _ _)))
+        (≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong₁ (≈-trans (∘co-prod-m _ _ _)
+                          (∘co-cong₂ (≈-trans (assoc _ _ _) (≈-trans (∘-cong₂ (pair-p₂ _ _)) (≈-sym (assoc _ _ _)))))))
+        (≈-trans (∘-cong₁ eq)
+        (≈-trans (∘co-prod-m _ _ _)
+        (≈-trans (∘co-cong₂
+                   (≈-trans (∘-cong₁ (strong-fmor-⟦⟧ˢ P _))
+                   (≈-trans (assoc _ _ _)
+                   (≈-trans (∘-cong₂ (≈-trans (≈-sym (prod-m-comp _ _ _ _))
+                                     (prod-m-cong id-left
+                                       (≈-trans (≈-sym (assoc _ _ _))
+                                       (≈-trans (∘-cong₁ (≡-to-⇒-sym-l (⟦⟧-fobj P (extend δ (μ-carrier P δ))))) id-left)))))
+                   (≈-trans (assoc _ _ _)
+                            (∘-cong₂ (≈-trans (⟦ P ⟧ˢ-fuse _ (extend-fam (μ-inj P δ j)))
+                                     (⟦ P ⟧ˢ-cong (λ { Fin.zero → h-leg j
+                                                     ; (Fin.suc i) → ≈-trans (∘-cong₂ prod-m-id) id-right })))))))))
+        (≈-trans (∘-cong₂ (≈-sym (≈-trans (pair-compose _ _ _ _) (pair-cong id-left ≈-refl))))
+                 (≈-sym (assoc _ _ _))))))))))))
diff --git a/agda/src/unused/example-bools.agda b/agda/src/unused/example-bools.agda
new file mode 100644
index 00000000..0558cf76
--- /dev/null
+++ b/agda/src/unused/example-bools.agda
@@ -0,0 +1,77 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- Backward analyses of the list and rose-tree examples for the language with
+-- general recursive types, over the self-dual Boolean algebras.
+
+module example-bools where
+
+open import Level using (lift)
+import Data.Fin as Fin
+open import Data.Sum using (inj₁; inj₂)
+open import Data.Product using (_,_)
+open import Data.Unit renaming (tt to ·) using ()
+open import Relation.Binary.PropositionalEquality using (_≡_) renaming (refl to ≡-refl)
+open import prop-setoid using (Setoid)
+open Setoid using (Carrier)
+import nat
+open import example.signature nat.ℕ using (Sig; number; label)
+open import label using (a; b)
+import two
+open import two renaming (I to ⊤; O to ⊥) using ()
+import example.bool
+import ho-model-boolalg-sd-semimod
+import example
+import indexed-family
+import galois
+import preorder
+
+module HB = ho-model-boolalg-sd-semimod two.semiring two.semiring-boolean
+module Ex = example nat.ℕ nat.zero
+
+open HB.interp-boolean Sig example.bool.D.BaseInterp1
+open indexed-family._⇒f_ using (transf)
+open galois._⇒g_ using (right)
+open preorder._=>_ using (fun)
+
+open Ex.L using (list; base; unit; var; μ; _[×]_; _[+]_; first-order)
+open Ex.ex using (query; rose; rose-query)
+
+module T = HB.Fam⟨𝒟⟩-μ.Tree {n = 0} (λ ())
+
+input : ⟦ list (base label [×] base number) ⟧ty (λ ()) .idx .Carrier
+input = T.sup (inj₂ ((a , 0) , T.sup (inj₂ ((b , 1) , T.sup (inj₂ ((a , 1) , T.sup (inj₁ (lift ·))))))))
+
+list-fo : first-order (list (base label [×] base number))
+list-fo = μ (unit [+] ((base label [×] base number) [×] var Fin.zero))
+
+bwd-slice : label.label → _
+bwd-slice l =
+  to-gal (𝟘 ⊕ ty₀ list-fo input) (ty₀ (base number) 0)
+         (⟦ query l ⟧tm .famf .transf (_ , input)) .right .fun ⊥
+
+-- Querying for the 'a' label uses the 1st and 3rd numbers.
+test1 : bwd-slice a ≡ (lift · , (lift · , ⊥) , (lift · , ⊤) , (lift · , ⊥) , _)
+test1 = ≡-refl
+
+-- Querying for the 'b' label uses the 2nd number.
+test2 : bwd-slice b ≡ (lift · , (lift · , ⊤) , (lift · , ⊥) , (lift · , ⊤) , _)
+test2 = ≡-refl
+
+-- Rose tree node 1 [node 2 [] , node 3 []]: the children lists are trees of a
+-- nested μ-type, so folding over the tree exercises the nested recursion.
+rose-input : ⟦ rose ⟧ty (λ ()) .idx .Carrier
+rose-input =
+  T.sup (1 , T.sup (inj₂ (T.sup (2 , T.sup (inj₁ (lift ·))) ,
+             T.sup (inj₂ (T.sup (3 , T.sup (inj₁ (lift ·))) , T.sup (inj₁ (lift ·)))))))
+
+rose-fo : first-order rose
+rose-fo = μ (base number [×] μ (unit [+] (var (Fin.suc Fin.zero) [×] var Fin.zero)))
+
+rose-bwd : _
+rose-bwd =
+  to-gal (𝟘 ⊕ ty₀ rose-fo rose-input) (ty₀ (base number) 0)
+         (⟦ rose-query ⟧tm .famf .transf (_ , rose-input)) .right .fun ⊥
+
+-- Summing demands every number in the tree.
+rose-test : rose-bwd ≡ (lift · , ⊥ , (⊥ , _) , (⊥ , _) , _)
+rose-test = ≡-refl
diff --git a/agda/src/example/bool-bwd.agda b/agda/src/unused/example/bool-bwd.agda
similarity index 58%
rename from agda/src/example/bool-bwd.agda
rename to agda/src/unused/example/bool-bwd.agda
index 5b0ef6ca..8a8bf38d 100644
--- a/agda/src/example/bool-bwd.agda
+++ b/agda/src/unused/example/bool-bwd.agda
@@ -4,16 +4,17 @@
 module example.bool-bwd where
 
 open import example.bool
+import Data.Fin as Fin
 
-input : ⟦ list (base label [×] base number) ⟧ty .idx .Carrier
-input = 3 , (a , 0) , (b , 1) , (a , 1) , _
+input : ⟦ list (base label [×] base number) ⟧ty (λ ()) .idx .Carrier
+input = T.sup (inj₂ ((a , 0) , T.sup (inj₂ ((b , 1) , T.sup (inj₂ ((a , 1) , T.sup (inj₁ (lift ·))))))))
 
-input-ty : first-order-data (list (base label [×] base number))
-input-ty = list (base label [×] base number)
+input-ty : first-order (list (base label [×] base number))
+input-ty = μ (unit [+] ((base label [×] base number) [×] var Fin.zero))
 
 bwd-slice : _ → _
 bwd-slice l =
-  to-gal (ty (unit [×] input-ty) (_ , input)) (ty (base number) 0)
+  to-gal (𝟘 ⊕ ty₀ input-ty input) (ty₀ (base number) 0)
          (mor (query l) (_ , input)) .right .fun ⊥
 
 -- Querying 'a' needs the 1st and 3rd numbers; querying 'b' needs the 2nd.
diff --git a/agda/src/example/bool-fwd.agda b/agda/src/unused/example/bool-fwd.agda
similarity index 76%
rename from agda/src/example/bool-fwd.agda
rename to agda/src/unused/example/bool-fwd.agda
index 8c0f818b..8af1fa80 100644
--- a/agda/src/example/bool-fwd.agda
+++ b/agda/src/unused/example/bool-fwd.agda
@@ -5,8 +5,8 @@ module example.bool-fwd where
 
 open import example.bool
 
-input : ⟦ list (base label [×] base number) ⟧ty .idx .Carrier
-input = 3 , (a , 0) , (b , 1) , (a , 1) , _
+input : ⟦ list (base label [×] base number) ⟧ty (λ ()) .idx .Carrier
+input = T.sup (inj₂ ((a , 0) , T.sup (inj₂ ((b , 1) , T.sup (inj₂ ((a , 1) , T.sup (inj₁ (lift ·))))))))
 
 -- Output depends on the 1st and 3rd numbers (those with label a), not the 2nd.
 test-1 : fwd (query a) (_ , input) (lift · , (lift · , ⊤) , (lift · , ⊥) , (lift · , ⊥) , _) ≡ ⊤
diff --git a/agda/src/example/bool-mult.agda b/agda/src/unused/example/bool-mult.agda
similarity index 100%
rename from agda/src/example/bool-mult.agda
rename to agda/src/unused/example/bool-mult.agda
diff --git a/agda/src/example/bool.agda b/agda/src/unused/example/bool.agda
similarity index 84%
rename from agda/src/example/bool.agda
rename to agda/src/unused/example/bool.agda
index 548efd6a..2864620d 100644
--- a/agda/src/example/bool.agda
+++ b/agda/src/unused/example/bool.agda
@@ -4,6 +4,7 @@
 -- (BaseInterp1), over the self-dual Boolean algebras as first-order model.
 module example.bool where
 
+open import Data.Nat using (ℕ)
 open import categories using (Category; HasInitial; HasProducts; HasTerminal)
 import cmon-enriched
 import prop
@@ -14,21 +15,22 @@ import indexed-family
 import galois
 import preorder
 import nat
-open import example.signature nat.ℕ using (Sig; number; label; approx) public
+open import example.signature nat.ℕ using (Sig; number; label) public
 import example
 
 -- Vocabulary re-exported for tests.
 open import Level using (lift) public
 open import Data.Unit renaming (tt to ·) using () public
 open import Data.Product using (_,_) public
+open import Data.Sum using (inj₁; inj₂) public
 open import Relation.Binary.PropositionalEquality using (_≡_; refl) public
 open import two renaming (I to ⊤; O to ⊥) using () public
 open import nat using (ℕ) public
 open import prop-setoid using (Setoid)
 open Setoid using (Carrier) public
-open import language-syntax Sig hiding (_,_) public   -- _⊢_, types, first-order-data, unit/base/list/_[×]_
+open import language-syntax Sig hiding (_,_) public   -- _⊢_, types, first-order, unit/base/list/_[×]_
 module Ex = example nat.ℕ nat.zero
-open Ex.ex public                                 -- query, mult-ex, cbn-query, sum, …
+open Ex.ex public                                 -- query, mult-ex, sum, …
 open import label using (a; b) public
 
 -- Model instantiation.
@@ -37,8 +39,11 @@ module BoolAlg-𝟚 = boolalg-sd-semimodule two.semiring two.semiring-boolean
 module SemiMod-𝟚 = semimodule two.semiring
 open cmon-enriched.CMonEnriched SemiMod-𝟚.cmon-enriched using (_+m_; εm)
 
+number-width : ℕ
+number-width = 1
+
 Approx : Category.obj BoolAlg-𝟚.cat
-Approx = BoolAlg-𝟚.𝕀
+Approx = BoolAlg-𝟚.S^ number-width
 
 approx-unit : Category._⇒_ BoolAlg-𝟚.cat (HasTerminal.witness BoolAlg-𝟚.terminal) Approx
 approx-unit = HasInitial.from-initial BoolAlg-𝟚.initial {Approx}
@@ -47,7 +52,7 @@ approx-conjunct = HasProducts.p₁ BoolAlg-𝟚.products {Approx} {Approx}
         +m HasProducts.p₂ BoolAlg-𝟚.products {Approx} {Approx}
 
 open import example.signature-interpretation BoolAlg-𝟚.cat BoolAlg-𝟚.products BoolAlg-𝟚.terminal
-  Approx approx-unit approx-conjunct nat.ℕₛ nat.add nat.mult public
+  BoolAlg-𝟚.S^_ (BoolAlg-𝟚.terminal .HasTerminal.is-terminal) number-width approx-unit approx-conjunct nat.ℕₛ nat.add nat.mult public
 
 -- Boolean-collapse derivative coefficient: zero map vs identity.
 private
@@ -63,6 +68,9 @@ private
 module D = Deriv coeff-b coeff-cong-b
 open ho-model-boolalg-sd-semimod.interp-boolean two.semiring two.semiring-boolean Sig D.BaseInterp1 public
 
+-- W-trees indexing the fibres of closed μ-types, for writing inputs.
+module T = Pm.Tree {n = 0} (λ ())
+
 open indexed-family._⇒f_ public
 open SemiMod-𝟚._⇒_ public
 open galois._⇒g_ public
diff --git a/agda/src/example/counting-total.agda b/agda/src/unused/example/counting-total.agda
similarity index 68%
rename from agda/src/example/counting-total.agda
rename to agda/src/unused/example/counting-total.agda
index 90cbeea1..10a53aee 100644
--- a/agda/src/example/counting-total.agda
+++ b/agda/src/unused/example/counting-total.agda
@@ -6,12 +6,14 @@
 module example.counting-total where
 
 open import example.counting
+import Data.Fin as Fin
 
-input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty .idx .Carrier
-input = (3 , (a , + 3 / 1) , (b , 1ℚ) , (a , -[1+ 2 ] / 1) , _) , (+ 2 / 1 , + 5 / 1)
+input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty (λ ()) .idx .Carrier
+input = T.sup (inj₂ ((a , + 3 / 1) , T.sup (inj₂ ((b , 1ℚ) , T.sup (inj₂ ((a , -[1+ 2 ] / 1) , T.sup (inj₁ (lift ·))))))))
+        , (+ 2 / 1 , + 5 / 1)
 
-input-ty : first-order-data ((list (base label [×] base number)) [×] (base number [×] base number))
-input-ty = list (base label [×] base number) [×] (base number [×] base number)
+input-ty : first-order ((list (base label [×] base number)) [×] (base number [×] base number))
+input-ty = μ (unit [+] ((base label [×] base number) [×] var Fin.zero)) [×] (base number [×] base number)
 
 -- One use of the first quantity reaches the output once.
 test-fwd-q₁ : fwd (total a) (_ , input)
@@ -27,7 +29,7 @@ test-fwd-price-a : fwd (total a) (_ , input)
 test-fwd-price-a = refl
 
 -- Backward derivative of the output: use-counts for every position.
-test-bwd : conjugate (ty (unit [×] input-ty) (_ , input)) (ty (base number) 0ℚ)
+test-bwd : conjugate (ty₀ (unit [×] input-ty) (_ , input)) (ty₀ (base number) 0ℚ)
              (mor (total a) (_ , input)) .func 1
-           ≡ (lift · , ((lift · , 1) , (lift · , 0) , (lift · , 1) , lift ·) , (2 , 0))
+           ≡ (lift · , ((lift · , 1) , (lift · , 0) , (lift · , 1) , _) , (2 , 0))
 test-bwd = refl
diff --git a/agda/src/example/counting.agda b/agda/src/unused/example/counting.agda
similarity index 88%
rename from agda/src/example/counting.agda
rename to agda/src/unused/example/counting.agda
index d64271bd..c1656faf 100644
--- a/agda/src/example/counting.agda
+++ b/agda/src/unused/example/counting.agda
@@ -18,6 +18,7 @@ open import commutative-semiring using (CommutativeSemiring)
 open import Level using (lift; 0ℓ) public
 open import Data.Unit renaming (tt to ·) using () public
 open import Data.Product using (_,_) public
+open import Data.Sum using (inj₁; inj₂) public
 open import Relation.Binary.PropositionalEquality using (_≡_; refl) public
 open import Data.Nat using (ℕ) public
 open import Data.Nat.Base public using (nonZero)
@@ -25,7 +26,7 @@ open import Data.Integer using (+_; -[1+_]) public
 open import Data.Rational using (ℚ; 0ℚ; 1ℚ; _/_) public
 open import prop-setoid using (Setoid)
 open Setoid using (Carrier) public
-open import example.signature ℚ using (Sig; number; label; approx) public
+open import example.signature ℚ using (Sig; number; label) public
 import example
 module Ex = example ℚ 0ℚ
 open Ex.ex public
@@ -38,8 +39,11 @@ module SDSemiMod-ℕ = sd-semimodule semiring-N.semiring
 module SemiMod-ℕ = semimodule semiring-N.semiring
 open cmon-enriched.CMonEnriched SemiMod-ℕ.cmon-enriched using (_+m_)
 
+number-width : ℕ
+number-width = 1
+
 Approx : Category.obj SDSemiMod-ℕ.cat
-Approx = SDSemiMod-ℕ.𝕀
+Approx = SDSemiMod-ℕ.S^ number-width
 
 approx-unit : Category._⇒_ SDSemiMod-ℕ.cat (HasTerminal.witness SDSemiMod-ℕ.terminal) Approx
 approx-unit = HasInitial.from-initial SDSemiMod-ℕ.initial {Approx}
@@ -60,7 +64,7 @@ private
   num-mult .func-resp-≈ e = Num.·-cong (prop.proj₁ e) (prop.proj₂ e)
 
 open import example.signature-interpretation SDSemiMod-ℕ.cat SDSemiMod-ℕ.products SDSemiMod-ℕ.terminal
-  Approx approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
+  SDSemiMod-ℕ.S^_ (SDSemiMod-ℕ.terminal .HasTerminal.is-terminal) number-width approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
 
 -- Use-counting coefficients: every argument of every operation counts as one use.
 private
@@ -75,6 +79,9 @@ module D = BinDeriv unit-c unit-c unit-c unit-c unit-c-cong unit-c-cong unit-c-c
 open ho-model-sd-semimod.interp-sd semiring-N.semiring Sig D.BaseInterp1 public
 open SDSemiMod-ℕ public using (conjugate)
 
+-- W-trees indexing the fibres of closed μ-types, for writing inputs.
+module T = Pm.Tree {n = 0} (λ ())
+
 open indexed-family._⇒f_ public
 open SemiMod-ℕ._⇒_ public
 
diff --git a/agda/src/example/free-total.agda b/agda/src/unused/example/free-total.agda
similarity index 74%
rename from agda/src/example/free-total.agda
rename to agda/src/unused/example/free-total.agda
index 16104d1c..e034b7c0 100644
--- a/agda/src/example/free-total.agda
+++ b/agda/src/unused/example/free-total.agda
@@ -7,13 +7,15 @@ module example.free-total where
 
 open import example.free
 import semiring-N
+import Data.Fin as Fin
 
 -- The run of the introduction, with each perturbable position seeded by its variable.
-input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty .idx .Carrier
-input = (3 , (a , + 3 / 1) , (b , 1ℚ) , (a , -[1+ 2 ] / 1) , _) , (+ 2 / 1 , + 5 / 1)
+input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty (λ ()) .idx .Carrier
+input = T.sup (inj₂ ((a , + 3 / 1) , T.sup (inj₂ ((b , 1ℚ) , T.sup (inj₂ ((a , -[1+ 2 ] / 1) , T.sup (inj₁ (lift ·))))))))
+        , (+ 2 / 1 , + 5 / 1)
 
-input-ty : first-order-data ((list (base label [×] base number)) [×] (base number [×] base number))
-input-ty = list (base label [×] base number) [×] (base number [×] base number)
+input-ty : first-order ((list (base label [×] base number)) [×] (base number [×] base number))
+input-ty = μ (unit [+] ((base label [×] base number) [×] var Fin.zero)) [×] (base number [×] base number)
 
 fwd-poly : Poly
 fwd-poly = fwd (total a) (_ , input)
@@ -30,7 +32,7 @@ test-eval-counting = refl
 bwd-polys : List Poly
 bwd-polys =
   let (_ , ((_ , p₁) , (_ , p₂) , (_ , p₃) , _) , (ppa , ppb)) =
-        conjugate (ty (unit [×] input-ty) (_ , input)) (ty (base number) 0ℚ)
+        conjugate (ty₀ (unit [×] input-ty) (_ , input)) (ty₀ (base number) 0ℚ)
           (mor (total a) (_ , input)) .func (var 5)
   in p₁ ∷ p₂ ∷ p₃ ∷ ppa ∷ ppb ∷ []
 
diff --git a/agda/src/example/free.agda b/agda/src/unused/example/free.agda
similarity index 89%
rename from agda/src/example/free.agda
rename to agda/src/unused/example/free.agda
index 1778b190..2997ca67 100644
--- a/agda/src/example/free.agda
+++ b/agda/src/unused/example/free.agda
@@ -21,6 +21,7 @@ open import commutative-semiring using (CommutativeSemiring)
 open import Level using (lift; 0ℓ) public
 open import Data.Unit renaming (tt to ·) using () public
 open import Data.Product using (_,_) public
+open import Data.Sum using (inj₁; inj₂) public
 open import Data.List using (List; []; _∷_; map) public
 open import Data.Nat using (ℕ) public
 open import Data.Nat.Base public using (nonZero)
@@ -31,7 +32,7 @@ open import Data.Integer using (+_; -[1+_]) public
 open import Data.Rational using (ℚ; 0ℚ; 1ℚ; _/_) public
 open import prop-setoid using (Setoid)
 open Setoid using (Carrier) public
-open import example.signature ℚ using (Sig; number; label; approx) public
+open import example.signature ℚ using (Sig; number; label) public
 import example
 module Ex = example ℚ 0ℚ
 open Ex.ex public
@@ -48,8 +49,11 @@ module SDSemiMod-Free = sd-semimodule Free.semiring
 module SemiMod-Free = semimodule Free.semiring
 open cmon-enriched.CMonEnriched SemiMod-Free.cmon-enriched using (_+m_)
 
+number-width : ℕ
+number-width = 1
+
 Approx : Category.obj SDSemiMod-Free.cat
-Approx = SDSemiMod-Free.𝕀
+Approx = SDSemiMod-Free.S^ number-width
 
 approx-unit : Category._⇒_ SDSemiMod-Free.cat (HasTerminal.witness SDSemiMod-Free.terminal) Approx
 approx-unit = HasInitial.from-initial SDSemiMod-Free.initial {Approx}
@@ -71,7 +75,7 @@ private
   num-mult .func-resp-≈ e = Num.·-cong (prop.proj₁ e) (prop.proj₂ e)
 
 open import example.signature-interpretation SDSemiMod-Free.cat SDSemiMod-Free.products SDSemiMod-Free.terminal
-  Approx approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
+  SDSemiMod-Free.S^_ (SDSemiMod-Free.terminal .HasTerminal.is-terminal) number-width approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
 
 -- Unit coefficients: every argument of every operation counts as one use.
 private
@@ -86,6 +90,9 @@ module D = BinDeriv unit-c unit-c unit-c unit-c unit-c-cong unit-c-cong unit-c-c
 open ho-model-sd-semimod.interp-sd Free.semiring Sig D.BaseInterp1 public
 open SDSemiMod-Free public using (conjugate)
 
+-- W-trees indexing the fibres of closed μ-types, for writing inputs.
+module T = Pm.Tree {n = 0} (λ ())
+
 open indexed-family._⇒f_ public
 open SemiMod-Free._⇒_ public
 
diff --git a/agda/src/example/intervals-mult-total.agda b/agda/src/unused/example/intervals-mult-total.agda
similarity index 72%
rename from agda/src/example/intervals-mult-total.agda
rename to agda/src/unused/example/intervals-mult-total.agda
index 8fbfe702..2d103bd9 100644
--- a/agda/src/example/intervals-mult-total.agda
+++ b/agda/src/unused/example/intervals-mult-total.agda
@@ -5,12 +5,14 @@
 module example.intervals-mult-total where
 
 open import example.intervals-mult
+import Data.Fin as Fin
 
-input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty .idx .Carrier
-input = (3 , (a , + 3 / 1) , (b , 1ℚ) , (a , -[1+ 2 ] / 1) , _) , (+ 2 / 1 , + 5 / 1)
+input : ⟦ (list (base label [×] base number)) [×] (base number [×] base number) ⟧ty (λ ()) .idx .Carrier
+input = T.sup (inj₂ ((a , + 3 / 1) , T.sup (inj₂ ((b , 1ℚ) , T.sup (inj₂ ((a , -[1+ 2 ] / 1) , T.sup (inj₁ (lift ·))))))))
+        , (+ 2 / 1 , + 5 / 1)
 
-input-ty : first-order-data ((list (base label [×] base number)) [×] (base number [×] base number))
-input-ty = list (base label [×] base number) [×] (base number [×] base number)
+input-ty : first-order ((list (base label [×] base number)) [×] (base number [×] base number))
+input-ty = μ (unit [+] ((base label [×] base number) [×] var Fin.zero)) [×] (base number [×] base number)
 
 -- Multiplication passes relative bounds through unchanged: a bound on price b reaches the output
 -- of total b intact.
@@ -34,7 +36,7 @@ test-cancel = refl
 
 -- The backward derivative of total b: the bound propagates to the selected quantity and its
 -- price, and nothing else is constrained.
-test-bwd : conjugate (ty (unit [×] input-ty) (_ , input)) (ty (base number) (+ 5 / 1))
+test-bwd : conjugate (ty₀ (unit [×] input-ty) (_ , input)) (ty₀ (base number) (+ 5 / 1))
              (mor (total b) (_ , input)) .func (fin (+ 1 / 10))
-           ≡ (lift · , ((lift · , ∞) , (lift · , fin (+ 1 / 10)) , (lift · , ∞) , lift ·) , (∞ , fin (+ 1 / 10)))
+           ≡ (lift · , ((lift · , ∞) , (lift · , fin (+ 1 / 10)) , (lift · , ∞) , _) , (∞ , fin (+ 1 / 10)))
 test-bwd = refl
diff --git a/agda/src/example/intervals-mult.agda b/agda/src/unused/example/intervals-mult.agda
similarity index 91%
rename from agda/src/example/intervals-mult.agda
rename to agda/src/unused/example/intervals-mult.agda
index de58eb01..d344dc33 100644
--- a/agda/src/example/intervals-mult.agda
+++ b/agda/src/unused/example/intervals-mult.agda
@@ -16,9 +16,11 @@ import semiring-Q-tropical-mult
 import indexed-family
 open import commutative-semiring using (CommutativeSemiring)
 
+open import Data.Nat using (ℕ)
 open import Level using (lift; 0ℓ) public
 open import Data.Unit renaming (tt to ·) using () public
 open import Data.Product using (_,_) public
+open import Data.Sum using (inj₁; inj₂) public
 open import Relation.Binary.PropositionalEquality using (_≡_; refl) public
 open import Relation.Nullary using (yes; no)
 open import Data.Integer using (+_; -[1+_]) public
@@ -29,7 +31,7 @@ open import Data.Integer.Base public using (nonNeg)
 open import Data.Rational.Properties using (∣-∣-nonNeg)
 open import prop-setoid using (Setoid)
 open Setoid using (Carrier) public
-open import example.signature ℚ using (Sig; number; label; approx) public
+open import example.signature ℚ using (Sig; number; label) public
 import example
 open import language-syntax Sig hiding (_,_) public
 module Ex = example ℚ 0ℚ
@@ -45,8 +47,11 @@ module SemiMod-Rel = semimodule semiring-Q-tropical-mult.semiring
 module Scalars = CommutativeSemiring semiring-Q-tropical-mult.semiring
 open cmon-enriched.CMonEnriched SemiMod-Rel.cmon-enriched using (_+m_)
 
+number-width : ℕ
+number-width = 1
+
 Approx : Category.obj SDSemiMod-Rel.cat
-Approx = SDSemiMod-Rel.𝕀
+Approx = SDSemiMod-Rel.S^ number-width
 
 approx-unit : Category._⇒_ SDSemiMod-Rel.cat (HasTerminal.witness SDSemiMod-Rel.terminal) Approx
 approx-unit = HasInitial.from-initial SDSemiMod-Rel.initial {Approx}
@@ -67,7 +72,7 @@ private
   num-mult .func-resp-≈ e = Num.·-cong (prop.proj₁ e) (prop.proj₂ e)
 
 open import example.signature-interpretation SDSemiMod-Rel.cat SDSemiMod-Rel.products SDSemiMod-Rel.terminal
-  Approx approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
+  SDSemiMod-Rel.S^_ (SDSemiMod-Rel.terminal .HasTerminal.is-terminal) number-width approx-unit approx-conjunct semiring-Q.setoid num-add num-mult
 
 private
   -- Multiplication by a scalar as a linear endomorphism of the scalars.
@@ -107,6 +112,9 @@ module D = BinDeriv add-c₁ add-c₂ mult-c mult-c add-c₁-cong add-c₂-cong
 open ho-model-sd-semimod.interp-sd semiring-Q-tropical-mult.semiring Sig D.BaseInterp1 public
 open SDSemiMod-Rel public using (conjugate)
 
+-- W-trees indexing the fibres of closed μ-types, for writing inputs.
+module T = Pm.Tree {n = 0} (λ ())
+
 open indexed-family._⇒f_ public
 open SemiMod-Rel._⇒_ public
 
diff --git a/agda/src/example/signature-interpretation.agda b/agda/src/unused/example/signature-interpretation.agda
similarity index 80%
rename from agda/src/example/signature-interpretation.agda
rename to agda/src/unused/example/signature-interpretation.agda
index 1961a8c3..f180ac99 100644
--- a/agda/src/example/signature-interpretation.agda
+++ b/agda/src/unused/example/signature-interpretation.agda
@@ -1,18 +1,25 @@
 {-# OPTIONS --postfix-projections --prop --safe #-}
 
 open import Level using (Level; 0ℓ; suc)
-open import categories using (Category; HasProducts; HasTerminal; HasCoproducts)
+open import categories using (Category; HasProducts; HasTerminal; HasCoproducts; IsTerminal)
 open import prop-setoid using (Setoid)
+open import Data.Nat using (ℕ)
 
 module example.signature-interpretation
   {o : Level}
   (𝒞 : Category o 0ℓ 0ℓ)
   (𝒞-products : HasProducts 𝒞)
   (𝒞-terminal : HasTerminal 𝒞)
-  -- the object approximating the `number` and `approx` sorts; unit and conjunct give it a monoid structure.
-  (Approx : Category.obj 𝒞)
-  (unit : Category._⇒_ 𝒞 (HasTerminal.witness 𝒞-terminal) Approx)
-  (conjunct : Category._⇒_ 𝒞 (HasProducts.prod 𝒞-products Approx Approx) Approx)
+  -- the approximation carried by a value, indexed by how many dimensions it has.
+  (approx : ℕ → Category.obj 𝒞)
+  -- no dimensions means no information, so the width-0 approximation is terminal.
+  (approx-0-terminal : IsTerminal 𝒞 (approx 0))
+  -- how many dimensions a `number` carries; unit and conjunct give its approximation
+  -- a monoid structure.
+  (number-width : ℕ)
+  (unit : Category._⇒_ 𝒞 (HasTerminal.witness 𝒞-terminal) (approx number-width))
+  (conjunct : Category._⇒_ 𝒞 (HasProducts.prod 𝒞-products (approx number-width) (approx number-width))
+                             (approx number-width))
   -- what a `number` carries, with add/mult on the index side.
   (Numₛ : Setoid 0ℓ 0ℓ)
   (num-add  : prop-setoid._⇒_ (prop-setoid.⊗-setoid Numₛ Numₛ) Numₛ)
@@ -21,6 +28,10 @@ module example.signature-interpretation
 
 import fam
 
+-- The 𝒞-object approximating a `number`, computed from its width.
+number-approx : Category.obj 𝒞
+number-approx = approx number-width
+
 private
   module 𝒞m = Category 𝒞
   𝟙-base = HasTerminal.witness 𝒞-terminal
@@ -116,21 +127,28 @@ private
 BaseInterp0 : Model PFPC[ cat , terminal , products , 𝟚 ] Sig
 BaseInterp0 .Model.⟦sort⟧ number = simple[ Numₛ , 𝟙-base ]
 BaseInterp0 .Model.⟦sort⟧ label = simple[ label.Label , 𝟙-base ]
-BaseInterp0 .Model.⟦sort⟧ approx = simple[ 𝟙ₛ , Approx ]
 BaseInterp0 .Model.⟦op⟧ (lit n) = simplef[ constₛ _ n , 𝒞m.id _ ]
 BaseInterp0 .Model.⟦op⟧ add = simplef[ num-add , to-𝟙-base ] C.∘ binary
 BaseInterp0 .Model.⟦op⟧ mult = simplef[ num-mult , to-𝟙-base ] C.∘ binary
 BaseInterp0 .Model.⟦op⟧ (lbl l) = simplef[ constₛ _ l , 𝒞m.id _ ]
 BaseInterp0 .Model.⟦rel⟧ equal-label = predicate label.equal-label C.∘ binary
-BaseInterp0 .Model.⟦op⟧ approx-unit = simplef[ idS _ , unit ]
-BaseInterp0 .Model.⟦op⟧ approx-mult = simplef[ prop-setoid.to-𝟙 , conjunct ] C.∘ binary
+
+-- The approximation attached to each sort in the value-carrying model, given by its width; the
+-- model's ⟦sort⟧ is the approximation of that width.
+sort-index : sort → Setoid 0ℓ 0ℓ
+sort-index number = Numₛ
+sort-index label  = label.Label
+
+sort-width : sort → ℕ
+sort-width number = number-width
+sort-width label  = 0
 
 -- The value-carrying model, parameterized by per-argument derivative coefficients for the binary
 -- arithmetic primitives: at run values (x, y), the derivative of an operation is c₁ x y on its
 -- first argument plus c₂ x y on its second. This is the only part of the interpretation that
 -- varies between the models.
 module BinDeriv
-  (add-c₁ add-c₂ mult-c₁ mult-c₂ : Setoid.Carrier Numₛ → Setoid.Carrier Numₛ → Category._⇒_ 𝒞 Approx Approx)
+  (add-c₁ add-c₂ mult-c₁ mult-c₂ : Setoid.Carrier Numₛ → Setoid.Carrier Numₛ → Category._⇒_ 𝒞 number-approx number-approx)
   (add-c₁-cong : ∀ {x x' y y'} → Setoid._≈_ Numₛ x x' → Setoid._≈_ Numₛ y y' → Category._≈_ 𝒞 (add-c₁ x y) (add-c₁ x' y'))
   (add-c₂-cong : ∀ {x x' y y'} → Setoid._≈_ Numₛ x x' → Setoid._≈_ Numₛ y y' → Category._≈_ 𝒞 (add-c₂ x y) (add-c₂ x' y'))
   (mult-c₁-cong : ∀ {x x' y y'} → Setoid._≈_ Numₛ x x' → Setoid._≈_ Numₛ y y' → Category._≈_ 𝒞 (mult-c₁ x y) (mult-c₁ x' y'))
@@ -139,10 +157,10 @@ module BinDeriv
 
   private
     op-deriv : (g : prop-setoid._⇒_ (prop-setoid.⊗-setoid Numₛ Numₛ) Numₛ)
-               (c₁ c₂ : Setoid.Carrier Numₛ → Setoid.Carrier Numₛ → Category._⇒_ 𝒞 Approx Approx)
+               (c₁ c₂ : Setoid.Carrier Numₛ → Setoid.Carrier Numₛ → Category._⇒_ 𝒞 number-approx number-approx)
                (c₁-cong : ∀ {x x' y y'} → Setoid._≈_ Numₛ x x' → Setoid._≈_ Numₛ y y' → Category._≈_ 𝒞 (c₁ x y) (c₁ x' y'))
                (c₂-cong : ∀ {x x' y y'} → Setoid._≈_ Numₛ x x' → Setoid._≈_ Numₛ y y' → Category._≈_ 𝒞 (c₂ x y) (c₂ x' y')) →
-               simple[ Numₛ ×ₛ Numₛ , CP.prod Approx Approx ] C.⇒ simple[ Numₛ , Approx ]
+               simple[ Numₛ ×ₛ Numₛ , CP.prod number-approx number-approx ] C.⇒ simple[ Numₛ , number-approx ]
     op-deriv g c₁ c₂ c₁-cong c₂-cong .idxf = g
     op-deriv g c₁ c₂ c₁-cong c₂-cong .famf .transf xy =
       conjunct 𝒞m.∘ CP.pair (c₁ (proj₁ xy) (proj₂ xy) 𝒞m.∘ CP.p₁) (c₂ (proj₁ xy) (proj₂ xy) 𝒞m.∘ CP.p₂)
@@ -153,32 +171,28 @@ module BinDeriv
                         (𝒞m.∘-cong (c₂-cong (num-sym (prop.proj₁ e)) (num-sym (prop.proj₂ e))) 𝒞m.≈-refl)))
         (𝒞m.≈-sym 𝒞m.id-left))
 
-  add-deriv : simple[ Numₛ ×ₛ Numₛ , CP.prod Approx Approx ] C.⇒ simple[ Numₛ , Approx ]
+  add-deriv : simple[ Numₛ ×ₛ Numₛ , CP.prod number-approx number-approx ] C.⇒ simple[ Numₛ , number-approx ]
   add-deriv = op-deriv num-add add-c₁ add-c₂ add-c₁-cong add-c₂-cong
 
-  mult-deriv : simple[ Numₛ ×ₛ Numₛ , CP.prod Approx Approx ] C.⇒ simple[ Numₛ , Approx ]
+  mult-deriv : simple[ Numₛ ×ₛ Numₛ , CP.prod number-approx number-approx ] C.⇒ simple[ Numₛ , number-approx ]
   mult-deriv = op-deriv num-mult mult-c₁ mult-c₂ mult-c₁-cong mult-c₂-cong
 
   BaseInterp1 : Model PFPC[ cat , terminal , products , 𝟚 ] Sig
-  BaseInterp1 .Model.⟦sort⟧ number = simple[ Numₛ , Approx ]
-  BaseInterp1 .Model.⟦sort⟧ label = simple[ label.Label , 𝟙-base ]
-  BaseInterp1 .Model.⟦sort⟧ approx = simple[ 𝟙ₛ , Approx ]
+  BaseInterp1 .Model.⟦sort⟧ s = simple[ sort-index s , approx (sort-width s) ]
   BaseInterp1 .Model.⟦op⟧ (lit n) = simplef[ constₛ _ n , unit ]
   BaseInterp1 .Model.⟦op⟧ add = add-deriv C.∘ binary
   BaseInterp1 .Model.⟦op⟧ mult = mult-deriv C.∘ binary
-  BaseInterp1 .Model.⟦op⟧ (lbl l) = simplef[ constₛ _ l , 𝒞m.id _ ]
+  BaseInterp1 .Model.⟦op⟧ (lbl l) = simplef[ constₛ _ l , IsTerminal.to-terminal approx-0-terminal ]
   BaseInterp1 .Model.⟦rel⟧ equal-label = predicate label.equal-label C.∘ binary
-  BaseInterp1 .Model.⟦op⟧ approx-unit = simplef[ idS _ , unit ]
-  BaseInterp1 .Model.⟦op⟧ approx-mult = simplef[ prop-setoid.to-𝟙 , conjunct ] C.∘ binary
 
 -- The special case with addition's coefficients the identity and multiplication's the Jacobian
 -- entries [ ∂/∂x , ∂/∂y ] = [ coeff y , coeff x ].
 module Deriv
-  (coeff : Setoid.Carrier Numₛ → Category._⇒_ 𝒞 Approx Approx)
+  (coeff : Setoid.Carrier Numₛ → Category._⇒_ 𝒞 number-approx number-approx)
   (coeff-cong : ∀ {x y} → Setoid._≈_ Numₛ x y → Category._≈_ 𝒞 (coeff x) (coeff y))
   where
 
-  open BinDeriv (λ _ _ → 𝒞m.id Approx) (λ _ _ → 𝒞m.id Approx)
+  open BinDeriv (λ _ _ → 𝒞m.id number-approx) (λ _ _ → 𝒞m.id number-approx)
                 (λ _ y → coeff y) (λ x _ → coeff x)
                 (λ _ _ → 𝒞m.≈-refl) (λ _ _ → 𝒞m.≈-refl)
                 (λ _ e₂ → coeff-cong e₂) (λ e₁ _ → coeff-cong e₁)
diff --git a/agda/src/example/signs-score.agda b/agda/src/unused/example/signs-score.agda
similarity index 89%
rename from agda/src/example/signs-score.agda
rename to agda/src/unused/example/signs-score.agda
index cbbfb440..3c4889a2 100644
--- a/agda/src/example/signs-score.agda
+++ b/agda/src/unused/example/signs-score.agda
@@ -12,11 +12,11 @@ open import example.signs
 --   1 2 1
 --   3 5 4
 --   1 7 1
-gval : ⟦ Grid ⟧ty .idx .Carrier
+gval : ⟦ Grid ⟧ty (λ ()) .idx .Carrier
 gval = (((+ 1 , + 2) , + 1) , ((+ 3 , + 5) , + 4)) , ((+ 1 , + 7) , + 1)
 
 -- Grid as first-order data (the Row/Grid synonyms are plain types, so spell it out here).
-grid-fo : first-order-data Grid
+grid-fo : first-order Grid
 grid-fo = (((base number [×] base number) [×] base number) [×] ((base number [×] base number) [×] base number))
             [×] ((base number [×] base number) [×] base number)
 
@@ -24,8 +24,8 @@ grid-fo = (((base number [×] base number) [×] base number) [×] ((base number
 -- raise it through their interaction, the centre is ambiguous (its linear and interaction
 -- contributions pull in opposite directions), and the bottom-middle cell is ignored.
 saliency :
-  conjugate (ty (unit [×] grid-fo) (_ , gval))
-            (ty (base number) (+ 3))
+  conjugate (ty₀ (unit [×] grid-fo) (_ , gval))
+            (ty₀ (base number) (+ 3))
             (mor (score -[1+ 0 ]) (_ , gval)) .func pos
   ≡ (lift · , ((((neg , neg) , neg) , ((pos , unk) , pos)) , ((neg , zer) , neg)))
 saliency = refl
diff --git a/agda/src/example/signs.agda b/agda/src/unused/example/signs.agda
similarity index 93%
rename from agda/src/example/signs.agda
rename to agda/src/unused/example/signs.agda
index 0dd87e9d..9d299b17 100644
--- a/agda/src/example/signs.agda
+++ b/agda/src/unused/example/signs.agda
@@ -15,6 +15,7 @@ import ho-model-sd-semimod
 import indexed-family
 import semiring-sign
 
+open import Data.Nat using (ℕ)
 open import Level using (lift; 0ℓ) public
 open import Data.Unit renaming (tt to ·) using () public
 open import Data.Product using (_,_) public
@@ -27,7 +28,7 @@ import Data.Integer
 open import prop-setoid using (Setoid; IsEquivalence)
 open Setoid using (Carrier) public
 open import commutative-semiring using (CommutativeSemiring)
-open import example.signature ℤ using (Sig; number; label; approx) public
+open import example.signature ℤ using (Sig; number; label) public
 import example
 open import language-syntax Sig hiding (_,_) public
 module Ex = example ℤ (+ 0)
@@ -40,8 +41,11 @@ module SemiMod-S = semimodule semiring-sign.semiring
 module Scalars = CommutativeSemiring semiring-sign.semiring
 open cmon-enriched.CMonEnriched SemiMod-S.cmon-enriched using (_+m_)
 
+number-width : ℕ
+number-width = 1
+
 Approx : Category.obj SDSemiMod-S.cat
-Approx = SDSemiMod-S.𝕀
+Approx = SDSemiMod-S.S^ number-width
 
 approx-unit : Category._⇒_ SDSemiMod-S.cat (HasTerminal.witness SDSemiMod-S.terminal) Approx
 approx-unit = HasInitial.from-initial SDSemiMod-S.initial {Approx}
@@ -97,7 +101,7 @@ private
   coeff-cong {x} (liftS refl) = Category.≈-refl SemiMod-S.cat {f = coeff x}
 
 open import example.signature-interpretation SDSemiMod-S.cat SDSemiMod-S.products SDSemiMod-S.terminal
-  Approx approx-unit approx-conjunct ℤ-setoid num-add num-mult public
+  SDSemiMod-S.S^_ (SDSemiMod-S.terminal .HasTerminal.is-terminal) number-width approx-unit approx-conjunct ℤ-setoid num-add num-mult public
 module D = Deriv coeff coeff-cong
 open ho-model-sd-semimod.interp-sd semiring-sign.semiring Sig D.BaseInterp1 public
 open SDSemiMod-S public using (conjugate)
diff --git a/agda/src/ho-model-boolalg-sd-semimod.agda b/agda/src/unused/ho-model-boolalg-sd-semimod.agda
similarity index 50%
rename from agda/src/ho-model-boolalg-sd-semimod.agda
rename to agda/src/unused/ho-model-boolalg-sd-semimod.agda
index cedf4286..8afb17cc 100644
--- a/agda/src/ho-model-boolalg-sd-semimod.agda
+++ b/agda/src/unused/ho-model-boolalg-sd-semimod.agda
@@ -6,10 +6,9 @@ open import Level using (0ℓ)
 open import prop-setoid using (Setoid)
 open import commutative-semiring using (CommutativeSemiring; BooleanAlgebra)
 open import signature using (Signature; Model; PFPC[_,_,_,_])
-open import Data.Product using (_,_)
-open import Data.Sum using (inj₁; inj₂)
-import nat
-import lists
+open import categories using (Category)
+open import Relation.Binary.PropositionalEquality using (refl)
+open import prop using (_,_)
 import language-syntax
 import semimodule
 import boolalg-sd-semimodule
@@ -24,41 +23,20 @@ open ho-model.Interpretation
   BoolAlg.cat BoolAlg.terminal BoolAlg.products
   SemiMod.cat SemiMod.cmon-enriched SemiMod.limits SemiMod.terminal SemiMod.biproduct
   BoolAlg.U BoolAlg.U-preserve-terminal (λ {X} {Y} → BoolAlg.U-preserve-products {X} {Y})
+  (λ e → e) (λ h _ → h , Category.≈-refl SemiMod.cat)
   public
 
--- Self-dual Boolean algebras on first-order-data types.
+-- Self-dual Boolean algebras on the first-order types of the language with
+-- general recursive types: instantiate the generic fibre-object machinery at
+-- the Boolean algebras.
 module interp-boolean (Sig : Signature 0ℓ)
-                      (Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig)
+                        (Impl : Model PFPC[ Fam⟨𝒞⟩.cat , Fam⟨𝒞⟩-terminal , Fam⟨𝒞⟩-products , Fam⟨𝒞⟩-bool ] Sig)
    where
 
   open interp Sig Impl public
-  open language-syntax Sig using (_⊢_; first-order-data; unit; bool; base; _[×]_; _[+]_; list)
+  open language-syntax Sig using (_⊢_)
   open BoolAlg using (SelfDualBooleanAlgebra; 𝟘; _⊕_; to-gal) public
   open Setoid using (Carrier)
-  open Fam⟨𝒞⟩ using (fm)
-  open Fam⟨𝒞⟩.Obj using (fam)
-  open Model Impl using (⟦sort⟧)
-  open lists Fam⟨𝒟⟩.cat Fam⟨𝒟⟩-terminal Fam⟨𝒟⟩-products Fam⟨𝒟⟩-exponentials Fam⟨𝒟⟩.bigCoproducts
-    using (_^_)
-
-  open FirstOrderConservativity
-    (λ {X} {Y} → BoolAlg.U-full {X} {Y})
-    (λ {X} {Y} {f} {g} → BoolAlg.U-faithful {X} {Y} {f} {g})
-    Sig Impl public
-
-  ty  : ∀ {τ} → first-order-data τ → (i : ⟦ τ ⟧ty .idx .Carrier) → SelfDualBooleanAlgebra
-  pow : ∀ {τ} → first-order-data τ → (n : nat.ℕ) → (i : (⟦ τ ⟧ty ^ n) .idx .Carrier) → SelfDualBooleanAlgebra
-
-  ty unit       _        = 𝟘
-  ty bool       _        = 𝟘
-  ty (base s)   i        = ⟦sort⟧ s .fam .fm i
-  ty (a [×] b)  (i , j)  = ty a i ⊕ ty b j
-  ty (a [+] b)  (inj₁ i) = ty a i
-  ty (a [+] b)  (inj₂ j) = ty b j
-  ty (list a)   (n , i)  = pow a n i
-
-  pow a nat.zero     _        = 𝟘
-  pow a (nat.succ n) (i , is) = ty a i ⊕ pow a n is
 
   open SemiMod._⇒_ using (func)
 
diff --git a/agda/src/unused/language-interpretation-slicing.agda b/agda/src/unused/language-interpretation-slicing.agda
new file mode 100644
index 00000000..1e7ba799
--- /dev/null
+++ b/agda/src/unused/language-interpretation-slicing.agda
@@ -0,0 +1,56 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+import Data.Fin as Fin
+open Fin using (Fin; splitAt)
+open import Data.Nat using (ℕ; zero; suc; _+_)
+open import Data.Sum using ([_,_])
+open import Level using (_⊔_)
+open import categories
+  using (Category; HasTerminal; HasProducts; HasCoproducts; HasStrongCoproducts;
+         strong-coproducts→coproducts; HasExponentials)
+open import functor using (Functor; StrongFunctor)
+open import signature using (Signature)
+import polynomial-functor
+import language-syntax
+
+module language-interpretation-slicing
+  {ℓ} (Sig : Signature ℓ)
+  {o m e}
+  (𝒞 : Category o m e)
+  (𝒞T : HasTerminal 𝒞) (𝒞P : HasProducts 𝒞) (𝒞SC : HasStrongCoproducts 𝒞 𝒞P)
+  (𝒞E : HasExponentials 𝒞 𝒞P)
+  (T  : StrongFunctor 𝒞P)
+  (let open polynomial-functor 𝒞T 𝒞P 𝒞SC T hiding (_+_; _×_))
+  (Mu : HasMu)
+  (⟦sort⟧ : Signature.sort Sig → Category.obj 𝒞)
+  where
+
+open Category 𝒞
+open HasTerminal 𝒞T renaming (witness to 𝟙)
+open HasProducts 𝒞P
+open HasCoproducts (strong-coproducts→coproducts 𝒞T 𝒞SC)
+open HasExponentials 𝒞E renaming (exp to _⟦→⟧_)
+open language-syntax Sig
+open HasMu Mu
+
+T-obj : obj → obj
+T-obj = Functor.fobj (StrongFunctor.F T)
+
+mutual
+  ⟦_⟧ty : ∀ {Δ} → type Δ → (Fin Δ → obj) → obj
+  ⟦ var i ⟧ty     δ = δ i
+  ⟦ unit ⟧ty      δ = T-obj 𝟙
+  ⟦ base s ⟧ty    δ = T-obj (⟦sort⟧ s)
+  ⟦ σ [+] τ ⟧ty δ = T-obj (coprod (⟦ σ ⟧ty δ) (⟦ τ ⟧ty δ))
+  ⟦ σ [×] τ ⟧ty δ = T-obj (prod   (⟦ σ ⟧ty δ) (⟦ τ ⟧ty δ))
+  ⟦ σ [→] τ ⟧ty δ = T-obj (⟦ σ ⟧ty (λ ()) ⟦→⟧ ⟦ τ ⟧ty (λ ()))
+  ⟦ μ τ ⟧ty     δ = μ-obj (as-poly τ δ) (λ ())
+
+  as-poly : ∀ {Δ n} → type (n + Δ) → (Fin Δ → obj) → Poly n
+  as-poly {Δ} {n} (var i) δ = [ Poly.var , (λ j → Poly.const (δ j)) ] (splitAt n i)
+  as-poly unit       δ = Poly.T∘ Poly.const 𝟙
+  as-poly (base s)   δ = Poly.T∘ Poly.const (⟦sort⟧ s)
+  as-poly (σ [+] τ)  δ = Poly.T∘ (as-poly σ δ Poly.+ as-poly τ δ)
+  as-poly (σ [×] τ)  δ = Poly.T∘ (as-poly σ δ Poly.× as-poly τ δ)
+  as-poly (σ [→] τ)  δ = Poly.T∘ Poly.const (⟦ σ ⟧ty (λ ()) ⟦→⟧ ⟦ τ ⟧ty (λ ()))
+  as-poly (μ τ)      δ = Poly.μ (as-poly τ δ)
diff --git a/agda/src/unused/omega-chains.agda b/agda/src/unused/omega-chains.agda
new file mode 100644
index 00000000..bd454453
--- /dev/null
+++ b/agda/src/unused/omega-chains.agda
@@ -0,0 +1,312 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- The shape category ω = (ℕ, ≤): diagrams over it are ω-chains, whose colimits underlie the
+-- initial-algebra construction for polynomial functors. A chain is most conveniently given by its
+-- step maps; `chain` packages these as a functor out of ω.
+
+open import Level using (0ℓ; _⊔_)
+open import Data.Nat using (ℕ; suc; _≤′_; ≤′-refl; ≤′-step)
+open import Data.Nat.Properties using (≤′-trans; ≤′⇒≤; 1+n≰n; z≤′n)
+open import prop using (⊤; tt)
+open import prop-setoid using (⊤-isEquivalence; module ≈-Reasoning)
+open import categories using (Category)
+import functor
+open functor using (Functor; NatTrans; ≃-NatTrans; Colimit; IsColimit; constF; constFmor; colambda-unique) renaming (_∘_ to _∘NT_)
+open IsColimit
+open Colimit
+
+module omega-chains where
+
+ω : Category 0ℓ 0ℓ 0ℓ
+ω .Category.obj = ℕ
+ω .Category._⇒_ m n = m ≤′ n
+ω .Category._≈_ _ _ = ⊤
+ω .Category.isEquiv = ⊤-isEquivalence
+ω .Category.id n = ≤′-refl
+ω .Category._∘_ f g = ≤′-trans g f
+ω .Category.∘-cong _ _ = tt
+ω .Category.id-left = tt
+ω .Category.id-right = tt
+ω .Category.assoc _ _ _ = tt
+
+module _ {o m e} {𝒞 : Category o m e} where
+  open Category 𝒞
+
+  module _ (X : ℕ → obj) (f : ∀ n → X n ⇒ X (suc n)) where
+    private
+      walk : ∀ {m n} → m ≤′ n → X m ⇒ X n
+      walk ≤′-refl     = id _
+      walk (≤′-step p) = f _ ∘ walk p
+
+      -- Any two parallel walks agree: ≤′ is propositional, up to the absurd mixed cases.
+      walk-cong : ∀ {m n} (p q : m ≤′ n) → walk p ≈ walk q
+      walk-cong ≤′-refl     ≤′-refl     = ≈-refl
+      walk-cong ≤′-refl     (≤′-step q) with () ← 1+n≰n (≤′⇒≤ q)
+      walk-cong (≤′-step p) ≤′-refl     with () ← 1+n≰n (≤′⇒≤ p)
+      walk-cong (≤′-step p) (≤′-step q) = ∘-cong₂ (walk-cong p q)
+
+      walk-comp : ∀ {x y z} (p : y ≤′ z) (q : x ≤′ y) → walk (≤′-trans q p) ≈ (walk p ∘ walk q)
+      walk-comp ≤′-refl     q = ≈-sym id-left
+      walk-comp (≤′-step p) q = ≈-trans (∘-cong₂ (walk-comp p q)) (≈-sym (assoc _ _ _))
+
+    chain : Functor ω 𝒞
+    chain .Functor.fobj = X
+    chain .Functor.fmor = walk
+    chain .Functor.fmor-cong {_} {_} {p} {q} _ = walk-cong p q
+    chain .Functor.fmor-id = ≈-refl
+    chain .Functor.fmor-comp = walk-comp
+
+  -- A cocone over a chain, from legs commuting with single steps.
+  module _ {X : ℕ → obj} {f : ∀ n → X n ⇒ X (suc n)} {a : obj}
+           (legs : ∀ n → X n ⇒ a) (legs-step : ∀ n → legs n ≈ (legs (suc n) ∘ f n)) where
+
+    open NatTrans
+
+    step-cocone : NatTrans (chain X f) (constF ω a)
+    step-cocone .transf = legs
+    step-cocone .natural p = nat p
+      where
+        nat : ∀ {k n} (p : k ≤′ n) → (id a ∘ legs k) ≈ (legs n ∘ chain X f .Functor.fmor p)
+        nat ≤′-refl     = id-swap
+        nat (≤′-step p) = ≈-trans (nat p) (≈-trans (∘-cong₁ (legs-step _)) (assoc _ _ _))
+
+  -- Conversely, any cocone commutes with single steps.
+  cocone-step : ∀ {X : ℕ → obj} {f : ∀ n → X n ⇒ X (suc n)} {a : obj}
+                (c : NatTrans (chain X f) (constF ω a)) →
+                ∀ n → c .NatTrans.transf n ≈ (c .NatTrans.transf (suc n) ∘ f n)
+  cocone-step c n =
+    ≈-trans (≈-sym id-left)
+    (≈-trans (c .NatTrans.natural (≤′-step ≤′-refl)) (∘-cong₂ id-right))
+
+  -- A constant chain has its value as a colimit.
+  module _ (A : obj) where
+    private
+      walk-id : ∀ {m n} (p : m ≤′ n) → chain (λ _ → A) (λ _ → id A) .Functor.fmor p ≈ id A
+      walk-id ≤′-refl     = ≈-refl
+      walk-id (≤′-step p) = ≈-trans id-left (walk-id p)
+
+    open NatTrans
+
+    const-chain-colimit : Colimit (chain (λ _ → A) (λ _ → id A))
+    const-chain-colimit .apex = A
+    const-chain-colimit .cocone .transf n = id A
+    const-chain-colimit .cocone .natural p =
+      ≈-trans id-left (≈-trans (≈-sym (walk-id p)) (≈-sym id-left))
+    const-chain-colimit .isColimit .colambda x β = β .transf 0
+    const-chain-colimit .isColimit .colambda-cong β≃γ = β≃γ .≃-NatTrans.transf-eq 0
+    const-chain-colimit .isColimit .colambda-coeval x β .≃-NatTrans.transf-eq n =
+      ≈-trans id-right
+      (≈-trans (≈-sym id-left)
+      (≈-trans (β .natural (z≤′n {n}))
+      (≈-trans (∘-cong₂ (walk-id (z≤′n {n}))) id-right)))
+    const-chain-colimit .isColimit .colambda-ext x f = id-right
+
+  -- Stage maps commuting with the steps induce a natural transformation between chains, and a
+  -- mediating morphism between their colimits.
+  module _ {X Y : ℕ → obj} (f : ∀ n → X n ⇒ X (suc n)) (g : ∀ n → Y n ⇒ Y (suc n))
+           (h : ∀ n → X n ⇒ Y n)
+           (h-step : ∀ n → (h (suc n) ∘ f n) ≈ (g n ∘ h n)) where
+
+    open NatTrans
+
+    chain-map : NatTrans (chain X f) (chain Y g)
+    chain-map .transf = h
+    chain-map .natural p = square p
+      where
+        square : ∀ {k n} (p : k ≤′ n) → (chain Y g .Functor.fmor p ∘ h k) ≈ (h n ∘ chain X f .Functor.fmor p)
+        square ≤′-refl     = id-swap
+        square (≤′-step p) =
+          ≈-trans (assoc _ _ _)
+          (≈-trans (∘-cong₂ (square p))
+          (≈-trans (≈-sym (assoc _ _ _))
+          (≈-trans (∘-cong₁ (≈-sym (h-step _))) (assoc _ _ _))))
+
+    colim-map : (CX : Colimit (chain X f)) (CY : Colimit (chain Y g)) → CX .apex ⇒ CY .apex
+    colim-map CX CY = CX .colambda _ (CY .cocone ∘NT chain-map)
+
+  -- The mediating morphism respects pointwise-equal stage maps (and so is independent of the squares).
+  colim-map-cong : ∀ {X Y : ℕ → obj} {f : ∀ n → X n ⇒ X (suc n)} {g : ∀ n → Y n ⇒ Y (suc n)}
+                   {h h' : ∀ n → X n ⇒ Y n}
+                   {h-step : ∀ n → (h (suc n) ∘ f n) ≈ (g n ∘ h n)}
+                   {h'-step : ∀ n → (h' (suc n) ∘ f n) ≈ (g n ∘ h' n)} →
+                   (∀ n → h n ≈ h' n) → ∀ CX CY →
+                   colim-map f g h h-step CX CY ≈ colim-map f g h' h'-step CX CY
+  colim-map-cong h≈h' CX CY =
+    CX .colambda-cong (record { transf-eq = λ n → ∘-cong₂ (h≈h' n) })
+
+  -- Identity stage maps mediate to the identity.
+  colim-map-id : ∀ {X : ℕ → obj} {f : ∀ n → X n ⇒ X (suc n)}
+                 {id-step : ∀ n → ((id (X (suc n))) ∘ f n) ≈ (f n ∘ id (X n))} →
+                 ∀ CX → colim-map f f (λ n → id (X n)) id-step CX CX ≈ id (CX .apex)
+  colim-map-id CX =
+    ≈-trans (CX .colambda-cong (record { transf-eq = λ n → id-swap' }))
+            (CX .colambda-ext _ (id _))
+
+  -- Composite stage maps satisfy the composite square.
+  square-comp : ∀ {X Y Z : ℕ → obj}
+                {f : ∀ n → X n ⇒ X (suc n)} {g : ∀ n → Y n ⇒ Y (suc n)} {e : ∀ n → Z n ⇒ Z (suc n)}
+                {h : ∀ n → X n ⇒ Y n} {k : ∀ n → Y n ⇒ Z n} →
+                (∀ n → (h (suc n) ∘ f n) ≈ (g n ∘ h n)) →
+                (∀ n → (k (suc n) ∘ g n) ≈ (e n ∘ k n)) →
+                ∀ n → ((k (suc n) ∘ h (suc n)) ∘ f n) ≈ (e n ∘ (k n ∘ h n))
+  square-comp h-step k-step n =
+    ≈-trans (assoc _ _ _)
+    (≈-trans (∘-cong₂ (h-step n))
+    (≈-trans (≈-sym (assoc _ _ _))
+    (≈-trans (∘-cong₁ (k-step n)) (assoc _ _ _))))
+
+  -- Mediating morphisms compose.
+  colim-map-comp : ∀ {X Y Z : ℕ → obj}
+                   {f : ∀ n → X n ⇒ X (suc n)} {g : ∀ n → Y n ⇒ Y (suc n)} {e : ∀ n → Z n ⇒ Z (suc n)}
+                   {h : ∀ n → X n ⇒ Y n} {k : ∀ n → Y n ⇒ Z n}
+                   {h-step : ∀ n → (h (suc n) ∘ f n) ≈ (g n ∘ h n)}
+                   {k-step : ∀ n → (k (suc n) ∘ g n) ≈ (e n ∘ k n)}
+                   {kh-step : ∀ n → ((k (suc n) ∘ h (suc n)) ∘ f n) ≈ (e n ∘ (k n ∘ h n))} →
+                   ∀ CX CY CZ →
+                   colim-map f e (λ n → k n ∘ h n) kh-step CX CZ
+                     ≈ (colim-map g e k k-step CY CZ ∘ colim-map f g h h-step CX CY)
+  colim-map-comp {f = f} {g} {e} {h} {k} {h-step} {k-step} {kh-step} CX CY CZ =
+    ≈-trans (CX .colambda-cong E) (CX .colambda-ext _ _)
+    where
+      open NatTrans
+
+      E : ≃-NatTrans (CZ .cocone ∘NT chain-map f e (λ n → k n ∘ h n) kh-step)
+                     (constFmor (colim-map g e k k-step CY CZ ∘ colim-map f g h h-step CX CY) ∘NT CX .cocone)
+      E .≃-NatTrans.transf-eq n = begin
+          CZ .cocone .transf n ∘ (k n ∘ h n)
+        ≈˘⟨ assoc _ _ _ ⟩
+          (CZ .cocone .transf n ∘ k n) ∘ h n
+        ≈˘⟨ ∘-cong₁ (CY .colambda-coeval _ _ .≃-NatTrans.transf-eq n) ⟩
+          (colim-map g e k k-step CY CZ ∘ CY .cocone .transf n) ∘ h n
+        ≈⟨ assoc _ _ _ ⟩
+          colim-map g e k k-step CY CZ ∘ (CY .cocone .transf n ∘ h n)
+        ≈˘⟨ ∘-cong₂ (CX .colambda-coeval _ _ .≃-NatTrans.transf-eq n) ⟩
+          colim-map g e k k-step CY CZ ∘ (colim-map f g h h-step CX CY ∘ CX .cocone .transf n)
+        ≈˘⟨ assoc _ _ _ ⟩
+          (colim-map g e k k-step CY CZ ∘ colim-map f g h h-step CX CY) ∘ CX .cocone .transf n
+        ∎
+        where open ≈-Reasoning isEquiv
+
+-- Interchange of colimits for a commuting ω×ω grid: given colimits of the rows, colimits of the
+-- columns onto a chain of column apexes, and a colimit of that chain, the latter is also a colimit
+-- of the chain of row apexes.
+module interchange {o m e} {𝒞 : Category o m e}
+  (let open Category 𝒞)
+  (G : ℕ → ℕ → obj)
+  (v : ∀ k j → G k j ⇒ G k (suc j))            -- steps within row k
+  (h : ∀ k j → G k j ⇒ G (suc k) j)            -- steps between rows
+  (sq : ∀ k j → (h k (suc j) ∘ v k j) ≈ (v (suc k) j ∘ h k j))
+  (R : ∀ k → Colimit (chain {𝒞 = 𝒞} (G k) (v k)))
+  (γ : ℕ → obj) (w : ∀ j → γ j ⇒ γ (suc j))    -- the chain of column apexes
+  (ℓ : ∀ k j → G k j ⇒ γ j)                    -- column cocone legs
+  (ℓ-step : ∀ k j → ℓ k j ≈ (ℓ (suc k) j ∘ h k j))
+  (ℓ-v : ∀ k j → (w j ∘ ℓ k j) ≈ (ℓ k (suc j) ∘ v k j))
+  (CL : ∀ j → IsColimit (chain {𝒞 = 𝒞} (λ k → G k j) (λ k → h k j)) (γ j)
+                        (step-cocone (λ k → ℓ k j) (λ k → ℓ-step k j)))
+  (CΓ : Colimit (chain {𝒞 = 𝒞} γ w))
+  where
+
+  open NatTrans
+
+  -- The chain of row apexes, with the mediated steps.
+  ρ : ℕ → obj
+  ρ k = R k .apex
+
+  ρ-step : ∀ k → ρ k ⇒ ρ (suc k)
+  ρ-step k = colim-map (v k) (v (suc k)) (h k) (sq k) (R k) (R (suc k))
+
+  -- Each row maps into the apex of the column chain, mediated row by row.
+  row-legs : ∀ k j → G k j ⇒ CΓ .apex
+  row-legs k j = CΓ .cocone .transf j ∘ ℓ k j
+
+  row-legs-step : ∀ k j → row-legs k j ≈ (row-legs k (suc j) ∘ v k j)
+  row-legs-step k j =
+    ≈-trans (∘-cong₁ (cocone-step (CΓ .cocone) j))
+    (≈-trans (assoc _ _ _)
+    (≈-trans (∘-cong₂ (ℓ-v k j)) (≈-sym (assoc _ _ _))))
+
+  ρ-inj : ∀ k → ρ k ⇒ CΓ .apex
+  ρ-inj k = R k .colambda _ (step-cocone (row-legs k) (row-legs-step k))
+
+  ρ-inj-step : ∀ k → ρ-inj k ≈ (ρ-inj (suc k) ∘ ρ-step k)
+  ρ-inj-step k = ≈-sym (colambda-unique (R k .isColimit) pointwise)
+    where
+      pointwise : ∀ j → ((ρ-inj (suc k) ∘ ρ-step k) ∘ R k .cocone .transf j)
+                      ≈ (ρ-inj k ∘ R k .cocone .transf j)
+      pointwise j =
+        ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (R k .colambda-coeval _ _ .≃-NatTrans.transf-eq j))
+        (≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong₁ (R (suc k) .colambda-coeval _ _ .≃-NatTrans.transf-eq j))
+        (≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (≈-sym (ℓ-step k j)))
+                 (≈-sym (R k .colambda-coeval _ _ .≃-NatTrans.transf-eq j)))))))
+
+  -- Mediation: a cocone over the row-apex chain mediates column-wise, then along the column-apex
+  -- chain.
+  private
+    module _ {x : obj} (β : NatTrans (chain {𝒞 = 𝒞} ρ ρ-step) (constF ω x)) where
+
+      col-legs : ∀ j k → G k j ⇒ x
+      col-legs j k = β .transf k ∘ R k .cocone .transf j
+
+      col-legs-step : ∀ j k → col-legs j k ≈ (col-legs j (suc k) ∘ h k j)
+      col-legs-step j k =
+        ≈-trans (∘-cong₁ (cocone-step β k))
+        (≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (R k .colambda-coeval _ _ .≃-NatTrans.transf-eq j))
+                 (≈-sym (assoc _ _ _))))
+
+      col-mediate : ∀ j → γ j ⇒ x
+      col-mediate j = CL j .colambda x (step-cocone (col-legs j) (col-legs-step j))
+
+      col-mediate-step : ∀ j → col-mediate j ≈ (col-mediate (suc j) ∘ w j)
+      col-mediate-step j = colambda-unique (CL j) pointwise
+        where
+          pointwise : ∀ k → (col-mediate j ∘ ℓ k j) ≈ ((col-mediate (suc j) ∘ w j) ∘ ℓ k j)
+          pointwise k =
+            ≈-trans (CL j .colambda-coeval _ _ .≃-NatTrans.transf-eq k)
+            (≈-sym
+              (≈-trans (assoc _ _ _)
+              (≈-trans (∘-cong₂ (ℓ-v k j))
+              (≈-trans (≈-sym (assoc _ _ _))
+              (≈-trans (∘-cong₁ (CL (suc j) .colambda-coeval _ _ .≃-NatTrans.transf-eq k))
+              (≈-trans (assoc _ _ _)
+                       (∘-cong₂ (≈-sym (cocone-step (R k .cocone) j)))))))))
+
+      mediate : CΓ .apex ⇒ x
+      mediate = CΓ .colambda x (step-cocone col-mediate col-mediate-step)
+
+  is-colimit : IsColimit (chain {𝒞 = 𝒞} ρ ρ-step) (CΓ .apex) (step-cocone ρ-inj ρ-inj-step)
+  is-colimit .colambda x β = mediate β
+  is-colimit .colambda-cong β≃β' =
+    CΓ .colambda-cong (record { transf-eq = λ j →
+      CL j .colambda-cong (record { transf-eq = λ k →
+        ∘-cong₁ (β≃β' .≃-NatTrans.transf-eq k) }) })
+  is-colimit .colambda-coeval x β .≃-NatTrans.transf-eq k =
+    colambda-unique (R k .isColimit) pointwise
+    where
+      pointwise : ∀ j → ((mediate β ∘ ρ-inj k) ∘ R k .cocone .transf j)
+                      ≈ (β .transf k ∘ R k .cocone .transf j)
+      pointwise j =
+        ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (R k .colambda-coeval _ _ .≃-NatTrans.transf-eq j))
+        (≈-trans (≈-sym (assoc _ _ _))
+        (≈-trans (∘-cong₁ (CΓ .colambda-coeval _ _ .≃-NatTrans.transf-eq j))
+                 (CL j .colambda-coeval _ _ .≃-NatTrans.transf-eq k))))
+  is-colimit .colambda-ext x f =
+    colambda-unique (CΓ .isColimit) pointwise
+    where
+      βf = constFmor f ∘NT step-cocone ρ-inj ρ-inj-step
+
+      pointwise : ∀ j → (mediate βf ∘ CΓ .cocone .transf j) ≈ (f ∘ CΓ .cocone .transf j)
+      pointwise j =
+        ≈-trans (CΓ .colambda-coeval _ _ .≃-NatTrans.transf-eq j)
+                (colambda-unique (CL j) inner)
+        where
+          inner : ∀ k → (col-mediate βf j ∘ ℓ k j) ≈ ((f ∘ CΓ .cocone .transf j) ∘ ℓ k j)
+          inner k =
+            ≈-trans (CL j .colambda-coeval _ _ .≃-NatTrans.transf-eq k)
+            (≈-trans (assoc _ _ _)
+            (≈-trans (∘-cong₂ (R k .colambda-coeval _ _ .≃-NatTrans.transf-eq j))
+                     (≈-sym (assoc _ _ _))))
diff --git a/agda/src/unused/setoid-cat-colimits.agda b/agda/src/unused/setoid-cat-colimits.agda
new file mode 100644
index 00000000..d3650b59
--- /dev/null
+++ b/agda/src/unused/setoid-cat-colimits.agda
@@ -0,0 +1,319 @@
+{-# OPTIONS --prop --postfix-projections --safe #-}
+
+-- The cocompleteness structure of SetoidCat: initial object, strong coproducts, ω-colimits, and
+-- cocontinuous products. This is the standalone half of the factorisation — instantiating colimit-mu-types
+-- against it builds μ-types of polynomial functors on setoids (the index μ-types of the Fam construction).
+
+open import Level using (_⊔_; lift)
+open import Data.Nat using (ℕ; suc; _≤′_; ≤′-refl; ≤′-step) renaming (_⊔_ to _⊔ℕ_)
+open import Data.Nat.Properties using (m≤m⊔n; m≤n⊔m; ≤⇒≤′; ≤′⇒≤; ⊔-monoˡ-≤; ⊔-monoʳ-≤)
+open import Data.Product using (_,_; Σ)
+open import Data.Sum using (inj₁; inj₂)
+open import prop using (_,_; ∃; liftS; tt; proj₁; proj₂)
+open import categories
+  using (Category; HasInitial; IsInitial; HasProducts; HasStrongCoproducts)
+open import functor
+  using (Functor; NatTrans; Colimit; IsColimit; constF; constFmor; ≃-NatTrans; HasColimits; colambda-unique)
+  renaming (_∘_ to _∘NT_)
+open import omega-chains using (ω; chain; step-cocone; cocone-step)
+open import prop-setoid
+  using (Setoid; IsEquivalence; 𝟘; from-𝟘; from-𝟘-unique; +-setoid; ⊗-setoid; case; inject₁; inject₂;
+         rel→Setoid; EquivOf-intro; rel-preserving-func; elim-EquivOfS)
+  renaming (_⇒_ to _⇒s_; _≃m_ to _≈s_)
+open import setoid-cat using (SetoidCat; Setoid-products)
+
+open Setoid
+open IsEquivalence
+open _⇒s_
+open _≈s_
+
+module setoid-cat-colimits where
+
+-- Work in SetoidCat o (o ⊔ e): the colimit's generated equality lands at level o ⊔ e, so the apex only fits
+-- when the equality level absorbs the carrier level. The Fam index setoids (Setoid os (os ⊔ es)) are of this form.
+module _ o e where
+  private
+    𝒮 = SetoidCat o (o ⊔ e)
+  open Category 𝒮
+  open HasInitial
+  open IsInitial
+  open HasStrongCoproducts
+
+  initial : HasInitial 𝒮
+  initial .witness = 𝟘
+  initial .is-initial .from-initial = from-𝟘
+  initial .is-initial .from-initial-ext f = from-𝟘-unique from-𝟘 f
+
+  strongCoproducts : HasStrongCoproducts 𝒮 (Setoid-products o (o ⊔ e))
+  strongCoproducts .coprod = +-setoid
+  strongCoproducts .in₁ = inject₁
+  strongCoproducts .in₂ = inject₂
+  strongCoproducts .copair = case
+  strongCoproducts .copair-cong f₁≈f₂ g₁≈g₂ .func-eq {_ , inj₁ _} {_ , inj₁ _} (w≈ , x≈) = f₁≈f₂ .func-eq (w≈ , x≈)
+  strongCoproducts .copair-cong f₁≈f₂ g₁≈g₂ .func-eq {_ , inj₂ _} {_ , inj₂ _} (w≈ , y≈) = g₁≈g₂ .func-eq (w≈ , y≈)
+  strongCoproducts .copair-in₁ f g .func-eq (w≈ , x≈) = f .func-resp-≈ (w≈ , x≈)
+  strongCoproducts .copair-in₂ f g .func-eq (w≈ , y≈) = g .func-resp-≈ (w≈ , y≈)
+  strongCoproducts .copair-ext h .func-eq {_ , inj₁ _} {_ , inj₁ _} (w≈ , x≈) = h .func-resp-≈ (w≈ , x≈)
+  strongCoproducts .copair-ext h .func-eq {_ , inj₂ _} {_ , inj₂ _} (w≈ , y≈) = h .func-resp-≈ (w≈ , y≈)
+
+  -- Sequential colimit of a setoid ω-chain: pairs (n , x) with x in the n-th setoid, under the equivalence
+  -- generated by identifying x with its image one (or more) steps up the chain.
+  ωcolimits : HasColimits ω 𝒮
+  ωcolimits D = colim
+    where
+    module D = Functor D
+
+    A : Set o
+    A = Σ ℕ (λ n → D.fobj n .Carrier)
+
+    R : A → A → Prop (o ⊔ e)
+    R (n , x) (m , y) = ∃ (n ≤′ m) (λ p → D.fobj m ._≈_ (D.fmor p .func x) y)
+
+    apex : Setoid o (o ⊔ e)
+    apex = rel→Setoid A R
+
+    cocone : NatTrans D (constF ω apex)
+    cocone .NatTrans.transf n .func x = n , x
+    cocone .NatTrans.transf n .func-resp-≈ x≈ = EquivOf-intro (≤′-refl , D.fmor-id .func-eq x≈)
+    cocone .NatTrans.natural p .func-eq a≈ = EquivOf-intro (p , D.fmor p .func-resp-≈ a≈)
+
+    mediate : (X' : Setoid o (o ⊔ e)) → NatTrans D (constF ω X') → apex ⇒s X'
+    mediate X' γ = rel-preserving-func X' f base
+      where
+      f : A → X' .Carrier
+      f (n , a) = γ .NatTrans.transf n .func a
+
+      base : ∀ {u v} → R u v → X' ._≈_ (f u) (f v)
+      base {n , a} {m , b} (p , da≈b) =
+        X' .isEquivalence .trans
+          (γ .NatTrans.natural p .func-eq (D.fobj n .isEquivalence .refl))
+          (γ .NatTrans.transf m .func-resp-≈ da≈b)
+
+    colim : Colimit D
+    colim .Colimit.apex = apex
+    colim .Colimit.cocone = cocone
+    colim .Colimit.isColimit .IsColimit.colambda = mediate
+    colim .Colimit.isColimit .IsColimit.colambda-cong {X'} {α} α≈β .func-eq {n , a} {m , b} u≈v =
+      X' .isEquivalence .trans
+        (mediate X' α .func-resp-≈ u≈v)
+        (α≈β .≃-NatTrans.transf-eq m .func-eq (D.fobj m .isEquivalence .refl))
+    colim .Colimit.isColimit .IsColimit.colambda-coeval X' γ .≃-NatTrans.transf-eq n .func-eq a≈ =
+      γ .NatTrans.transf n .func-resp-≈ a≈
+    colim .Colimit.isColimit .IsColimit.colambda-ext X' f .func-eq {n , a} u≈v = f .func-resp-≈ u≈v
+
+  open HasProducts (Setoid-products o (o ⊔ e)) using (prod; prod-m; prod-m-cong; prod-m-comp; prod-m-id)
+  open NatTrans using (transf)
+
+  -- Finite products preserve ω-colimits: the product of two colimits is the colimit of the product chain.
+  module _ {X Y : ℕ → obj} {f : ∀ k → X k ⇒ X (suc k)} {g : ∀ k → Y k ⇒ Y (suc k)} {a b : obj}
+           {cX : NatTrans (chain {𝒞 = 𝒮} X f) (constF ω a)} {cY : NatTrans (chain {𝒞 = 𝒮} Y g) (constF ω b)}
+           (isX : IsColimit (chain {𝒞 = 𝒮} X f) a cX) (isY : IsColimit (chain {𝒞 = 𝒮} Y g) b cY) where
+    private
+      Xc  = chain {𝒞 = 𝒮} X f
+      Yc  = chain {𝒞 = 𝒮} Y g
+      PXY = chain {𝒞 = 𝒮} (λ k → prod (X k) (Y k)) (λ k → prod-m (f k) (g k))
+
+      CXY : Colimit PXY
+      CXY = ωcolimits PXY
+
+      canonX = ωcolimits Xc
+      canonY = ωcolimits Yc
+
+      ιX : a ⇒s canonX .Colimit.apex
+      ιX = isX .IsColimit.colambda (canonX .Colimit.apex) (canonX .Colimit.cocone)
+
+      ιY : b ⇒s canonY .Colimit.apex
+      ιY = isY .IsColimit.colambda (canonY .Colimit.apex) (canonY .Colimit.cocone)
+
+      cocone₀ : NatTrans PXY (constF ω (prod a b))
+      cocone₀ = step-cocone (λ k → prod-m (cX .transf k) (cY .transf k))
+                            (λ k → ≈-trans (prod-m-cong (cocone-step cX k) (cocone-step cY k))
+                                           (prod-m-comp (cX .transf (suc k)) (cY .transf (suc k)) (f k) (g k)))
+
+      -- Two walks with the same endpoints agree; `varying` additionally absorbs a single-step shift of
+      -- the source through the chain.
+      module walks (D : Functor ω 𝒮) where
+        private
+          module D = Functor D
+
+        fixed : ∀ {k M N} (low : k ≤′ M) (mid : M ≤′ N) (hi : k ≤′ N) (a : D.fobj k .Carrier) →
+                D.fobj N ._≈_ (D.fmor mid .func (D.fmor low .func a)) (D.fmor hi .func a)
+        fixed low mid hi a =
+          D.fobj _ .isEquivalence .trans
+            (D.fobj _ .isEquivalence .sym (D.fmor-comp mid low .func-eq (D.fobj _ .isEquivalence .refl)))
+            (D.fmor-cong tt .func-eq (D.fobj _ .isEquivalence .refl))
+
+        varying : ∀ {k k' M N} (p : k ≤′ k') (low : k ≤′ M) (mid : M ≤′ N) (hi : k' ≤′ N)
+                  {a : D.fobj k .Carrier} {a' : D.fobj k' .Carrier} →
+                  D.fobj k' ._≈_ (D.fmor p .func a) a' →
+                  D.fobj N ._≈_ (D.fmor mid .func (D.fmor low .func a)) (D.fmor hi .func a')
+        varying p low mid hi wa =
+          D.fobj _ .isEquivalence .trans
+            (D.fobj _ .isEquivalence .sym (D.fmor-comp mid low .func-eq (D.fobj _ .isEquivalence .refl)))
+          (D.fobj _ .isEquivalence .trans
+            (D.fmor-cong tt .func-eq (D.fobj _ .isEquivalence .refl))
+          (D.fobj _ .isEquivalence .trans
+            (D.fmor-comp hi p .func-eq (D.fobj _ .isEquivalence .refl))
+            (D.fmor hi .func-resp-≈ wa)))
+
+      module wX = walks Xc
+      module wY = walks Yc
+
+      -- The product chain's transport is the pairing of the component transports.
+      prod-walk : ∀ {m n} (qw : m ≤′ n) (a : X m .Carrier) (b : Y m .Carrier) →
+                  prod (X n) (Y n) ._≈_ (PXY .Functor.fmor qw .func (a , b))
+                                         (Xc .Functor.fmor qw .func a , Yc .Functor.fmor qw .func b)
+      prod-walk ≤′-refl      a b = prod (X _) (Y _) .isEquivalence .refl
+      prod-walk (≤′-step qw) a b .proj₁ = f _ .func-resp-≈ (prod-walk qw a b .proj₁)
+      prod-walk (≤′-step qw) a b .proj₂ = g _ .func-resp-≈ (prod-walk qw a b .proj₂)
+
+      κ-fwd : prod (canonX .Colimit.apex) (canonY .Colimit.apex) ⇒s CXY .Colimit.apex
+      κ-fwd .func ((k , x) , (j , y)) =
+        _ , (Xc .Functor.fmor (≤⇒≤′ (m≤m⊔n k j)) .func x , Yc .Functor.fmor (≤⇒≤′ (m≤n⊔m k j)) .func y)
+      κ-fwd .func-resp-≈ {u₁ , (uj , uy)} {(vk , vx) , v₂} (liftS px , liftS qy) =
+        CXY .Colimit.apex .isEquivalence .trans
+          (elim-EquivOfS (CXY .Colimit.apex) (λ w → κ-fwd .func (w , (uj , uy)))
+            (λ { {k , x} {k' , x'} (p , wx) →
+              EquivOf-intro
+                ( ≤⇒≤′ (⊔-monoˡ-≤ uj (≤′⇒≤ p))
+                , prod (X _) (Y _) .isEquivalence .trans (prod-walk (≤⇒≤′ (⊔-monoˡ-≤ uj (≤′⇒≤ p))) _ _)
+                    ( wX.varying p (≤⇒≤′ (m≤m⊔n k uj)) (≤⇒≤′ (⊔-monoˡ-≤ uj (≤′⇒≤ p))) (≤⇒≤′ (m≤m⊔n k' uj)) wx
+                    , wY.fixed (≤⇒≤′ (m≤n⊔m k uj)) (≤⇒≤′ (⊔-monoˡ-≤ uj (≤′⇒≤ p))) (≤⇒≤′ (m≤n⊔m k' uj)) uy )) }) px)
+          (elim-EquivOfS (CXY .Colimit.apex) (λ w → κ-fwd .func ((vk , vx) , w))
+            (λ { {j , y} {j' , y'} (p' , wy) →
+              EquivOf-intro
+                ( ≤⇒≤′ (⊔-monoʳ-≤ vk (≤′⇒≤ p'))
+                , prod (X _) (Y _) .isEquivalence .trans (prod-walk (≤⇒≤′ (⊔-monoʳ-≤ vk (≤′⇒≤ p'))) _ _)
+                    ( wX.fixed (≤⇒≤′ (m≤m⊔n vk j)) (≤⇒≤′ (⊔-monoʳ-≤ vk (≤′⇒≤ p'))) (≤⇒≤′ (m≤m⊔n vk j')) vx
+                    , wY.varying p' (≤⇒≤′ (m≤n⊔m vk j)) (≤⇒≤′ (⊔-monoʳ-≤ vk (≤′⇒≤ p'))) (≤⇒≤′ (m≤n⊔m vk j')) wy )) }) qy)
+
+      forward : prod a b ⇒s CXY .Colimit.apex
+      forward = κ-fwd ∘ prod-m ιX ιY
+
+      -- The comparison maps intertwine the given cocones with the canonical ones.
+      ι-coevalX : ∀ k → Category._≈_ 𝒮 (ιX ∘ cX .transf k) (canonX .Colimit.cocone .transf k)
+      ι-coevalX = isX .IsColimit.colambda-coeval (canonX .Colimit.apex) (canonX .Colimit.cocone) .≃-NatTrans.transf-eq
+
+      ι-coevalY : ∀ k → Category._≈_ 𝒮 (ιY ∘ cY .transf k) (canonY .Colimit.cocone .transf k)
+      ι-coevalY = isY .IsColimit.colambda-coeval (canonY .Colimit.apex) (canonY .Colimit.cocone) .≃-NatTrans.transf-eq
+
+      -- κ-fwd carries the product of the canonical cocones onto the product-chain cocone (its k-stage
+      -- injection lands one diagonal step `k ⊔ k` up, which the chain absorbs).
+      κ-cocone : ∀ k → Category._≈_ 𝒮 (κ-fwd ∘ prod-m (canonX .Colimit.cocone .transf k) (canonY .Colimit.cocone .transf k))
+                                      (CXY .Colimit.cocone .transf k)
+      κ-cocone k .func-eq {x₁ , y₁} {x₂ , y₂} (x₁≈x₂ , y₁≈y₂) =
+        CXY .Colimit.apex .isEquivalence .sym
+          (EquivOf-intro
+            ( ≤⇒≤′ (m≤m⊔n k k)
+            , prod (X _) (Y _) .isEquivalence .trans (prod-walk (≤⇒≤′ (m≤m⊔n k k)) x₂ y₂)
+                ( Xc .Functor.fmor (≤⇒≤′ (m≤m⊔n k k)) .func-resp-≈ (X k .isEquivalence .sym x₁≈x₂)
+                , Yc .Functor.fmor-cong {f₁ = ≤⇒≤′ (m≤m⊔n k k)} {f₂ = ≤⇒≤′ (m≤n⊔m k k)} tt
+                    .func-eq (Y k .isEquivalence .sym y₁≈y₂) )))
+
+      -- Hence `forward` is a cocone morphism from the product-chain cocone to the canonical apex.
+      forward-cocone : ∀ k → Category._≈_ 𝒮 (forward ∘ prod-m (cX .transf k) (cY .transf k)) (CXY .Colimit.cocone .transf k)
+      forward-cocone k =
+        ≈-trans (assoc _ _ _)
+        (≈-trans (∘-cong₂ (≈-sym (prod-m-comp ιX ιY (cX .transf k) (cY .transf k))))
+        (≈-trans (∘-cong₂ (prod-m-cong (ι-coevalX k) (ι-coevalY k)))
+                 (κ-cocone k)))
+
+      -- The comparison maps are isos; their inverses mediate the canonical colimits back to a, b.
+      ι⁻X : canonX .Colimit.apex ⇒s a
+      ι⁻X = canonX .Colimit.isColimit .IsColimit.colambda a cX
+
+      ι⁻Y : canonY .Colimit.apex ⇒s b
+      ι⁻Y = canonY .Colimit.isColimit .IsColimit.colambda b cY
+
+      ι⁻X-coeval : ∀ k → Category._≈_ 𝒮 (ι⁻X ∘ canonX .Colimit.cocone .transf k) (cX .transf k)
+      ι⁻X-coeval = canonX .Colimit.isColimit .IsColimit.colambda-coeval a cX .≃-NatTrans.transf-eq
+
+      ι⁻Y-coeval : ∀ k → Category._≈_ 𝒮 (ι⁻Y ∘ canonY .Colimit.cocone .transf k) (cY .transf k)
+      ι⁻Y-coeval = canonY .Colimit.isColimit .IsColimit.colambda-coeval b cY .≃-NatTrans.transf-eq
+
+      ιinvX : Category._≈_ 𝒮 (ι⁻X ∘ ιX) (id a)
+      ιinvX = colambda-unique isX (λ k →
+        ≈-trans (assoc ι⁻X ιX (cX .transf k))
+        (≈-trans (∘-cong₂ (ι-coevalX k))
+        (≈-trans (ι⁻X-coeval k) (≈-sym id-left))))
+
+      ιinvY : Category._≈_ 𝒮 (ι⁻Y ∘ ιY) (id b)
+      ιinvY = colambda-unique isY (λ k →
+        ≈-trans (assoc ι⁻Y ιY (cY .transf k))
+        (≈-trans (∘-cong₂ (ι-coevalY k))
+        (≈-trans (ι⁻Y-coeval k) (≈-sym id-left))))
+
+      -- κ-bwd splits κ-fwd: it sends a stage-n product back to the diagonal pair of injections.
+      ρ : NatTrans PXY (constF ω (prod (canonX .Colimit.apex) (canonY .Colimit.apex)))
+      ρ = step-cocone (λ k → prod-m (canonX .Colimit.cocone .transf k) (canonY .Colimit.cocone .transf k))
+                      (λ k → ≈-trans (prod-m-cong (cocone-step (canonX .Colimit.cocone) k)
+                                                  (cocone-step (canonY .Colimit.cocone) k))
+                                     (prod-m-comp (canonX .Colimit.cocone .transf (suc k))
+                                                  (canonY .Colimit.cocone .transf (suc k)) (f k) (g k)))
+
+      κ-bwd : CXY .Colimit.apex ⇒s prod (canonX .Colimit.apex) (canonY .Colimit.apex)
+      κ-bwd = CXY .Colimit.isColimit .IsColimit.colambda (prod (canonX .Colimit.apex) (canonY .Colimit.apex)) ρ
+
+      κ-bwd-coeval : ∀ k → Category._≈_ 𝒮 (κ-bwd ∘ CXY .Colimit.cocone .transf k)
+                                          (prod-m (canonX .Colimit.cocone .transf k) (canonY .Colimit.cocone .transf k))
+      κ-bwd-coeval =
+        CXY .Colimit.isColimit .IsColimit.colambda-coeval
+          (prod (canonX .Colimit.apex) (canonY .Colimit.apex)) ρ .≃-NatTrans.transf-eq
+
+      κ-bwd∘fwd : Category._≈_ 𝒮 (κ-bwd ∘ κ-fwd) (id (prod (canonX .Colimit.apex) (canonY .Colimit.apex)))
+      κ-bwd∘fwd .func-eq {(k , x) , (j , y)} {(k' , x') , (j' , y')} (ex , ey) =
+        ( canonX .Colimit.apex .isEquivalence .trans
+            (canonX .Colimit.apex .isEquivalence .sym
+              (EquivOf-intro (≤⇒≤′ (m≤m⊔n k j) , X (k ⊔ℕ j) .isEquivalence .refl)))
+            ex
+        , canonY .Colimit.apex .isEquivalence .trans
+            (canonY .Colimit.apex .isEquivalence .sym
+              (EquivOf-intro (≤⇒≤′ (m≤n⊔m k j) , Y (k ⊔ℕ j) .isEquivalence .refl)))
+            ey )
+
+      backward : prod (canonX .Colimit.apex) (canonY .Colimit.apex) ⇒s prod a b
+      backward = prod-m ι⁻X ι⁻Y
+
+      -- `backward ∘ κ-bwd` is a section of `forward`.
+      retract : Category._≈_ 𝒮 ((backward ∘ κ-bwd) ∘ forward) (id (prod a b))
+      retract =
+        ≈-trans (assoc backward κ-bwd forward)
+        (≈-trans (∘-cong₂ (≈-trans (≈-sym (assoc κ-bwd κ-fwd (prod-m ιX ιY)))
+                          (≈-trans (∘-cong₁ κ-bwd∘fwd) id-left)))
+        (≈-trans (≈-sym (prod-m-comp ι⁻X ι⁻Y ιX ιY))
+        (≈-trans (prod-m-cong ιinvX ιinvY) prod-m-id)))
+
+      retract-cocone : ∀ k → Category._≈_ 𝒮 ((backward ∘ κ-bwd) ∘ CXY .Colimit.cocone .transf k)
+                                            (prod-m (cX .transf k) (cY .transf k))
+      retract-cocone k =
+        ≈-trans (assoc backward κ-bwd (CXY .Colimit.cocone .transf k))
+        (≈-trans (∘-cong₂ (κ-bwd-coeval k))
+        (≈-trans (≈-sym (prod-m-comp ι⁻X ι⁻Y (canonX .Colimit.cocone .transf k) (canonY .Colimit.cocone .transf k)))
+                 (prod-m-cong (ι⁻X-coeval k) (ι⁻Y-coeval k))))
+
+    ×-cocont : IsColimit PXY (prod a b) cocone₀
+    ×-cocont .IsColimit.colambda Z γ = CXY .Colimit.isColimit .IsColimit.colambda Z γ ∘ forward
+    ×-cocont .IsColimit.colambda-cong α≃β =
+      ∘-cong₁ (CXY .Colimit.isColimit .IsColimit.colambda-cong α≃β)
+    ×-cocont .IsColimit.colambda-coeval Z γ .≃-NatTrans.transf-eq k =
+      ≈-trans (assoc _ _ _)
+      (≈-trans (∘-cong₂ (forward-cocone k))
+               (CXY .Colimit.isColimit .IsColimit.colambda-coeval Z γ .≃-NatTrans.transf-eq k))
+    ×-cocont .IsColimit.colambda-ext Z h =
+      ≈-trans (∘-cong₁ lemA)
+      (≈-trans (assoc h (backward ∘ κ-bwd) forward)
+      (≈-trans (∘-cong₂ retract) id-right))
+      where
+        lemA : Category._≈_ 𝒮 (CXY .Colimit.isColimit .IsColimit.colambda Z (constFmor h ∘NT cocone₀))
+                              (h ∘ (backward ∘ κ-bwd))
+        lemA = colambda-unique (CXY .Colimit.isColimit) (λ k →
+          ≈-trans (CXY .Colimit.isColimit .IsColimit.colambda-coeval Z (constFmor h ∘NT cocone₀) .≃-NatTrans.transf-eq k)
+          (≈-sym (≈-trans (assoc h (backward ∘ κ-bwd) (CXY .Colimit.cocone .transf k))
+                          (∘-cong₂ (retract-cocone k)))))
+
+  -- A product with the initial (empty) setoid is itself initial: a pair needs a 𝟘 element, so the
+  -- carrier is empty.
+  prod𝟘-initial : ∀ {Γ} → IsInitial 𝒮 (prod Γ 𝟘)
+  prod𝟘-initial .from-initial .func (_ , lift ())
+  prod𝟘-initial .from-initial .func-resp-≈ {_ , lift ()}
+  prod𝟘-initial .from-initial-ext f .func-eq {_ , lift ()}
diff --git a/bib.bib b/bib.bib
index 9382d9a0..ca016460 100644
--- a/bib.bib
+++ b/bib.bib
@@ -300,6 +300,16 @@ @book{crole94
   address = {Cambridge},
 }
 
+@article{lawvere69,
+  author = {F. William Lawvere},
+  title = {Adjointness in Foundations},
+  journal = {Dialectica},
+  volume = {23},
+  number = {3--4},
+  pages = {281--296},
+  year = {1969}
+}
+
 @incollection{pitts01,
   author = {Andrew M. Pitts},
   title =	{Categorical Logic},
@@ -780,6 +790,15 @@ @book{Maclane1971-MACCFT
 	year = {1971}
 }
 
+@book{martinLof1984,
+  title = {Intuitionistic Type Theory},
+  author = {Martin-L{\"o}f, Per},
+  year = {1984},
+  publisher = {Bibliopolis},
+  address = {Naples},
+  note = {Notes by Giovanni Sambin of a series of lectures given in Padua, June 1980}
+}
+
 @inproceedings{green07,
   author = {Todd J. Green and Grigoris Karvounarakis and Val Tannen},
   title = {Provenance Semirings},
@@ -789,6 +808,100 @@ @inproceedings{green07
   doi = {10.1145/1265530.1265535},
 }
 
+@inproceedings{abbott2004,
+  author = {Abbott, Michael and Altenkirch, Thorsten and Ghani, Neil},
+  title = {Representing Nested Inductive Types Using {W}-Types},
+  booktitle = {Automata, Languages and Programming (ICALP)},
+  year = {2004},
+  pages = {59--71},
+  doi = {10.1007/978-3-540-27836-8_8}
+}
+
+@article{abbott2005,
+  author = {Abbott, Michael and Altenkirch, Thorsten and Ghani, Neil},
+  title = {Containers: Constructing Strictly Positive Types},
+  journal = {Theoretical Computer Science},
+  volume = {342},
+  number = {1},
+  pages = {3--27},
+  year = {2005},
+  doi = {10.1016/j.tcs.2005.06.002}
+}
+
+@inproceedings{cockett-spencer92,
+  author = {Cockett, J. Robin B. and Spencer, Dwight},
+  title = {Strong Categorical Datatypes {I}},
+  editor = {Seely, R. A. G.},
+  booktitle = {International Meeting on Category Theory 1991},
+  series = {CMS Conference Proceedings},
+  volume = {13},
+  publisher = {American Mathematical Society},
+  pages = {141--169},
+  year = {1992}
+}
+
+@article{hinze13,
+  author = {Hinze, Ralf},
+  title = {Adjoint Folds and Unfolds---An Extended Study},
+  journal = {Science of Computer Programming},
+  volume = {78},
+  number = {11},
+  pages = {2108--2159},
+  year = {2013},
+  doi = {10.1016/j.scico.2012.07.011}
+}
+
+@inproceedings{backhouse95,
+  author = {Backhouse, Roland and Bijsterveld, Marcel and van Geldrop, Rik and van der Woude, Jaap},
+  title = {Categorical Fixed Point Calculus},
+  booktitle = {Category Theory and Computer Science (CTCS 1995)},
+  series = {Lecture Notes in Computer Science},
+  volume = {953},
+  publisher = {Springer},
+  pages = {159--179},
+  year = {1995},
+  doi = {10.1007/3-540-60164-3_25}
+}
+
+@inproceedings{mitchell-scedrov92,
+  author = {Mitchell, John C. and Scedrov, Andre},
+  title = {Notes on Sconing and Relators},
+  booktitle = {Computer Science Logic (CSL 1992)},
+  series = {Lecture Notes in Computer Science},
+  volume = {702},
+  publisher = {Springer},
+  pages = {352--378},
+  year = {1993}
+}
+
+@book{levy2003,
+  author = {Levy, Paul Blain},
+  title = {Call-By-Push-Value: A Functional/Imperative Synthesis},
+  series = {Semantic Structures in Computation},
+  volume = {2},
+  publisher = {Springer},
+  year = {2003}
+}
+
+@article{lambek68,
+  author = {Lambek, Joachim},
+  title = {A Fixpoint Theorem for Complete Categories},
+  journal = {Mathematische Zeitschrift},
+  volume = {103},
+  pages = {151--161},
+  year = {1968}
+}
+
+@article{moerdijk-palmgren00,
+  author = {Moerdijk, Ieke and Palmgren, Erik},
+  title = {Wellfounded Trees in Categories},
+  journal = {Annals of Pure and Applied Logic},
+  volume = {104},
+  number = {1--3},
+  pages = {189--218},
+  year = {2000}
+}
+
 @book{high:ASNA2,
  author = "Nicholas J. Higham",
  title = "Accuracy and Stability of Numerical Algorithms",
diff --git a/macros.tex b/macros.tex
index c2a5f179..281c5ec8 100644
--- a/macros.tex
+++ b/macros.tex
@@ -20,9 +20,6 @@
 \newcommand{\bob}[1]{\textcolor{purple}{\textbf{BOB:} #1}}
 \newcommand{\roly}[1]{\textcolor{red}{\textbf{ROLY:} #1}}
 
-% Attribute inline edits with the optional id, e.g. \added[id=roly]{...}.
-\definechangesauthor[name=Bob, color=purple]{bob}
-\definechangesauthor[name=Roly, color=red]{roly}
 % No strikethrough: ulem's \sout is neither line-breakable nor metric-neutral.
 \colorlet{deletedgray}{gray!70}
 \setdeletedmarkup{\textcolor{deletedgray}{#1}}
@@ -143,7 +140,7 @@
 \newcommand*{\eval}{\varepsilon}
 \newcommand*{\faml}[1]{\overline{#1}} % \fam already defined
 \newcommand*{\fin}{\mathsf{fin}}
-\newcommand*{\cata}{\phi}
+\newcommand*{\cata}[1]{\llparenthesis #1 \rrparenthesis}
 \newcommand*{\id}{\mathsf{id}}
 \newcommand*{\idx}[1]{\widehat{#1}}
 \newcommand*{\inj}{\mathsf{inj}}
@@ -210,6 +207,9 @@
 \newcommand*{\demorgan}[1]{{#1}^{\circ}}
 \newcommand*{\HeytConj}{\namedcat{HeytConj}}
 \newcommand*{\muPoly}{\mu\namedcat{Poly}}
+\newcommand*{\Poly}{\namedcat{Poly}}
+\newcommand*{\roll}{\mathsf{roll}}
+\newcommand*{\with}{\mathsf{with}}
 \newcommand*{\Pred}{\mathrm{Pred}}
 \newcommand*{\PSh}{\namedcat{PSh}}
 \newcommand*{\PosGal}{\namedcat{PosGal}}
@@ -224,6 +224,8 @@
 \newcommand*{\JoinSLat}{\namedcat{JoinSLat}}
 \newcommand*{\Lposet}{\namedcat{Stable}}
 \newcommand*{\GLR}{\namedcat{GLR}} % Grothendieck Logical Relations
+\newcommand*{\Definable}{\mathsf{Def}}
+\newcommand*{\GF}{\hat{F}}
 \newcommand*{\Disc}{\mathrm{Disc}}
 \newcommand*{\LatConj}{\namedcat{LatConj}}
 \newcommand*{\QQ}{\mathbbm{Q}}
diff --git a/main.tex b/main.tex
index 9b959013..a353739c 100644
--- a/main.tex
+++ b/main.tex
@@ -7,6 +7,7 @@
 \usepackage{tabularx}
 \usepackage{bbm}
 \usepackage{bbold}
+\usepackage{stmaryrd}
 \usepackage{booktabs}
 \usepackage{enumitem}
 \usepackage{mathpartir}
diff --git a/mu-types.tex b/mu-types.tex
new file mode 100644
index 00000000..d895368c
--- /dev/null
+++ b/mu-types.tex
@@ -0,0 +1,36 @@
+\documentclass[acmsmall,screen]{acmart}
+
+\usepackage{tabularx}
+\usepackage{bbm}
+\usepackage{bbold}
+\usepackage{stmaryrd}
+\usepackage{mathpartir}
+\usepackage{subcaption}
+\usepackage{tikz-cd}
+\usepackage{xspace}
+
+\settopmatter{printacmref=false}
+\citestyle{acmauthoryear}
+\raggedbottom
+
+\usepackage[commandnameprefix=ifneeded,commentmarkup=footnote]{changes}
+\usepackage{changebar}
+\input{macros}
+
+\begin{document}
+
+\title{Inductive Types from Polynomial Endofunctors}
+
+\maketitle
+
+\input{mu-types/polynomial-types}
+\input{mu-types/conservativity}
+
+\bibliographystyle{ACM-Reference-Format}
+\bibliography{bib}
+
+\clearpage
+\appendix
+\input{mu-types/no-cbn}
+
+\end{document}
diff --git a/mu-types/conservativity.tex b/mu-types/conservativity.tex
new file mode 100644
index 00000000..d336747d
--- /dev/null
+++ b/mu-types/conservativity.tex
@@ -0,0 +1,562 @@
+\section{Correctness of the higher-order interpretation}
+\label{sec:conservativity}
+
+Two facts certify that the higher-order interpretation behaves correctly at first-order
+types: every term of first-order type denotes, up to the isomorphisms relating the two
+interpretations, a morphism of the first-order category; and the underlying function of the
+interpretation agrees with the plain set-level interpretation of the term. The first is immediate,
+because the embedding of the first-order model into the higher-order one is full
+(\remref{conservativity:full-F}). The second is
+proved by glueing: the interpreting category embeds into a category of Grothendieck logical
+relations \citep{fiore-simpson99}, the language is interpreted there, and at first-order types the
+interpretation is isomorphic to an embedded object, so by fullness of the embedding every term
+denotes the image of a morphism of the embedded category (\thmref{conservativity:underlying}).
+
+Glueing along a functor is the standard method for definability results, also known as
+sconing \citep{mitchell-scedrov92}; \citet{fiore-simpson99} refine it with \emph{covers},
+decompositions of an object as a coproduct (\secref{conservativity:glueing}), which sum types make
+necessary. \secref{predicate-system} sets up the calculus of predicates the construction uses,
+\secref{conservativity:glueing} builds the glued category, and \secref{conservativity:definability}
+proves the embedding full and derives the agreement of the underlying
+interpretation. The two remaining subsections
+supply the ingredients specific to inductive types: $\Poly$-types for the glued category
+(\secref{conservativity:glr-poly-types}) and their preservation by the embedding
+(\secref{conservativity:gf-poly-types}), which the theorem assumes.
+
+\subsection{Predicate systems}
+\label{sec:predicate-system}
+
+\subsubsection{Predicate system over $\cat{C}$}
+
+Let $\cat{C}$ be a category with finite products. A \emph{predicate system} over $\cat{C}$ consists of the
+following data:
+\begin{itemize}
+\item For every object $X$ of $\cat{C}$, a poset $(\Pred(X), \sqsubseteq)$ of predicates on $X$.
+\item For every $X$, the structure of a Heyting algebra (without $\bot$) on $\Pred(X)$, i.e.~ top element
+   $\top$, meets $\meet$, joins $\join$ and residual $\residual$ satisfying the usual laws.
+\item For every morphism $f: X \to Y$ of $\cat{C}$, a Galois connection $\directImage{-}{f} \dashv
+\reindex{-}{f} : \Pred(Y) \to \Pred(X)$. The right adjoint $\reindex{-}{f}: \Pred(Y) \to \Pred(X)$ computes
+the pullback (reindexing) of a predicate along $f$; the left adjoint $\directImage{-}{f}: \Pred(X) \to
+\Pred(Y)$ computes the pushforward (existential image) of a predicate along $f$, with the adjointness property
+meaning that
+\[\directImage{\varphi}{f} \sqsubseteq \psi \iff \varphi \sqsubseteq \reindex{\psi}{f} \]
+\item For every $X$ and $Y$, a right adjoint $\forall_Y: \Pred(X \times Y) \to \Pred(X)$ to the monotone map
+$\reindex{-}{\pi_1}$ called \emph{universal quantification}.
+\item $\reindex{-}{f}$ is colax (and thus $\directImage{-}{f}$ is lax) with respect to $\top$, $\meet$,
+$\residual$ and $\forall_Y$.
+\item $\reindex{-}{f}$ is lax (and thus $\directImage{-}{f}$ is colax) with respect to $\join$.
+\end{itemize}
+
+\noindent
+A predicate system is a first-order hyperdoctrine, with posets of predicates in place of
+categories: predicates are indexed by the objects of $\cat{C}$, substitution along a morphism acts
+on them by reindexing, and the quantifiers are the adjoints to substitution, existential on the
+left and universal on the right, which is the shape of the definition above. The reading of
+quantifiers as adjoints originates with \citet{lawvere69}; \citet{pitts01} surveys the resulting
+notion and its laws.
+
+\subsubsection{Predicate system over $\Set$}
+
+Let $X$ be a set. Define a \emph{predicate on $X$} to be a family of (proof-irrelevant) propositions for
+every $x \in X$. For any function $f: X \to Y$, define $\reindex{\varphi}{f}(x)$ iff $\varphi(f(x))$ and
+$\directImage{\varphi}{f}(y)$ iff there exists $x$ such that $f(x) = y$ and $\varphi(x)$. Define $\mathcal{S}$ to be the
+predicate system over $\Set$ which assigns to any set $X$ the set $\Pred(X)$ of propositions on $X$ ordered by
+implication, with $\top, \meet, \join$ and $\residual$ defined pointwise and universal quantification defined
+as $\forall_Y(\varphi)(x)$ iff $\varphi(x,y)$ for all $y \in Y$.
+
+\subsubsection{Predicates on a presheaf}
+
+Let $\cat{C}$ be a category and $H: \cat{C}^\op \to \Set$ a presheaf. Define a \emph{predicate on $H$} to be
+a family of predicates $\varphi_X \in \Pred_\mathcal{S}(H(X))$ for every object $X$ in $\cat{C}$ such that $\varphi_Y
+\sqsubseteq \reindex{\varphi_X}{H(f)}$ for every $f: X \to Y$ in $\cat{C}$.
+
+Now define the predicate system $\mathcal{S}^{\cat{C}}$ over $\Func{\cat{C}^\op}{\Set}$ which assigns to every
+presheaf $H$ the poset $\Pred(H)$ of predicates on $H$ ordered pointwise, where $\top, \meet, \join,
+\residual$ and $\forall$ in $\Pred(H)$ are all given pointwise, and to every natural transformation $\theta: H
+\to K$, families of pullback and pushforward maps where $\reindex{\varphi}{\theta}_X = \reindex{\varphi_X}{\theta_X}$ and
+$\directImage{\varphi}{\theta}_X = \directImage{\varphi_X}{\theta_X}$.
+
+\subsubsection{Closure operator over a predicate system}
+
+A \emph{closure operator} $C$ over a poset $(L, \sqleq)$ is a lax idempotent monad on $L$, with functoriality,
+unit and multiplication given by monotonicity, extensivity ($p \sqleq C(p)$) and idempotence ($C(C(p)) \sqleq
+C(p)$).
+
+Let $\mathcal{S} = (\Pred, \top, \meet, \join, \residual, \forall)$ be a predicate system over a category
+$\cat{C}$. A closure operator $C$ over $\mathcal{S}$ is a fibred lax idempotent monad $C$ on the fibration
+$\Pred: \cat{C}^\op \to \Poset$ where for every object $X$ the fibre map $C_X: \Pred(X) \to \Pred(X)$ is a
+closure operator, $C$ is lax monoidal with respect to $\meet$ (i.e.~$C(\varphi) \meet C(\psi) \sqleq C(\varphi \meet \psi)$),
+and $C$ is lax strong, i.e.~$C(\varphi) \meet \psi \sqleq C(\varphi \meet \psi)$. $C$ being a fibred functor means it commutes
+with any reindexing functor $\reindex{-}{f}$, i.e.~$C_X \comp \reindex{-}{f} \iso \reindex{-}{f} \comp C_Y$.
+
+\subsection{The category of logical relations}
+\label{sec:conservativity:glueing}
+
+Fix a category $\cat{C}$ with terminal object, finite products and stable set-indexed coproducts,
+in which the first-order fragment of the language is interpreted; a category $\cat{D}$ with terminal
+object, finite products, exponentials, and set-indexed coproducts, in which the full
+language is interpreted; and a functor $F : \cat{C} \to \cat{D}$ preserving the terminal object,
+products, and set-indexed coproducts. The finite coproducts both interpretations need for sum types
+are the two-element instance of the set-indexed ones, so they are not assumed separately; likewise
+their stability and preservation by $F$ follow from the set-indexed versions. For the
+language without inductive types it suffices to assume stable \emph{finite} coproducts, as in the
+extensive categories of \citet{fiore-simpson99}; recursive types force the set-indexed
+strengthening (\secref{conservativity:gf-poly-types}). Call a set-indexed coproduct decomposition
+$\coprod_i y_i \cong y$ a \emph{cover} of the object $y$; covers generate the closure operator
+introduced below.
+
+\begin{lemma}
+\label{lem:conservativity:fam-stable-coproducts}
+In a $\Fam$ category the set-indexed coproducts are stable, and a functor acting fibrewise
+preserves them.
+\end{lemma}
+
+\begin{proof}[Proof sketch]
+A cover $\coprod_i y_i \cong y$ presents each index of $y$ as lying in a unique summand; pulling
+back along $g$ retags the indices of the source, splitting it over the same index set, which gives
+stability. A fibrewise functor leaves index sets untouched and acts on fibres alone, so it carries
+the disjoint union of index sets to the disjoint union of their images.
+\end{proof}
+
+Predicates live over presheaves on $\cat{C}$: let $G : \cat{D} \to \PSh(\cat{C})$ be the functor
+sending $X$ to the presheaf $\cat{D}(F(-), X)$. A presheaf predicate on $G(X)$ thus
+assigns to each $y \in \cat{C}$, called the \emph{stage}, a predicate on the morphisms $F(y) \to X$, compatibly with
+precomposition along $\cat{C}$-morphisms; the predicate system of \secref{predicate-system} provides
+reindexing and the connectives for such predicates.
+
+\begin{definition}[Definability]
+\label{def:conservativity:definable}
+For $x \in \cat{C}$, the predicate $\Definable_x$ on $G(F(x))$ holds at $y \in \cat{C}$ of those $f :
+F(y) \to F(x)$ that are images of first-order morphisms: those with $f = F(g)$ for some $g : y \to x$.
+\end{definition}
+
+Definability is not closed under the reasoning the interpretation requires; in particular, a morphism
+defined by case analysis on a coproduct is definable only up to precomposition with the case split.
+Predicates are therefore taken \emph{closed} with respect to a closure operator $\mathbf{C}$,
+generated by covers of the stage: $\mathbf{C}(\Phi)$ is defined
+inductively, holding at $f : F(y) \to X$ if $\Phi$ does, or if some cover of $y$ has
+$\mathbf{C}(\Phi)$ holding at each restriction of $f$.
+
+\begin{lemma}
+\label{lem:conservativity:indexed-closure}
+$\mathbf{C}$ is a strong closure operator on predicates (\secref{predicate-system}), its
+reindexing law using the stability of the set-indexed coproducts of $\cat{C}$.
+\end{lemma}
+
+\begin{proof}[Proof sketch]
+Monotonicity, extensivity, idempotence, and strength are structural recursions on cover trees.
+The reindexing law transports a cover tree along a morphism by pulling each cover back
+(\lemref{conservativity:fam-stable-coproducts}) and recurring on the summands.
+\end{proof}
+
+The category $\GLR(F)$ of \emph{Grothendieck logical relations} has as objects pairs $(X, \Phi)$ of an
+object $X \in \cat{D}$ and a closed predicate $\Phi$ on $G(X)$, and as morphisms $(X, \Phi) \to (Y,
+\Psi)$ those $f : X \to Y$ with $\Phi \sqsubseteq \Psi[G(f)]$. The first-order category
+embeds by
+\[
+  \GF : \cat{C} \to \GLR(F) \qquad \GF(x) = (F(x), \mathbf{C}(\Definable_x)) \qquad \GF(g) = F(g)
+\]
+and the whole construction is summarised by the following theorem.
+
+\begin{theorem}[after \citet{fiore-simpson99}]
+\label{thm:conservativity:glr}
+$\GLR(F)$ is bicartesian closed, with set-indexed coproducts, each deriving from the
+corresponding structure of $\cat{D}$ with an appropriate predicate component. The projection $p :
+\GLR(F) \to \cat{D}$, $(X, \Phi) \mapsto X$, strictly preserves this structure, and $p \circ \GF =
+F$. The embedding $\GF$ is full and preserves the terminal object, products and coproducts.
+\end{theorem}
+
+\begin{remark}
+\label{rem:conservativity:glr-deltas}
+Relative to the statement of \citet{fiore-simpson99}: $\cat{C}$ need not be cartesian closed, nor
+$F$ preserve exponentials (when they are and it does, $\GF$ preserves exponentials too, but nothing
+below needs this); the smallness of $\cat{C}$ is replaced, in the formalisation, by an appropriate
+universe level; and the covers generating the closure operator are set-indexed rather than binary,
+a strengthening required for inductive types (\secref{conservativity:gf-poly-types}). Enlarging the covers
+strengthens the closure condition, so fewer predicates are closed and the category itself changes;
+the theorem carries over because its proof uses only the closure laws of
+\secref{predicate-system}, not the choice of generating covers.
+\end{remark}
+\noindent
+The functors assemble as
+\begin{center}
+\begin{tikzcd}[row sep=2.4em, column sep=3.2em]
+  \cat{C} \arrow[r, "\GF"] \arrow[dr, "F"'] & \GLR(F) \arrow[d, "p"] & \\
+  & \cat{D} \arrow[r, "G"'] & \PSh(\cat{C})
+\end{tikzcd}
+\end{center}
+\noindent
+with $p \circ \GF = F$: an object of $\GLR(F)$ is a $\cat{D}$-object together with a closed
+predicate on the presheaf that $G$ assigns to it, and $\GF$ equips each $F(x)$ with the closure of
+its definability predicate.
+
+\subsection{Definability}
+\label{sec:conservativity:definability}
+
+The glueing construction makes $\GF$ \emph{full}: morphisms between embedded objects are
+already first-order. Fullness is the last clause of \thmref{conservativity:glr}; here we
+give the proof.
+
+\begin{lemma}[Fullness of $\GF$]
+\label{lem:conservativity:definability}
+Every morphism $f : \GF(x) \to \GF(y)$ of $\GLR(F)$ is the image of a first-order morphism: $f = F(g)$
+for some $g : x \to y$.
+\end{lemma}
+
+\begin{proof}
+As a morphism of $\GLR$, $f$ maps $\mathbf{C}(\Definable_x)$ into $\mathbf{C}(\Definable_y)$ reindexed along
+$G(f)$; concretely, postcomposition with $f$ sends morphisms satisfying $\mathbf{C}(\Definable_x)$ to
+morphisms satisfying $\mathbf{C}(\Definable_y)$. The identity $F(\id_x)$ satisfies $\Definable_x$, so $f = f
+\circ F(\id_x)$ satisfies $\mathbf{C}(\Definable_y)$. But $\Definable_y$ is itself closed, because, node by
+node in a cover tree, witnesses for the summand restrictions copair along the decomposition to a witness
+for the covered morphism. So $f$ satisfies $\Definable_y$, that is, $f = F(g)$ for some $g : x \to y$.
+\end{proof}
+
+The copairing chooses a witness for each summand. Classically this is an instance of the axiom
+of choice; in the formalisation, where definability is a proof-irrelevant existential, no choice
+principle is available, and finite covers are special only because finitely many witnesses can
+be extracted one at a time. We therefore assume a uniform choice of witnesses: a function that,
+for each morphism $h : F(a) \to F(b)$ in the image of $F$, yields a $g$ with $F(g) = h$. When
+$F$ is a fibrewise functor between $\Fam$ categories and is faithful, the assumption reduces to
+its fibre functor: the index part of a witness is determined by $h$, the fibre parts are given
+by the fibre functor's witness function, and faithfulness supplies the naturality of the
+assembled family. At the pairing functor of \thmref{conservativity:underlying} below, a
+morphism in the image is a pair whose second component is determined by the first, so the witness
+is the first component itself.
+
+Fullness of $\GF$ (\lemref{conservativity:definability}) applies only to morphisms between embedded
+objects, so it remains to show that the interpretation of every first-order type is isomorphic to
+one. Interpreting the language in $\GLR(F)$ needs, beyond the structure of
+\secref{conservativity:glueing}, only $\Poly$-types (\defref{polynomial-types:has-poly}), which we
+construct in \secref{conservativity:glr-poly-types}; their preservation by $\GF$ is assumed here and
+proved in \secref{conservativity:gf-poly-types}. First-order types are also
+interpreted directly in $\cat{C}$, which has $\Poly$-types whenever it is a $\Fam$ category
+(\propref{polynomial-types:fam-has-poly}); write $\sem{\tau}_{\mathit{fo}}$ for this interpretation.
+
+\begin{lemma}[Type agreement]
+\label{lem:conservativity:type-agreement}
+For first-order $\tau$, $\sem{\tau} \cong \GF(\sem{\tau}_{\mathit{fo}})$.
+\end{lemma}
+
+\begin{proof}
+By induction on $\tau$. The unit, product and sum cases follow from the fact that $\GF$ preserves
+the terminal object, products and coproducts; base types agree by construction, the $\GLR(F)$-model of
+the signature being the transport of the $\cat{C}$-model along $\GF$; and $\mu$-types follow from
+the assumed preservation together with the isomorphism-invariance of the $\mu$-operator
+(\secref{polynomial-types:fam}).
+\end{proof}
+
+\begin{remark}[Full embeddings]
+\label{rem:conservativity:full-F}
+When $F$ is full (for example the embedding $\Fam(\SDSemiMod(S)) \to \Fam(\SemiMod(S))$), every
+$\cat{D}$-morphism between embedded objects is an $F$-image outright, so conservativity over
+$\cat{C}$ follows from the isomorphisms $\sem{\tau}_{\cat{D}} \cong F(\sem{\tau}_{\mathit{fo}})$
+alone, with no glueing; these arise as in \lemref{conservativity:type-agreement}, with
+$F$ in place of $\GF$.
+\end{remark}
+
+The glueing machinery is needed for the following theorem, whose pairing functor
+$\langle \mathrm{Id}, U \rangle$ is not full: the language is interpreted twice, in the
+higher-order category and in a set-level category, and fullness of the glued embedding ensures
+the two agree.
+
+\begin{theorem}[Term agreement]
+\label{thm:conservativity:underlying}
+Suppose the set-indexed coproducts of $\cat{D}$ are stable. Let $\cat{E}$ be a further category with the
+structure of $\cat{D}$ (\secref{conservativity:glueing}) and $\Poly$-types, and $U : \cat{D} \to
+\cat{E}$ a functor preserving the terminal object, products and set-indexed coproducts.
+Instantiate \secref{conservativity:glueing} with the first-order category taken to be $\cat{D}$
+itself, the higher-order category $\cat{D} \times \cat{E}$, and
+$F = \langle \mathrm{Id}, U \rangle$, and assume $\GF$ preserves $\Poly$-types
+(\defref{conservativity:preserves-poly}). Then for every term
+$\Gamma \vdash t : \tau$ with $\Gamma$ and $\tau$ first-order,
+\[
+  U(\sem{t}_{\cat{D}}) \;=\; \sem{t}_{\cat{E}},
+\]
+modulo the isomorphisms of \lemref{conservativity:type-agreement}.
+\end{theorem}
+
+\begin{proof}
+A morphism $F(x) \to F(y)$ of $\cat{D} \times \cat{E}$ is a pair $(h, k)$ with $h$ and $k$
+unrelated, whereas an $F$-image is constrained to $(g, U(g))$; in particular $F$ is not full. The interpretation of the language in
+$\cat{D} \times \cat{E}$ is computed componentwise, so it is the pair $(\sem{t}_{\cat{D}},
+\sem{t}_{\cat{E}})$. At first-order $\Gamma$ and $\tau$ the isomorphisms of
+\lemref{conservativity:type-agreement} exhibit this
+pair as a morphism between $\GF$-images, so by \lemref{conservativity:definability} it equals
+$(g, U(g))$ for some $g$; the first component gives $g = \sem{t}_{\cat{D}}$, and the second then
+gives $U(\sem{t}_{\cat{D}}) = \sem{t}_{\cat{E}}$.
+\end{proof}
+
+For the canonical models, $U : \Fam(\SemiMod(S)) \to \Set$ sends a family to its index set
+and a morphism to its index function; the stability hypothesis holds in any $\Fam$ category
+(\lemref{conservativity:fam-stable-coproducts}), and $\GF$ preserves $\Poly$-types by
+\propref{conservativity:gf-preserves-poly}, the first-order role being played by a $\Fam$
+category. The theorem then says that the underlying function of the
+higher-order interpretation is the plain set-theoretic interpretation of the term: the dependency
+data does not interfere. $U$ does not preserve exponentials, which is why
+the weakening of the hypotheses on $F$ in \remref{conservativity:glr-deltas} matters.
+
+\subsection{$\Poly$-types in $\GLR(F)$}
+\label{sec:conservativity:glr-poly-types}
+
+$\GLR(F)$ has $\Poly$-types. The category $\Fam(\GLR(F))$ has them already
+(\propref{polynomial-types:fam-has-poly}), so the task is to move the structure from the free
+coproduct completion (\secref{polynomial-types:fam}) back to $\GLR(F)$ itself: each family of
+$\GLR(F)$-objects can be \emph{realised} as an actual object, its set-indexed coproduct, and the
+initial algebras of $\GLR(F)$ are obtained as realisations of those of $\Fam(\GLR(F))$. The
+construction works for any category with the structure listed in
+\thmref{conservativity:transfer}; preservation by $\GF$ is the subject of
+\secref{conservativity:gf-poly-types}. Realisation supplies the carriers; the operations and laws transpose along an
+adjunction, at the price of a coherence property, \emph{realisation invariance}
+(\lemref{conservativity:realisation-invariance}).
+
+\subsubsection{Realisation}
+Let $\cat{E}$ be a category with set-indexed coproducts. The functor
+\[
+  \Sigma : \Fam(\cat{E}) \to \cat{E} \qquad \Sigma(X, \partial X) = \coprod_{x \in X} \partial X_x
+\]
+sends a family to the coproduct of its fibres and a morphism to the copairing of its fibre maps (the
+counit of the free coproduct completion). We call $\Sigma(X, \partial X)$ the
+\emph{realisation} of the family $(X, \partial X)$. Write $\eta : \cat{E} \to \Fam(\cat{E})$
+for the functor embedding an object as a family over a one-element set; $\Sigma \dashv \eta$.
+
+\begin{definition}[Presentation]
+\label{def:conservativity:presentation}
+A \emph{presentation} of an object $Z \in \cat{E}$ is a family $(X, \partial X) \in
+\Fam(\cat{E})$ together with an isomorphism $\Sigma(X, \partial X) \cong Z$.
+\end{definition}
+
+\noindent
+In a $\Fam$ category every
+object is canonically presented, set-indexed coproducts being disjoint unions of index sets; in
+$\GLR(F)$ presentations are genuine data, since a closed predicate on the carrier of $Z$ need not
+be determined by its restrictions to the fibres of a presenting family.
+
+\subsubsection{Carriers}
+\label{sec:conservativity:carriers}
+A functor applies to a polynomial constant-wise: for $G$ defined on $\cat{E}$, the polynomial
+$G(P)$ replaces each $\const$-object of $P$ with its $G$-image. In particular a polynomial $P$
+over $\cat{E}$ embeds as $\eta(P)$ over $\Fam(\cat{E})$, and $\Fam(\cat{E})$ has $\Poly$-types
+by \propref{polynomial-types:fam-has-poly}, since $\cat{E}$ has a terminal object and finite
+products. The $\Poly$-types for $\cat{E}$ are the realisations: $\mu_{\alpha.P}(\delta) :=
+\Sigma\, \mu_{\alpha.\eta(P)}(\eta \circ \delta)$, with $\eta \circ \delta$ entry-wise,
+that is, the composite
+\begin{center}
+\begin{tikzcd}[row sep=2.4em, column sep=4.5em]
+  \Fam(\cat{E})^{\Delta} \arrow[r, "\mu_{\alpha.\eta(P)}"] & \Fam(\cat{E}) \arrow[d, "\Sigma"] \\
+  \cat{E}^{\Delta} \arrow[u, "\eta^{\Delta}"] \arrow[r, dashed, "\mu_{\alpha.P}"'] & \cat{E}
+\end{tikzcd}
+\end{center}
+\noindent
+which routes an environment through $\Fam(\cat{E})$, where the initial algebras exist by
+construction, and realises the result back in $\cat{E}$. For this to yield
+\defref{polynomial-types:has-poly}, $\Sigma$ must preserve the structure from which
+the initial algebras of $\Fam(\cat{E})$ are built:
+set-indexed coproducts (immediate), the terminal object, and finite products, the last requiring
+products to distribute over set-indexed coproducts (a consequence of the exponentials). These
+requirements reappear as hypotheses of \thmref{conservativity:transfer}.
+
+\subsubsection{Operations and laws}
+The algebra map and catamorphism do not simply transport along the resulting isomorphisms: the algebra map of
+$\mu_{\alpha.\eta(P)}$ lives at an environment containing the $\Fam(\cat{E})$-object
+$\mu_{\alpha.\eta(P)}$ itself, whereas its realisation must live at the presented object
+$\Sigma\, \mu_{\alpha.\eta(P)}$. The adjunction $\Sigma \dashv \eta$ transposes algebras and
+catamorphisms between the two categories, an instance of adjoint folds \citep{hinze13};
+computing a fixed point through an adjunction goes back to the categorical fixed-point calculus
+\citep{backhouse95}. It remains to establish a fact about environments: the transposed operations are formed at
+environments of $\Fam(\cat{E})$-objects, and must instead be available at any environment
+whose entries merely have the right realisations, so $\Sigma(\eta(P)(-))$ must be unchanged,
+coherently, when each environment entry is replaced by a family with isomorphic realisation. We
+package this as a property of the polynomial, established by induction. We are not sure whether something similar exists in the literature.
+
+\begin{definition}[Realisation invariance]
+\label{def:conservativity:realisation-invariance}
+A polynomial $P$ over $\cat{E}$ is \emph{realisation-invariant} if every family of isomorphisms
+$\Sigma\,\varepsilon_i \cong \Sigma\,\varepsilon'_i$ between the realisations of two
+environments of $\Fam(\cat{E})$-objects induces an isomorphism $\Sigma(\eta(P)(\varepsilon))
+\cong \Sigma(\eta(P)(\varepsilon'))$ which is compatible with composition of such families and
+natural with respect to the strong action of $\eta(P)$.
+\end{definition}
+
+\begin{remark}
+Compatibility with identities is derivable, because naturality at projection families
+gives an extensionality principle (the induced isomorphism depends only on the underlying
+isomorphisms), extensionality then makes the induced isomorphism at identity families idempotent
+by compatibility with composition, and an idempotent isomorphism is the
+identity. Compatibility with composition is not derivable from
+naturality: a naturality square can be formed only at $\Fam(\cat{E})$-morphisms
+between the environment entries, and a family of mere isomorphisms between their realisations
+supplies none.
+\end{remark}
+
+\begin{lemma}
+\label{lem:conservativity:realisation-invariance}
+Every polynomial is realisation-invariant. For $\mu$-polynomials the induced isomorphism is
+moreover a morphism of algebras, and the laws of \defref{conservativity:realisation-invariance} follow from
+uniqueness of
+catamorphisms.
+\end{lemma}
+
+\begin{theorem}[Transfer]
+\label{thm:conservativity:transfer}
+Let $\cat{E}$ have set-indexed coproducts, a terminal object, finite products, exponentials and
+strong coproducts (copairing available in a context, as the catamorphisms of
+\secref{polynomial-types:fam} require). Then $\cat{E}$ has $\Poly$-types
+(\defref{polynomial-types:has-poly}).
+\end{theorem}
+
+\begin{proof}[Proof sketch]
+Take $\mu_{\alpha.P} := \Sigma\, \mu_{\alpha.\eta(P)}$ at singleton environments. The algebra
+map is the realised $\Fam(\cat{E})$ algebra map composed with the invariance
+isomorphism (\lemref{conservativity:realisation-invariance}) at the entry for the bound variable
+$\alpha$; the catamorphism transposes the
+$\Fam(\cat{E})$ catamorphism along $\Sigma \dashv \eta$. For the $\beta$ and $\eta$ laws, the
+interpretations agree across an isomorphism $\Sigma(\eta(P)(\eta \circ \delta)) \cong
+P(\delta)$, and this isomorphism commutes with the two strong actions, the realised
+action of $\eta(P)$ and the action $\cat{E}$ derives from the new structure (induction on $P$;
+the $\mu$ case is naturality of the invariance isomorphism). The laws are then the
+$\Fam(\cat{E})$ laws transported across these isomorphisms.
+\end{proof}
+
+\begin{corollary}
+\label{cor:conservativity:glr-poly}
+$\GLR(F)$ has $\Poly$-types.
+\end{corollary}
+
+\begin{proof}
+$\GLR(F)$ satisfies the hypotheses of \thmref{conservativity:transfer} by
+\thmref{conservativity:glr}, with its set-indexed coproducts computed as coproducts of carriers
+with joined predicates.
+\end{proof}
+
+\subsection{Preservation of $\Poly$-types by $\GF$}
+\label{sec:conservativity:gf-poly-types}
+
+\begin{definition}[Preservation of $\Poly$-types]
+\label{def:conservativity:preserves-poly}
+$\GF$ \emph{preserves $\Poly$-types} if for every $P \in \Poly_{\Delta,\alpha}$ over
+$\cat{C}$ and kinding environment $\delta$ there is an isomorphism
+$\mu_{\alpha.\GF(P)}(\GF \circ \delta) \cong \GF(\mu_{\alpha.P}(\delta))$.
+\end{definition}
+\noindent
+For the remainder of this subsection, suppose $\cat{C}$ is a $\Fam$ category.
+Preservation fails to follow simply from the fact that $\GF$ preserves the finite
+structure of $\cat{C}$: initial algebras
+map out of themselves, so finite preservation yields only a morphism $\mu_{\alpha.\GF(P)}
+\to \GF(\mu_{\alpha.P})$, obtained by folding the $\GF$-image of the algebra. The converse direction
+requires $\GF$ to preserve the presentation of $\mu_{\alpha.P}$ as a set-indexed coproduct of its
+fibres.
+
+\subsubsection{Concrete carriers}
+
+Preservation asks only for an
+isomorphism of objects, so we may take the $\Poly$-types of $\cat{C}$ to be the concrete
+construction of \propref{polynomial-types:fam-has-poly}, with carriers the sort-indexed tree
+families $(W_{s_0}, \partial W_{s_0})$, and build the isomorphism of
+\defref{conservativity:preserves-poly} on those carriers; the choice of $\Poly$-types structure is immaterial, any two having componentwise
+isomorphic $\mu$-objects, by folds both ways and uniqueness of catamorphisms. Working on the
+carriers avoids any appeal to initiality: sorts, trees and fibres are computed by recursion from
+the index sets $|A|$ and fibres $\partial A$ of the $\const$-objects and environment entries
+alone, so isomorphisms between carriers can be built directly. In particular $\const(A)$ and a
+variable $\beta$ with $\delta(\beta) = A$ contribute identical data.
+
+\begin{definition}[Constant-free form]
+\label{def:conservativity:constant-free-form}
+The \emph{constant-free form} $Q^{*}$ of a polynomial $Q$ replaces each occurrence of a
+$\const$-object with a fresh variable, giving a constant-free polynomial over the kinding context
+of $Q$ extended by those variables; an environment $\delta$ for $Q$ extends to the environment
+$(\delta, \vec{A})$ for $Q^{*}$ by assigning the displaced $\const$-objects $\vec{A}$ to the
+fresh variables.
+\end{definition}
+
+\noindent
+Having no constants,
+$Q^{*}$ is a polynomial over any category; below it is interpreted over both $\Fam(\cat{C})$ and
+$\Fam(\GLR(F))$, with the same sorts and trees on each side. Write
+$\check{\delta}_i$ for the $\GF$-image of the canonical presentation of $\delta_i$: the family
+over the index set of $\delta_i$ obtained by applying $\GF$ to the components of the
+presentation. Likewise write $\check{A}_j$ for the $\GF$-image of the canonical presentation of
+the $\const$-object $A_j$.
+
+\subsubsection{Preservation of set-indexed coproducts}
+
+\begin{lemma}
+\label{lem:conservativity:definable-coproducts}
+As predicates on $G(F(\coprod_i x_i))$, we have that
+$\Definable_{\coprod_i x_i} \sqsubseteq \mathbf{C}(\bigvee_i \Definable_{x_i}\langle
+\mathsf{in}_i \rangle)$.
+\end{lemma}
+
+\begin{proof}[Proof sketch]
+A definable $f = F(g)$ into the coproduct decomposes along the pullback of the cover
+$\coprod_i x_i$ along $g$, by stability; each restriction factors definably through a summand.
+\end{proof}
+
+Together with the fact that $F$ preserves set-indexed coproducts, the lemma makes $\GF$
+preserve them: carriers by assumption, predicates by the lemma and the closure operator's
+reindexing law (\lemref{conservativity:indexed-closure}), with the coproducts of $\GLR(F)$
+computed as in \corref{conservativity:glr-poly}. In particular $\Sigma\check{\delta}_i \cong
+\GF(\delta_i)$.
+
+\subsubsection{Carrier isomorphism}
+
+\begin{lemma}
+\label{lem:conservativity:constant-free-form}
+In a $\Fam$ category, $\mu_{\alpha.Q}(\delta) \cong \mu_{\alpha.Q^{*}}(\delta, \vec{A})$,
+where $\vec{A}$ are the $\const$-objects of $Q$.
+\end{lemma}
+
+\begin{proof}[Proof sketch]
+The carrier construction consumes a $\const$-object and the environment entry of a variable
+through the same data: the index set, decorating the tree sorts, and the fibres, interpreting the
+leaves. The constant/variable distinction is thus invisible to it, and the two carriers agree up to
+the renaming of tree constructors induced by the constant-free form, by tree recursion.
+\end{proof}
+
+\begin{lemma}[Carrier isomorphism]
+\label{lem:conservativity:carrier-isomorphism}
+$\GF(\mu_{\alpha.P^{*}}(\delta, \vec{A})) \cong \Sigma(\mu_{\alpha.P^{*}}(\check{\delta},
+\check{A}))$.
+\end{lemma}
+
+\begin{proof}[Proof sketch]
+Both carriers are set-indexed coproducts over the shared sort set, the left by the canonical
+presentation of the $\Fam$ $\mu$-object and the right by realisation. Since $\GF$ preserves
+set-indexed coproducts, it suffices to construct the isomorphism fibrewise, over a common sort, by
+tree recursion: at the leaves the two fibres are the same $\GF$-image of a presentation component, by
+the construction of $\check{\delta}$ and $\check{A}$, and at products they agree because $\GF$
+preserves products.
+\end{proof}
+
+\subsubsection{Preservation}
+
+\begin{proposition}[Preservation]
+\label{prop:conservativity:gf-preserves-poly}
+Suppose $\cat{C}$ is a $\Fam$ category. Then $\GF$ preserves $\Poly$-types.
+\end{proposition}
+
+\begin{proof}[Proof sketch]
+The $\Poly$-types of $\GLR(F)$ (\corref{conservativity:glr-poly}) are realisations:
+$\mu_{\alpha.\GF(P)}(\GF \circ \delta) = \Sigma(\mu_{\alpha.\eta(\GF(P))}(\eta \circ \GF
+\circ \delta))$, with functors applied to polynomials constant-wise and to environments
+entry-wise (\secref{conservativity:carriers}). Passing to the constant-free form discards
+$\const$-objects, so $\eta(\GF(P))^{*} = P^{*}$, and the displaced $\const$-objects of
+$\eta(\GF(P))$ are the $\eta(\GF(A_j))$. Then
+\[
+\begin{aligned}
+  \GF(\mu_{\alpha.P}(\delta))
+  &\;\overset{(1)}{\cong}\; \GF(\mu_{\alpha.P^{*}}(\delta, \vec{A}))
+  \;\overset{(2)}{\cong}\; \Sigma(\mu_{\alpha.P^{*}}(\check{\delta}, \check{A}))
+  \;\overset{(3)}{\cong}\; \Sigma(\mu_{\alpha.P^{*}}(\eta \circ \GF \circ \delta,
+    (\eta(\GF(A_j)))_j)) \\
+  &\;\overset{(4)}{\cong}\; \Sigma(\mu_{\alpha.\eta(\GF(P))}(\eta \circ \GF \circ \delta))
+  \;=\; \mu_{\alpha.\GF(P)}(\GF \circ \delta)
+\end{aligned}
+\]
+where (1) is \lemref{conservativity:constant-free-form} in $\cat{C}$, under $\GF$; (2) is
+\lemref{conservativity:carrier-isomorphism}; (3) is realisation invariance
+(\lemref{conservativity:realisation-invariance}) at the constant-free $P^{*}$, along the
+isomorphism family $\Sigma\check{\delta}_i \cong \GF(\delta_i) \cong
+\Sigma(\eta(\GF(\delta_i)))$ and likewise at the entries for $\vec{A}$; and (4) is
+\lemref{conservativity:constant-free-form} again, interpreted in $\Fam(\GLR(F))$ and realised, backwards.
+\end{proof}
diff --git a/mu-types/no-cbn.tex b/mu-types/no-cbn.tex
new file mode 100644
index 00000000..802acbba
--- /dev/null
+++ b/mu-types/no-cbn.tex
@@ -0,0 +1,36 @@
+\section{Why a syntactic CBN translation does not extend to inductive types}
+\label{sec:polynomial-types:no-cbn}
+
+Earlier versions of the paper attempted a syntactic approach to \emph{shape approximation},
+enriching datatypes with dependency information: Moggi's call-by-name translation
+\citep{notions-of-computation} into the language extended with a type constructor $T$, whose
+tags mark the positions at which dependency is recorded. The translation inserts $T$ around each
+child of every type constructor: $\cbn{\sigma \tySum \tau} = T(\cbn{\sigma}) \tySum T(\cbn{\tau})$,
+similarly for $\tyProd$ and $\tyFun$, with $\cbn{\rho} = \rho$ and $\cbn{\tyUnit} = \tyUnit$. This
+appendix records why that route is unavailable in the presence of inductive types: the substitution
+$\subst{\tau}{\sigma}{\alpha}$ in the $\syn{fold}$ typing rule does not commute with the
+$T$-tagging.
+
+Take the list schema $\tau = \tyUnit \tySum (\gamma \tyProd \alpha)$ and $\sigma = \gamma$, a
+closed base type. The $\syn{fold}$ rule types the fold body in a context extended by
+$\subst{\tau}{\sigma}{\alpha}$, and for the translated fold to typecheck, the translation of that
+entry must agree with what the target's $\syn{fold}$ rule expects: translating then substituting
+must equal substituting then translating. On one side, the translated context entry (a thunk, hence
+one more $T$) is
+\[
+  T(\cbn{\subst{\tau}{\sigma}{\alpha}}) =
+  T\bigl(T(\tyUnit) \tySum T(T(\gamma) \tyProd T(\gamma))\bigr);
+\]
+on the other, the target rule substitutes the $T$-wrapped result type into the translated
+schema:
+\[
+  \subst{\cbn{\tau}}{T(\cbn{\sigma})}{\alpha} =
+  T(\tyUnit) \tySum T\bigl(T(\gamma) \tyProd T(T(\gamma))\bigr).
+\]
+The two disagree twice. The context translation contributes an outermost $T$ that the target
+rule does not. And at the recursive position, the target substitutes $T(\gamma)$ under the $T$
+already wrapping $\alpha$ in $\cbn{\tau}$, giving $T(T(\gamma))$, where the source-side
+substitution, performed while $\alpha$ was a bare variable, leaves $T(\gamma)$. It is not clear how
+to repair this within Moggi's translation. Two ideas worth exploring are the CBN-into-CBPV
+translation \citep{levy2003}, and moving the $T$-tagging into the interpretation while keeping the
+source language as is.
diff --git a/mu-types/polynomial-types.tex b/mu-types/polynomial-types.tex
new file mode 100644
index 00000000..2cbd8912
--- /dev/null
+++ b/mu-types/polynomial-types.tex
@@ -0,0 +1,412 @@
+\section{Inductive types from polynomial endofunctors}
+\label{sec:polynomial-types}
+
+This section follows \citet{nunes2023}'s presentation, restricted to inductive types. Types are kinded
+over a context $\Delta = \alpha_1 : \mathsf{type}, \ldots, \alpha_n : \mathsf{type}$, with $\mu\alpha.\tau$
+binding a type variable in its body. Strict positivity is enforced by the kinding rule for function space:
+both argument and result must be closed (kinded in the empty context), so type variables cannot occur under
+$\tyFun$. A type with free kinding-context variables thus acts as a \emph{schema}: $\mu\alpha.\,\tyUnit
+\tySum (\gamma \tyProd \alpha)$, kinded under $\gamma : \mathsf{type}$, becomes a particular list type by
+substituting a closed type for $\gamma$. As in \citet{nunes2023}, the term language has no $\Lambda\alpha.\,
+t$ or $t[\tau]$, so this is type-level parameterisation only, not parametric polymorphism.
+\figref{polynomial-types:syntax} gives the syntax of types and terms.
+
+\begin{figure}
+\[
+\begin{array}{rclr}
+   \Delta &::=& \cdot \mid \Delta, \alpha : \mathsf{type} & \text{(kinding contexts)} \\
+   \tau, \sigma &::=& \alpha \mid \tyUnit \mid \rho \mid \sigma \tySum \tau \mid \sigma \tyProd \tau \mid
+                      \sigma \tyFun \tau \mid \mu\alpha.\tau & \text{(types)} \\
+   t, s &::=& \cdots \mid \tmRoll{t} \mid \syn{fold}\,t\,\syn{with}\,x.s & \text{(terms)}
+\end{array}
+\]
+\caption{Syntax of polynomial types and terms}
+\label{fig:polynomial-types:syntax}
+\end{figure}
+
+\subsection{Kinding rules}
+\label{sec:polynomial-types:kinding}
+
+A type $\tau$ is \emph{well-kinded} in context $\Delta$, written $\Delta \vdash \tau : \mathsf{type}$, by
+the rules in \figref{polynomial-types:kinding}. The function-space rule requires both $\sigma$ and $\tau$ to
+be kinded in the empty context, so function types are closed; this rules out any occurrence of a type
+variable under $\tyFun$, which suffices for strict positivity of $\mu\alpha.\tau$. The restriction is
+strictly stronger than classical strict positivity (which forbids type variables only in the \emph{domain}
+of $\tyFun$): our rule also excludes them from the codomain, so types like $\mu\alpha.\,\gamma \tyFun \alpha$
+are ruled out even though they are strictly positive in $\alpha$. The trade-off is a rule that needs no
+polarity tracking.
+
+\begin{figure}
+\begin{mathpar}
+\inferrule*
+  {\alpha : \mathsf{type} \in \Delta}
+  {\Delta \vdash \alpha : \mathsf{type}}
+\and
+\inferrule*
+  { }
+  {\Delta \vdash \tyUnit : \mathsf{type}}
+\and
+\inferrule*
+  {\rho \in \PrimTy}
+  {\Delta \vdash \rho : \mathsf{type}}
+\and
+\inferrule*
+  {\Delta \vdash \sigma : \mathsf{type} \\ \Delta \vdash \tau : \mathsf{type}}
+  {\Delta \vdash \sigma \tyProd \tau : \mathsf{type}}
+\and
+\inferrule*
+  {\Delta \vdash \sigma : \mathsf{type} \\ \Delta \vdash \tau : \mathsf{type}}
+  {\Delta \vdash \sigma \tySum \tau : \mathsf{type}}
+\and
+\inferrule*
+  {\cdot \vdash \sigma : \mathsf{type} \\ \cdot \vdash \tau : \mathsf{type}}
+  {\Delta \vdash \sigma \tyFun \tau : \mathsf{type}}
+\and
+\inferrule*
+  {\Delta, \alpha : \mathsf{type} \vdash \tau : \mathsf{type}}
+  {\Delta \vdash \mu\alpha.\tau : \mathsf{type}}
+\end{mathpar}
+\caption{Kinding rules for types}
+\label{fig:polynomial-types:kinding}
+\end{figure}
+
+\subsection{Syntactic polynomials}
+\label{sec:polynomial-types:poly}
+
+Let $\cat{C}$ be a category with finite products $(\times, \One)$ and finite coproducts
+$(\coprod, 0)$. The \emph{polynomials} over $\cat{C}$ are functor expressions in a kinding context
+$\Delta$:
+\[
+  P, Q \in \Poly_\Delta \;::=\; \const(A) \mid \alpha \mid P + Q \mid P \times Q \mid \mu\alpha.P
+\]
+where $A$ ranges over objects of $\cat{C}$ and $\alpha$ over the variables of $\Delta$.
+Polynomials mirror the types of \secref{polynomial-types:kinding}, with constants in place of primitive
+types. Function space is absent because function types are closed (\figref{polynomial-types:kinding}),
+so a function type denotes a fixed object and enters a polynomial as a constant. We identify each $P
+\in \Poly_\Delta$ with the functor $\cat{C}^\Delta \to \cat{C}$ it presents, writing $P(\delta)$ for
+its action on a \emph{kinding environment} $\delta \in \cat{C}^\Delta$, an assignment of an object to
+each variable of $\Delta$; the $\mu$ clause presupposes initial algebras, supplied as structure on
+$\cat{C}$ by \defref{polynomial-types:has-poly} below. Presenting functors by a syntax of signatures,
+interpreted afterwards, is standard in the literature on containers and strictly positive types
+\citep{abbott2005}; \citet{gambino-kock} treat polynomial functors as a categorical subject in their
+own right.
+
+\citet[Definition~6]{nunes2023} instead define the polynomial endofunctors on $\cat{C}$
+semantically, as the smallest subcategory of $\Cat$ containing the product and coproduct functors,
+projections, pairing and constants, and closed under forming $\mu H$ whenever it exists. An expression
+of type $\Poly_\Delta$ is in effect a derivation of membership in this class, detached from its side
+conditions, so it exists whether or not the initial algebras do. The construction of
+\secref{polynomial-types:fam} recurses on the expression to establish that the initial algebras exist,
+and, by substituting at the constants, interprets the same expression in both $\Fam(\cat{C})$ and sets.
+
+\subsection{Typing rules}
+\label{sec:polynomial-types:language}
+
+Typing contexts $\Gamma = x_1 : \sigma_1, \ldots, x_n : \sigma_n$ have all $\sigma_i$ closed
+($\cdot \vdash \sigma_i : \mathsf{type}$). The typing rules for $\syn{roll}$ and $\syn{fold}$ are
+\begin{mathpar}
+\inferrule*
+  {\Gamma \vdash t : \subst{\tau}{\mu\alpha.\tau}{\alpha}}
+  {\Gamma \vdash \tmRoll{t} : \mu\alpha.\tau}
+\and
+\inferrule*
+  {\Gamma \vdash t : \mu\alpha.\tau \\
+   \Gamma, x : \subst{\tau}{\sigma}{\alpha} \vdash s : \sigma}
+  {\Gamma \vdash \syn{fold}\,t\,\syn{with}\,x.s : \sigma}
+\end{mathpar}
+with $\sigma$ closed and $\tau$ kinded in context $\alpha : \mathsf{type}$. The $\fold$ rule uses the
+parametric (open) form of the catamorphism: the fold body $s$ lives in the extended context $\Gamma, x :
+\subst{\tau}{\sigma}{\alpha}$ rather than as a closed function, avoiding the need for exponentials in the
+semantic category.
+
+\subsection{Existence of initial algebras in $\Fam(\cat{C})$}
+\label{sec:polynomial-types:fam}
+
+\citet[Proposition~81]{nunes2023} establish that $\Fam(\Set)$ has initial algebras for their polynomials. We
+give a direct construction in $\Fam(\cat{C})$ via Martin-L\"of $W$-types
+\citep[Wellorderings, pp.~43--47]{martinLof1984}, restricted to the finitary fragment (where each shape has
+finite arity), which suffices because our polynomials are built from finite $+$ and $\times$.
+\citet{moerdijk-palmgren00} study $W$-types categorically, as initial algebras of polynomial
+endofunctors.
+
+We take polynomials (\secref{polynomial-types:poly}) over $\Fam(\cat{C})$, so each constant
+$\const(A)$ carries a family $A = (X, \partial X)$.
+
+The fold body of the $\syn{fold}$ rule of \secref{polynomial-types:language} lives in a typing context,
+so the catamorphism interpreting it must too. A \emph{morphism in context $\Gamma$} from $X$ to $Y$ is
+a map $\Gamma \times X \to Y$, composed by $f \circ_\Gamma g = f \circ \prodM{\pi_1}{g}$; these are
+the maps of the co-Kleisli category for the comonad $\Gamma \times -$. Each polynomial acts on
+morphisms in context through the \emph{strong} functorial action, which takes a morphism in context
+$\Gamma \times X_i \to Y_i$ for each variable $i$. Below, $F = P(\delta[\alpha \mapsto -])$.
+
+\begin{definition}[$\Poly$-types]
+\label{def:polynomial-types:has-poly}
+A category \emph{has $\Poly$-types} if for each $P \in \Poly_{\Delta,\alpha}$ and kinding environment $\delta$
+it provides:
+\begin{itemize}
+\item an object $\mu_{\alpha.P}(\delta)$ and algebra map $\inMap : P(\delta[\alpha \mapsto
+  \mu_{\alpha.P}(\delta)]) \to \mu_{\alpha.P}(\delta)$;
+\item for every $\Gamma$ and algebra $a : \Gamma \times P(\delta[\alpha \mapsto Y]) \to Y$, a map
+  $\cata{a} : \Gamma \times \mu_{\alpha.P}(\delta) \to Y$, its \emph{catamorphism}, the unique
+  morphism in context making
+  \begin{center}
+  \begin{tikzcd}[row sep=2.2em, column sep=3.2em]
+    F\,\mu_{\alpha.P}(\delta) \arrow[r, "\inMap"] \arrow[d, dashed, "F\cata{a}"'] &
+      \mu_{\alpha.P}(\delta) \arrow[d, dashed, "\cata{a}"] \\
+    F\,Y \arrow[r, "a"'] & Y
+  \end{tikzcd}
+  \end{center}
+  commute in the co-Kleisli category: commutation of the square is the law $\beta$, and uniqueness
+  of $\cata{a}$ the law $\eta$.
+\end{itemize}
+\end{definition}
+
+\noindent
+Unfolding $\circ_\Gamma$, the initiality square commutes in the underlying category as
+\begin{center}
+\begin{tikzcd}[row sep=2.4em, column sep=5em]
+  \Gamma \times F\,\mu_{\alpha.P}(\delta) \arrow[r, "\id \times \inMap"]
+    \arrow[d, "{\prodM{\pi_1}{F\cata{a}}}"'] &
+    \Gamma \times \mu_{\alpha.P}(\delta) \arrow[d, "\cata{a}"] \\
+  \Gamma \times F\,Y \arrow[r, "a"'] & Y
+\end{tikzcd}
+\end{center}
+\noindent
+where the left edge duplicates the context, retaining $\Gamma$ for $a$ while also feeding it
+to the strong action $F\cata{a}$. In element notation, for the polynomial $\const(A) \times \alpha$
+the strong action sends $h : \Gamma \times X \to Y$ to $(\gamma, (a, x)) \mapsto (a, h(\gamma, x))$:
+the context reaches each variable position, and constants pass through.
+
+Taking $\Gamma = 1$, each $\mu_{\alpha.P}(\delta)$ is in particular an initial algebra in the usual
+sense; in the presence of exponentials the strong form is no extra imposition (fold into $Y^\Gamma$), but
+$\Fam(\cat{C})$ need not have exponentials. Initial algebras equipped with catamorphisms in
+context are the strong datatypes of \citet{cockett-spencer92}, developed for categories with finite
+products but not necessarily exponentials. \citet[Definition~6]{nunes2023} accordingly ask only for
+initial algebras, their semantic categories being bicartesian closed. At the term level, $\beta$ reduces
+$\syn{fold}\,(\syn{roll}\,t)\,\syn{with}\,x.s$ by recursively folding each $\mu$-child of $t$ before
+substituting into $s$, and $\eta$ says $\syn{fold}\,t\,\syn{with}\,x.\syn{roll}\,x = t$.
+
+\begin{proposition}
+\label{prop:polynomial-types:fam-has-poly}
+If $\cat{C}$ has finite products $(\times, 1)$ then $\Fam(\cat{C})$ has $\Poly$-types.
+\end{proposition}
+
+Nested $\mu$s make the naive construction circular: when an inner binder's body mentions an outer binder,
+the inner carrier must be instantiated at the outer carrier while the latter is still being defined.
+Following \citet{abbott2004} we instead construct the initial algebras of $P$ and of all its inner
+$\mu$-bodies simultaneously, as a single family of trees indexed by sorts.
+
+The construction separates into two layers, and the first uses index data only. The separation
+is possible because $\Fam(\cat{C})$ is the free coproduct completion of $\cat{C}$, so an object is a
+set-indexed collection of $\cat{C}$-objects and nothing more. Write $|A|$ for the
+index set of a $\Fam(\cat{C})$-object $A$. The \emph{index erasure} $|Q|$ of a polynomial replaces
+each constant $\const(X, \partial X)$ by the constant on its index set $X$ and fixes the variable,
+sum, product and $\mu$ structure. The erasure $|\delta|$ of a kinding environment replaces each entry
+by its index set.
+
+The sorts and trees below are defined over $|Q|$ and $|\delta|$, so they make no reference to
+$\cat{C}$. The fibres form the second layer, assigning to each tree an object of $\cat{C}$. Two
+presentations agreeing on all index sets, even over different categories, therefore determine the
+same sorts and trees.
+
+\begin{definition}[Sort]
+\label{def:polynomial-types:sort}
+A \emph{sort} over $\Delta$ is a pair $(R, \rho)$ of an index-erased $\mu$-body $R$, that is a
+$\mu$-body whose constants are index sets, and an \emph{assignment} $\rho$ taking each free
+variable to either a parameter in $\Delta$ or another sort. The collection of sorts is inductively
+generated; those of $P$ are the sorts reachable from $|P|$.
+\end{definition}
+
+\begin{definition}[Trees of a sort]
+\label{def:polynomial-types:trees}
+Work over the erased environment $|\delta|$. For each sort $(R, \rho)$ the set $W_{(R,\rho)}$ of
+\emph{trees of sort $(R, \rho)$}, and for each index-erased polynomial $R'$ with an assignment $\rho'$
+of its variables the set of \emph{$R'$-trees}, are defined by a single simultaneous induction
+\citep{abbott2004}:
+\begin{itemize}
+\item a tree of sort $(R, \rho)$ is an $R$-tree, the bound variable $\alpha$ assigned the sort
+  $(R, \rho)$ itself;
+\item a $\const X$-tree is an element of $X$;
+\item a $\beta$-tree is an element of $|\delta|(\rho'(\beta))$ if $\rho'(\beta)$ is a parameter, and a
+  tree of sort $\rho'(\beta)$ otherwise;
+\item a $(R_1 + R_2)$-tree is an $R_1$-tree or an $R_2$-tree, tagged with the summand;
+\item a $(R_1 \times R_2)$-tree is a pair of an $R_1$-tree and an $R_2$-tree;
+\item a $\mu\beta.R'$-tree is a tree of sort $(R', \rho')$.
+\end{itemize}
+\end{definition}
+
+\begin{definition}[Decoration]
+\label{def:polynomial-types:decoration}
+A \emph{decoration} of a sort $(R, \rho)$ is a $\mu$-body $Q$ with $|Q| = R$, together with a
+decoration of each sort in the range of $\rho$. Decorations are data over the sorts, so the trees do
+not depend on them, and a decoration determines the sort it decorates. The root sort $(|P|, \rho_0)$
+is decorated by $P$ itself, and a decoration induces decorations of the sorts reachable from its
+sort, each inner $\mu$-body decorating the sort it erases to.
+\end{definition}
+
+\begin{definition}[Fibres]
+\label{def:polynomial-types:fibres}
+For a decorated sort $s$, the \emph{fibre} $\partial W_s(t) \in \cat{C}$ of a tree $t \in W_s$
+recovers the erased objects, by structural recursion on $t$:
+\begin{itemize}
+\item the fibre of a tree of sort $(R, \rho)$ is the fibre of the underlying $R$-tree;
+\item the fibre of a $\const X$-tree $x$ is $\partial X_x$, where $\const(X, \partial X)$ is the
+  constant supplied by the decoration;
+\item the fibre of a $\beta$-tree is the corresponding fibre of $\delta(\rho'(\beta))$ if
+  $\rho'(\beta)$ is a parameter, and the fibre of the tree of sort $\rho'(\beta)$ otherwise;
+\item the fibre of a $(R_1 + R_2)$-tree is the fibre of the underlying $R_i$-tree;
+\item the fibre of a $(R_1 \times R_2)$-tree is the product of the fibres of its components;
+\item the fibre of a $\mu\beta.R'$-tree is the fibre of the underlying tree of sort $(R', \rho')$,
+  decorated by the corresponding $\mu$-body of the decoration.
+\end{itemize}
+\end{definition}
+
+\paragraph{Worked example: rose trees.}
+Take $P = \const(A) \times \mu\beta.(\const(\One_{\!F}) + \alpha \times \beta) \in
+\Poly_{\alpha}$ over $\Fam(\cat{C})$, where $A = (|A|, \partial A)$ is a family and $\One_{\!F}$ the
+terminal family (one index, terminal fibre): a rose tree carries an $A$-label and a list of subtrees.
+The inner body mentions the outer variable $\alpha$, so
+the naive construction is circular, because the list carrier must be instantiated at $\mu_{\alpha.P}$
+while the latter is still being defined. $P$ has two sorts (\defref{polynomial-types:sort}),
+\[
+  s_0 = \bigl(|A| \times \mu\beta.(1 + \alpha \times \beta),\; \cdot\,\bigr) \qquad
+  s_1 = \bigl(1 + \alpha \times \beta,\; \alpha \mapsto s_0\bigr)
+\]
+the root sort and the sort of the inner $\mu$-body. Each sort's own bound variable ($\alpha$
+in $s_0$, $\beta$ in $s_1$) refers to that sort itself; the entry $\alpha \mapsto s_0$ of $s_1$
+records symbolically that the inner body uses the outer binder, with no need for the outer carrier
+to exist yet. By \defref{polynomial-types:trees}, a tree of sort $s_0$ is an element of $|A|$ paired
+with a tree of sort $s_1$, and a tree of sort $s_1$ is either the left tag (end of list) or a tree
+of sort $s_0$ paired with a further tree of sort $s_1$. So $W_{s_0}$ contains exactly the
+$|A|$-labelled rose trees and $W_{s_1}$ their forests, generated by one simultaneous induction.
+Decorating $s_0$ by $P$
+(\defref{polynomial-types:decoration}) restores the fibres $\partial A$ that erasure forgot, and the
+fibre of a tree (\defref{polynomial-types:fibres}) multiplies them over its nodes:
+\begin{center}
+\begin{tikzpicture}[level distance=8mm, sibling distance=14mm, every node/.style={inner sep=1pt}]
+\node {$x_0$} child {node {$x_1$}} child {node {$x_2$}};
+\end{tikzpicture}
+\qquad\raisebox{5.5mm}{$\partial W_{s_0} = \partial A_{x_0} \times \bigl((\partial A_{x_1} \times 1)
+  \times ((\partial A_{x_2} \times 1) \times 1)\bigr) \;\cong\; \partial A_{x_0} \times \partial
+  A_{x_1} \times \partial A_{x_2}$}
+\end{center}
+\noindent
+where the units come from the list ends and the leaves' empty forests. The proposition's
+carrier $(W_{s_0}, \partial W_{s_0})$ is therefore the family of rose trees with, over each tree,
+the product of its label fibres; the algebra map builds a tree from a label and a forest, and on
+fibres it is the identity, both sides being the same node-wise product.
+
+\begin{proof}[Proof of \propref{polynomial-types:fam-has-poly}]
+Take $\mu_{\alpha.P}(\delta) = (W_{s_0}, \partial W_{s_0})$, the family at the root sort $s_0 = (|P|,
+\rho_0)$ decorated by $P$, where $\rho_0$ takes the free variables of $P$ to the parameters
+$\Delta$.
+
+For the algebra map $\inMap : P(\delta[\alpha \mapsto \mu_{\alpha.P}(\delta)]) \to
+\mu_{\alpha.P}(\delta)$, compute the domain by induction on $P$. An element of its index set is the
+tuple of arguments to one application of the tree constructor: a label at each constant, a tag at each sum,
+a pair at each product, an $s_0$-subtree at each occurrence of $\alpha$, and at each inner
+$\mu$-body a subtree of its sort in which the $\alpha$-positions again hold $s_0$-subtrees.
+\defref{polynomial-types:trees} admits exactly these arguments under the root of an $s_0$-tree, so
+on index sets $\inMap$ forms the tree with the arguments beneath a new root node, invertibly,
+decomposition at the root being its inverse; in the rose-tree example
+\begin{center}
+$\inMap : \bigl(x_0,\ [\,T_1,\ T_2\,]\bigr) \;\longmapsto\;$
+\begin{tikzpicture}[baseline=-8mm, level distance=7mm, sibling distance=12mm,
+                    every node/.style={inner sep=1pt}]
+\node {$x_0$} child {node {$\triangle_{T_1}$}} child {node {$\triangle_{T_2}$}};
+\end{tikzpicture}
+\end{center}
+\noindent
+with the triangles standing for the subtrees $T_1$ and $T_2$. On fibres $\inMap$ is the identity,
+because \defref{polynomial-types:fibres} computes the fibre of the new tree by the same product
+structure that the action of $P$ computes on the arguments; in the example, both sides are the same node-wise
+product of label fibres.
+
+For an algebra $a : \Gamma \times P(\delta[\alpha \mapsto Y]) \to Y$, the catamorphism
+$\cata{a} : \Gamma \times \mu_{\alpha.P}(\delta) \to Y$ is defined by structural recursion over
+trees, simultaneously over all sorts, threading the $\Gamma$-component unchanged. In the rose-tree
+example, on index sets,
+\[
+  \cata{a}\bigl(\gamma,\ \inMap(x_0,\ [\,T_1,\ T_2\,])\bigr) \;=\;
+  a\bigl(\gamma,\ (x_0,\ [\,\cata{a}(\gamma, T_1),\ \cata{a}(\gamma, T_2)\,])\bigr).
+\]
+\noindent
+In general, the root is decomposed into its arguments, the recursion is applied to each
+$s_0$-subtree, and $a$ combines the results. The recursion at an inner sort translates its trees from
+the environment $\delta$ to the environment $\delta[\alpha \mapsto Y]$, replacing each
+$s_0$-subtree by its folded value and leaving the surrounding structure intact (the list over $Y$
+in the equation above), so that the translated arguments land in the domain of $a$. The same recursion is
+performed on fibres.
+
+The law $\beta$ is the unfolded initiality square of \defref{polynomial-types:has-poly},
+taken at the concrete carriers. The upper path forms the tree with the arguments as its immediate
+subtrees and then folds it; the lower path folds the $s_0$-subtrees inside the arguments and then
+applies $a$. Both compute the same recursion on trees, and the equation above is $\beta$ at the
+example. For $\eta$, let $h$ satisfy $\beta$ in place of $\cata{a}$; by induction on trees
+(simultaneously over all sorts), $h$ agrees with $\cata{a}$ at every tree, the inductive
+hypothesis covering the $s_0$-subtrees among the arguments.
+\end{proof}
+
+\subsection{The $\mu$-operator}
+\label{sec:polynomial-types:mu-operator}
+
+The construction of \secref{polynomial-types:fam} is pointwise in the kinding environment
+$\delta$. This subsection derives the remaining structure, the action of $\mu_{\alpha.P}$ on morphisms
+of environments and its laws, from $\beta$ and $\eta$ alone, so everything here holds in any category
+with $\Poly$-types, independently of the construction. Fix $P \in \Poly_{\Delta,\alpha}$, write
+$\inMap_\delta$ for the algebra map at $\delta$, and $F = P(\delta[\alpha \mapsto -])$. All diagrams
+are squares of morphisms in context $\Gamma$, composed by $\circ_\Gamma$.
+
+As in \citet[Proposition~4]{nunes2023}, the action on a morphism $g : \delta \to \delta'$ is
+given by folding: $\mu_{\alpha.P}(g) = \cata{\,\inMap_{\delta'} \circ P(g[\alpha \mapsto \id])\,}$,
+the algebra built from the strong action of $P$. By $\beta$ and $\eta$, $\mu_{\alpha.P}(g)$ is the
+unique map making
+\begin{center}
+\begin{tikzcd}[row sep=2.2em, column sep=5em]
+  P(\delta[\alpha \mapsto \mu_{\alpha.P}(\delta)]) \arrow[r, "\inMap_\delta"]
+    \arrow[d, "{P(g[\alpha \mapsto \mu_{\alpha.P}(g)])}"'] &
+    \mu_{\alpha.P}(\delta) \arrow[d, "\mu_{\alpha.P}(g)"] \\
+  P(\delta'[\alpha \mapsto \mu_{\alpha.P}(\delta')]) \arrow[r, "\inMap_{\delta'}"'] &
+    \mu_{\alpha.P}(\delta')
+\end{tikzcd}
+\end{center}
+commute: the algebra maps are natural in the environment.
+
+The laws of this action follow from one standard consequence of initiality.
+
+\begin{lemma}[Fusion]
+\label{lem:polynomial-types:fusion}
+Let $a : \Gamma \times FY \to Y$ and $b : \Gamma \times FZ \to Z$ be algebras and $h : \Gamma \times
+Y \to Z$. If $h \circ_\Gamma a = b \circ_\Gamma Fh$ then $h \circ_\Gamma \cata{a} = \cata{b}$.
+\end{lemma}
+\begin{center}
+\begin{tikzcd}[row sep=2.2em, column sep=3.2em]
+  F\,\mu_{\alpha.P}(\delta) \arrow[r, "\inMap_\delta"] \arrow[d, "F\cata{a}"'] &
+    \mu_{\alpha.P}(\delta) \arrow[d, "\cata{a}"] \\
+  F\,Y \arrow[r, "a"] \arrow[d, "Fh"'] & Y \arrow[d, "h"] \\
+  F\,Z \arrow[r, "b"'] & Z
+\end{tikzcd}
+\end{center}
+\noindent
+The upper square is $\beta$; when the lower square commutes, the outer rectangle states that
+$h \circ_\Gamma \cata{a}$ satisfies the $\beta$-law characterising $\cata{b}$ (this uses that $F$
+preserves $\circ_\Gamma$), so the two are equal by uniqueness. Fusion gives the functor laws directly:
+$\mu_{\alpha.P}(\id) = \id$ is $\eta$, and pasting the naturality square of $g$ above that of $g'$
+exhibits $\mu_{\alpha.P}(g') \circ_\Gamma \mu_{\alpha.P}(g)$ as a fold of the algebra defining
+$\mu_{\alpha.P}(g' \circ g)$.
+
+Uniqueness also shows the initial algebra is determined by the polynomial up to isomorphism:
+if $\varphi : P(\delta) \cong Q(\delta)$ naturally in $\delta$, the folds
+$\cata{\inMap^Q \circ \varphi}$ and $\cata{\inMap^P \circ \varphi^{-1}}$ compose, by fusion, to folds
+of $\inMap^P$ and $\inMap^Q$, which are identities by $\eta$; so $\mu_{\alpha.P}(\delta) \cong
+\mu_{\alpha.Q}(\delta)$. The same pattern at $\Gamma = 1$ gives Lambek's lemma \citep{lambek68}:
+$\inMap_\delta$ is itself an isomorphism, with inverse $\cata{F\,\inMap_\delta}$, so
+$\mu_{\alpha.P}(\delta)$ is a fixed point of $F$.
+
+The strong action makes each $P$ the morphism part of a functor $(\cat{C}_\Gamma)^\Delta \to
+\cat{C}_\Gamma$ on co-Kleisli categories, the plain action being its restriction to pure morphisms
+$\prodM{\pi_1}{g \circ \pi_2}$. For a $\mu$-subexpression the functoriality that fusion assumes of
+$F$ is the functoriality being proved, at the inner binder; the two are established together by
+induction on the polynomial expression.
+
+
diff --git a/notes.tex b/notes.tex
index 9c72567e..8ed23524 100644
--- a/notes.tex
+++ b/notes.tex
@@ -3,6 +3,7 @@
 \usepackage{tabularx}
 \usepackage{bbm}
 \usepackage{bbold}
+\usepackage{stmaryrd}
 \usepackage{mathpartir}
 \usepackage{subcaption}
 \usepackage{tikz-cd}
@@ -13,6 +14,7 @@
 \citestyle{acmauthoryear}
 \raggedbottom
 
+\usepackage[commandnameprefix=ifneeded,commentmarkup=footnote]{changes}
 \input{macros}
 
 \begin{document}
@@ -50,9 +52,13 @@ \section{Overview}
    \end{itemize}
 \item matrices over a commutative semiring; $\Mat(\Two)$ as worked example (\secref{matrix})
 \item stable coproducts (\secref{stable-coproducts})
-\item predicate systems (\secref{predicate-system})
+% \item slicing interpretation of the source language via a strong monad on the semantic category
 \end{itemize}
 
+\noindent Inductive types from polynomial endofunctors, and the correctness development that
+depends on them (predicate systems, glueing, agreement of the underlying interpretation),
+previously covered here, now have their own document (\texttt{mu-types.pdf}).
+
 \noindent $\Set$ will usually be $\Setoid$ in the Agda implementation but we will gloss that detail for now.
 
 \input{notes/preliminaries}
@@ -68,7 +74,7 @@ \section{Overview}
 \input{notes/auto-diff-galois-slicing-via-fam}
 \input{notes/matrix}
 \input{notes/stable-coproducts}
-\input{notes/predicate-system}
+% \input{notes/slicing-interpretation}  % moved to unused: monadic slicing not load-bearing (see git history)
 
 \bibliographystyle{ACM-Reference-Format}
 \bibliography{bib}
diff --git a/notes/predicate-system.tex b/notes/predicate-system.tex
deleted file mode 100644
index bdcee4da..00000000
--- a/notes/predicate-system.tex
+++ /dev/null
@@ -1,65 +0,0 @@
-\section{Predicate systems}
-\label{sec:predicate-system}
-
-\subsection{Predicate system over $\cat{C}$}
-
-Suppose $\cat{C}$ a category with finite products. A \emph{predicate system} over $\cat{C}$ consists of the
-following data:
-\begin{itemize}
-\item For every object $X$ of $\cat{C}$, a poset $(\Pred(X), \sqsubseteq)$ of predicates on $X$.
-\item For every $X$, the structure of a Heyting algebra (without $\bot$) on $\Pred(X)$, i.e.~ top element
-   $\top$, meets $\meet$, joins $\join$ and residual $\residual$ satisfying the usual laws.
-\item For every morphism $f: X \to Y$ of $\cat{C}$, a Galois connection $\directImage{-}{f} \dashv
-\reindex{-}{f} : \Pred(Y) \to \Pred(X)$. The right adjoint $\reindex{-}{f}: \Pred(Y) \to \Pred(X)$ computes
-the pullback (reindexing) of a predicate along $f$; the left adjoint $\directImage{-}{f}: \Pred(X) \to
-\Pred(Y)$ computes the pushforward (existential image) of a predicate along $f$, with the adjointness property
-meaning that
-\[\directImage{P}{f} \sqsubseteq Q \iff P \sqsubseteq \reindex{Q}{f} \]
-\item For every $X$ and $Y$, a right adjoint $\forall_Y: \Pred(X \times Y) \to \Pred(X)$ to the monotone map
-$\reindex{-}{\pi_1}$ called \emph{universal quantification}. \roly{Is there a left adjoint $\exists_Y$?}
-\item $\reindex{-}{f}$ is colax (and thus $\directImage{-}{f}$ is lax) with respect to $\top$, $\meet$,
-$\residual$ and $\forall_Y$.
-\item $\reindex{-}{f}$ is lax (and thus $\directImage{-}{f}$ is colax) with respect to $\join$.
-\end{itemize}
-
-\subsection{Predicate system over $\Set$}
-
-Suppose $X$ a set. Define a \emph{predicate on $X$} to be a family of (proof-irrelevant) propositions for
-every $x \in X$. For any function $f: X \to Y$, define $\reindex{P}{f}(x)$ iff $P(f(x))$ and
-$\directImage{P}{f}(y)$ iff there exists $x$ such that $f(x) = y$ and $P(x)$. Define $\mathcal{S}$ to be the
-predicate system over $\Set$ which assigns to any set $X$ the set $\Pred(X)$ of propositions on $X$ ordered by
-implication, with $\top, \meet, \join$ and $\residual$ defined pointwise and universal quantification defined
-as $\forall_Y(P)(x)$ iff $P(x,y)$ for all $y \in Y$.
-
-\subsection{Predicates on a presheaf}
-
-Suppose $\cat{C}$ a category and $F: \cat{C}^\op \to \Set$ a presheaf. Define a \emph{predicate on $F$} to be
-a family of predicates $P_X \in \Pred_\mathcal{S}(F(X))$ for every object $X$ in $\cat{C}$ such that $P_Y
-\sqsubseteq \reindex{P_X}{F(f)}$ for every $f: X \to Y$ in $\cat{C}$.
-
-Now define the predicate system $\mathcal{S}^{\cat{C}}$ over $\Func{\cat{C}^\op}{\Set}$ which assigns to every
-presheaf $F$ the poset $\Pred(F)$ of predicates on $F$ ordered pointwise, where $\top, \meet, \join,
-\residual$ and $\forall$ in $\Pred(F)$ are all given pointwise, and to every natural transformation $\alpha: F
-\to G$, families of pullback and pushforward maps where $\reindex{P}{\alpha}_X = \reindex{P_X}{\alpha_X}$ and
-$\directImage{P}{\alpha}_X = \directImage{P_X}{\alpha_X}$.
-
-\subsection{Closure operator over a predicate system}
-
-A \emph{closure operator} $C$ over a poset $(X, \sqleq)$ is a lax idempotent monad on $X$, with functoriality,
-unit and multiplication given by monotonicity, extensivity ($x \sqleq C(x)$) and idempotence ($C(C(x)) \sqleq
-C(x)$).
-
-Suppose $\mathcal{S} = (\Pred, \top, \meet, \join, \residual, \forall)$ a predicate system over a category
-$\cat{C}$. A closure operator $C$ over $\mathcal{S}$ is a fibred lax idempotent monad $C$ on the fibration
-$\Pred: \cat{C}^\op \to \Poset$ where for every object $X$ the fibre map $C_X: \Pred(X) \to \Pred(X)$ is a
-closure operator, $C$ is lax monoidal with respect to $\meet$ (i.e.~$C(P) \meet C(Q) \sqleq C(P \meet Q)$),
-and $C$ is lax strong, i.e.~$C(P) \meet Q \sqleq C(P \meet Q)$. $C$ being a fibred functor means it commutes
-with any reindexing functor $\reindex{-}{f}$, i.e.~$C_X \comp \reindex{-}{f} \iso \reindex{-}{f} \comp C_Y$.
-
-% Haven't figured this out yet..
-%
-% \subsection{Coproduct closure operator}
-%
-% Suppose $\cat{C}$ a category with stable coproducts (\secref{stable-coproducts}). Define the fibred functor
-% $C$ where for every presheaf $F: \cat{C}^\op \to \Set$ the fibre map $C_F: \Pred(F) \to \Pred(F)$ sends every
-% family of predicates $P \in \Pred(F)$ to the family ... for every $X$ in $\cat{C}$
diff --git a/notes/slicing-interpretation.tex b/notes/slicing-interpretation.tex
new file mode 100644
index 00000000..5a2931d5
--- /dev/null
+++ b/notes/slicing-interpretation.tex
@@ -0,0 +1,178 @@
+\section{Interpretations parameterised by a strong monad}
+\label{sec:slicing-interpretation}
+
+In response to the obstruction described in \secref{polynomial-types:no-cbn}, we move the
+$T$-tagging from a syntactic translation into the interpretation. The source language stays as in
+\secref{polynomial-types}. Following \citet{notions-of-computation}, the interpretation is
+parameterised by a category $\cat{D}$ equipped with a strong monad $T : \cat{D} \to \cat{D}$
+modelling a notion of computation. Within this setup we give two distinct interpretations: a Moggi-style CBN interpretation
+(\secref{slicing-interpretation:moggi}) with $T$ around the children of each non-base type former
+(matching the placement of \secref{polynomial-types:no-cbn}'s CBN translation), and one intended
+to model Galois slicing (\secref{slicing-interpretation:galois}) with $T$ at the root of each type
+former.
+
+\subsection{Semantic assumptions}
+\label{sec:slicing-interpretation:assumptions}
+
+Assume a category $\cat{D}$ with:
+\begin{itemize}
+\item finite products $(\times, \One)$ and exponentials (so $\cat{D}$ is Cartesian closed);
+\item finite coproducts $(+, 0)$, with the products distributing over coproducts;
+\item a strong monad $T : \cat{D} \to \cat{D}$ with unit $\eta : \id \Rightarrow T$, multiplication
+  $\mu : T^2 \Rightarrow T$, and strength $\mathsf{st}_{X,Y} : X \times T(Y) \to T(X \times Y)$;
+\item a signature interpretation, assigning each $\rho \in \PrimTy$ an object
+  $\sem{\rho}_{\PrimTy} \in \cat{D}$;
+\item initial algebras for all endofunctors in $\Poly^T_{\cat{D}}$, where
+  $\Poly^T_{\cat{D}}$ extends $\Poly_{\cat{D}}$ (\defref{polynomial-types:Poly}) by additionally
+  closing the morphisms under post-composition with $T$. We say $\cat{D}$ \emph{has
+  $\Poly^T$-types}, and write $\mu F$ for the initial algebra of an $F \in \Poly^T_{\cat{D}}$.
+\end{itemize}
+
+A type $\tau$ kinded in context $\Delta = \alpha_1, \ldots, \alpha_n$ is interpreted as a functor
+$\sem{\tau} : \cat{D}^n \to \cat{D}$; closed types ($\Delta = \cdot$) thus interpret as objects of
+$\cat{D}$. Term contexts contain only closed types. The two placements agree on the variable and
+$\mu$ clauses and differ on the others.
+
+\subsection{Moggi-style CBN interpretation}
+\label{sec:slicing-interpretation:moggi}
+
+The Moggi semantics matches \secref{polynomial-types:no-cbn}'s CBN translation: $T$ wraps each
+\emph{child} of every non-base type former, with primitives and $\tyUnit$ left bare.
+\begin{align*}
+\sem{\alpha_i}(\vec{X})            & = X_i \\
+\sem{\rho}(\vec{X})                & = \sem{\rho}_{\PrimTy} \\
+\sem{\tyUnit}(\vec{X})             & = \One \\
+\sem{\sigma \tyProd \tau}(\vec{X}) & = T(\sem{\sigma}(\vec{X})) \times T(\sem{\tau}(\vec{X})) \\
+\sem{\sigma \tySum \tau}(\vec{X})  & = T(\sem{\sigma}(\vec{X})) + T(\sem{\tau}(\vec{X})) \\
+\sem{\sigma \tyFun \tau}(\vec{X})  & = T(\sem{\sigma}(\vec{X})) \Rightarrow T(\sem{\tau}(\vec{X})) \\
+\sem{\mu\alpha.\tau}(\vec{X})      & = \mu(X \mapsto \sem{\tau}(\vec{X}, X)) \\[3mm]
+\sem{\emptyCxt}                    & = \One \\
+\sem{\Gamma, x : \tau}             & = \sem{\Gamma} \times T(\sem{\tau})
+\end{align*}
+Context entries are $T$-wrapped because in CBN every variable is a thunk. Substitution commutes
+with the interpretation:
+\[
+\sem{\subst{\tau}{\sigma}{\alpha}} = \sem{\tau}[\sem{\sigma}/\alpha]
+\]
+which is just function composition and so holds by definition.
+
+\subsubsection{Term interpretation}
+\label{sec:slicing-interpretation:moggi-terms}
+
+Following Moggi's CBN convention, a term judgement $\Gamma \vdash t : \tau$ is interpreted as a
+morphism $\sem{t} : \sem{\Gamma} \to T(\sem{\tau})$: terms are computations producing values of
+type $\tau$.
+\begin{align*}
+\sem{x_i}                              & = \pi_i \\
+\sem{\tmUnit}                          & = \eta_{\One} \comp {!_{\sem{\Gamma}}} \\
+\sem{\tmPair{s}{t}}                    & = \eta \comp \prodM{\sem{s}}{\sem{t}} \\
+\sem{\tmFst{s}}                        & = \pi_1^\dagger \comp \sem{s} \\
+\sem{\tmSnd{s}}                        & = \pi_2^\dagger \comp \sem{s} \\
+\sem{\tmInl{s}}                        & = \eta \comp \mathsf{inj}_1 \comp \sem{s} \\
+\sem{\tmInr{s}}                        & = \eta \comp \mathsf{inj}_2 \comp \sem{s} \\
+\sem{\tmCase{s}{x_1}{t_1}{x_2}{t_2}}   & = (\coprodM{\sem{t_1}}{\sem{t_2}} \comp \delta)^\dagger
+                                            \comp \mathsf{st} \comp \prodM{\id}{\sem{s}} \\
+\sem{\tmFun{x}{t}}                     & = \eta \comp \lambda(\sem{t}) \\
+\sem{\tmApp{s}{t}}                     & = \eval^\dagger \comp \mathsf{st} \comp \prodM{\sem{s}}{\sem{t}} \\
+\sem{\phi(t_1, \ldots, t_n)}           & = (\eta \comp \sem{\phi}_{\Op})^\dagger \comp
+                                            \langle\sem{t_1}, \ldots, \sem{t_n}\rangle \\
+\sem{\tmRoll{t}}                       & = (\eta \comp \mathsf{in}_F)^\dagger \comp \sem{t} \\
+\sem{\syn{fold}\,s\,\syn{with}\,x.t}   & = \cata{\sem{t}}_F^T \comp \prodM{\id}{\sem{s}}
+\end{align*}
+Each elimination peels the outer $T$ off the scrutinee using $(-)^\dagger$ to give a Kleisli
+arrow; each introduction composes with $\eta$ at the result. The $\syn{roll}$ clause now needs
+$(\eta \comp \mathsf{in}_F)^\dagger$ rather than just $\mathsf{in}_F \comp \sem{t}$ because the
+source's $\sem{t}$ is $T$-wrapped.
+
+The $\syn{fold}$ clause uses a \emph{monadic} catamorphism $\cata{-}_F^T$, taking the Kleisli
+$F$-algebra $\sem{t} : \sem{\Gamma} \times T(F(\sem{\sigma})) \to T(\sem{\sigma})$ to a
+parameterised Kleisli morphism $\sem{\Gamma} \times T(\mu F) \to T(\sem{\sigma})$. The standard
+constructions for this, namely a distributive law $F \circ T \Rightarrow T \circ F$ or a
+preservation property $T(\mu F) \cong \mu(T \circ F)$, combine the per-position $T$-effects
+across an $F$-structure into a single outer $T$-effect. In contrast to state and partiality,
+where this collapse is precisely the intended semantics, for slicing the per-constructor
+approximation information is the content of the monad, and collapsing it into an outer summary
+defeats the intent. For now we therefore take as a separate assumption that the Kleisli category
+$\cat{D}_T$ has initial algebras for the relevant polynomial endofunctors, without fixing the
+mechanism.
+
+\subsection{Galois slicing interpretation}
+\label{sec:slicing-interpretation:galois}
+
+The Galois slicing semantics puts $T$ at the root of each type former, including primitives:
+\begin{align*}
+\sem{\alpha_i}(\vec{X})            & = X_i \\
+\sem{\rho}(\vec{X})                & = T(\sem{\rho}_{\PrimTy}) \\
+\sem{\tyUnit}(\vec{X})             & = T(\One) \\
+\sem{\sigma \tyProd \tau}(\vec{X}) & = T(\sem{\sigma}(\vec{X}) \times \sem{\tau}(\vec{X})) \\
+\sem{\sigma \tySum \tau}(\vec{X})  & = T(\sem{\sigma}(\vec{X}) + \sem{\tau}(\vec{X})) \\
+\sem{\sigma \tyFun \tau}(\vec{X})  & = T(\sem{\sigma}(\vec{X}) \Rightarrow \sem{\tau}(\vec{X})) \\
+\sem{\mu\alpha.\tau}(\vec{X})      & = \mu(X \mapsto \sem{\tau}(\vec{X}, X)) \\[3mm]
+\sem{\emptyCxt}                    & = \One \\
+\sem{\Gamma, x : \tau}             & = \sem{\Gamma} \times \sem{\tau}
+\end{align*}
+We do \emph{not} add a further $T$ to context entries: the type interpretation already places $T$
+at the root of each $\tau_i$. The outer $T$ on primitives is not optional: without it,
+eliminations whose result is a base type (e.g.\ $\tmFst M$ with $M : \rho \tyProd \tau$) cannot be
+interpreted, since the Kleisli extension always produces a $T$-wrapped result, with no general
+way to project the outer $T$ off. The placement of $T$ at each constructor root realises
+the per-constructor approximation point of prior Galois slicing work.
+
+\begin{remark}[Lifting degenerates on $\LatConj$]
+\label{rem:slicing-interpretation:no-conjugate-lift}
+On $\LatGal$ the approximation monad $T$ is the lifting that adjoins a bottom. On $\LatConj$ the same
+construction is a comonad, not a monad: its morphisms are pairs of join-preserving maps, on which the
+bottom-adjoining lift is a comonad, whose counit collapses the hole rather than propagating it. It also
+degenerates the disjointness its morphisms depend on.
+Disjointness $x \mathrel{\#} y$ means $x \wedge y \le \bot$, that is $x \wedge y = \bot$ since $\bot$ is
+least. Adjoining a new least element $\bot'$ below the old bottom
+makes $\#$ require $x \wedge y = \bot'$, which embedded meets $\langle a \rangle \wedge \langle b \rangle =
+\langle a \wedge b \rangle$ never reach. So no two embedded elements are disjoint, and the lift retains
+none of the original disjointness.
+\end{remark}
+
+\subsubsection{Term interpretation}
+\label{sec:slicing-interpretation:terms}
+
+A term judgement $\Gamma \vdash t : \tau$ is interpreted as a morphism $\sem{t} : \sem{\Gamma} \to
+\sem{\tau}$. Write $f^\dagger = \mu \comp T(f) : T(X) \to T(Y)$ for the Kleisli extension of $f :
+X \to T(Y)$, with the convention that for $n$-ary $f : X_1 \times \cdots \times X_n \to T(Y)$,
+the same notation $f^\dagger : T(X_1) \times \cdots \times T(X_n) \to T(Y)$ denotes the $n$-ary
+generalisation, defined by iterating the unary case with strength. Introductions compose with
+$\eta$; eliminations take the Kleisli extension of the underlying operation, using strength
+where needed. Unlike the Moggi semantics (\secref{slicing-interpretation:moggi-terms}),
+the $\syn{fold}$ clause here takes a plain $F$-algebra $\sem{t} : \sem{\Gamma} \times F(\sem{\sigma}) \to
+\sem{\sigma}$ and uses the standard catamorphism, so the issue of collapsing per-constructor
+approximations under fold does not arise.
+
+\begin{align*}
+\sem{x_i}                              & = \pi_i \\
+\sem{\tmUnit}                          & = \eta_{\One} \comp {!_{\sem{\Gamma}}} \\
+\sem{\tmPair{s}{t}}                    & = \eta_{\sem{\sigma}\times\sem{\tau}} \comp
+                                            \prodM{\sem{s}}{\sem{t}} \\
+\sem{\tmFst{s}}                        & = \pi_1^\dagger \comp \sem{s} \\
+\sem{\tmSnd{s}}                        & = \pi_2^\dagger \comp \sem{s} \\
+\sem{\tmInl{s}}                        & = \eta_{\sem{\sigma}+\sem{\tau}} \comp \mathsf{inj}_1
+                                            \comp \sem{s} \\
+\sem{\tmInr{s}}                        & = \eta_{\sem{\sigma}+\sem{\tau}} \comp \mathsf{inj}_2
+                                            \comp \sem{s} \\
+\sem{\tmCase{s}{x_1}{t_1}{x_2}{t_2}}   & = (\coprodM{\sem{t_1}}{\sem{t_2}} \comp \delta)^\dagger \comp
+                                            \mathsf{st}_{\sem{\Gamma}, \sem{\sigma_1}+\sem{\sigma_2}}
+                                            \comp \prodM{\id}{\sem{s}} \\
+\sem{\tmFun{x}{t}}                     & = \eta_{\sem{\sigma}\Rightarrow\sem{\tau}} \comp \lambda(\sem{t}) \\
+\sem{\tmApp{s}{t}}                     & = \eval^\dagger \comp
+                                            \mathsf{st}_{\sem{\sigma}\Rightarrow\sem{\tau}, \sem{\sigma}}
+                                            \comp \prodM{\sem{s}}{\sem{t}} \\
+\sem{\phi(t_1, \ldots, t_n)}           & = (\eta_{\sem{\rho}_{\PrimTy}} \comp \sem{\phi}_{\Op})^\dagger
+                                            \comp \langle\sem{t_1}, \ldots, \sem{t_n}\rangle \\
+\sem{\tmRoll{t}}                       & = \mathsf{in}_F \comp \sem{t} \\
+\sem{\syn{fold}\,s\,\syn{with}\,x.t}   & = \cata{\sem{t}}_F \comp \prodM{\id}{\sem{s}}
+\end{align*}
+
+In the $\syn{case}$ clause, $\delta : \sem{\Gamma} \times (\sem{\sigma_1}+\sem{\sigma_2}) \to
+(\sem{\Gamma}\times\sem{\sigma_1}) + (\sem{\Gamma}\times\sem{\sigma_2})$ is the distributivity
+isomorphism. In the $\syn{roll}$ and $\syn{fold}$ clauses, for a type $\mu\alpha.\tau$, $F$ is
+the endofunctor $X \mapsto \sem{\tau}[X/\alpha]$ on $\cat{D}$; $\cata{-}_F$ denotes the
+parameterised catamorphism it induces, which exists by initiality of $\mu F$ together with the
+exponential structure of $\cat{D}$, used to internalise the $\Gamma$-parameter via currying.
+
diff --git a/old/examples/alga-examples/src/DEPRECATED b/old/examples/alga-examples/src/DEPRECATED
new file mode 100644
index 00000000..d565a21d
--- /dev/null
+++ b/old/examples/alga-examples/src/DEPRECATED
@@ -0,0 +1,86 @@
+
+-- Unused functions from prior versions of the code
+-- Add edge within state
+addEdge :: forall a. a -> a -> State (Graph a) (Graph a)
+addEdge s t = state (\g -> let e = edge s t in Tuple e (overlay g e))
+
+addNode :: forall a. a -> State (Graph a) (Graph a)
+addNode n = state (\g -> let newV = Vertex n in Tuple newV (overlay g newV))
+
+addVertex :: Graph Int -> Int -> Array Int -> Tuple (Graph Int) (Graph Int)
+addVertex prevGraph newNodeId neighbours = Tuple diffGraph newGraph
+  where
+    diffGraph = connect (vertex newNodeId) (vertices (fromArray neighbours))
+    newGraph  = overlay prevGraph diffGraph
+
+-- Initial attempt at wrapping addvertex in StateT, pointless
+addVertexST :: Graph Int -> Int -> Array Int -> StateT (Graph Int) Effect (Graph Int)
+addVertexST prev newId neighbours = state (\_ -> Tuple newEdges newGraph)
+  where
+    newEdges = (connect (vertex newId) (vertices (fromArray neighbours)))
+    newGraph = overlay prev newEdges
+
+-- 2 versions which don't work but pass typechecker
+baNewnode :: Graph Int -> Int -> StateT (Graph Int) Effect (Graph Int)
+baNewnode prev m =
+  let
+    normalizer      = edgeCount prev
+    newId           = 1 + (vertexCount prev)
+    degrees         = fromFoldable (values (outDegrees prev))
+  in do
+    neighbours <- liftEffect $ newNeighbours (vertexCount prev) normalizer degrees m
+    addVertexST prev newId neighbours
+
+baNewnode' :: Int -> Graph Int -> StateT (Graph Int) Effect (Graph Int)
+baNewnode' m prev =
+  let
+    normalizer      = edgeCount prev
+    newId           = 1 + (vertexCount prev)
+    degrees         = fromFoldable (values (outDegrees prev))
+  in do
+    neighbours <- liftEffect $ newNeighbours (vertexCount prev) normalizer degrees m
+    let
+      diffGraph = outStarG newId neighbours
+      newGraph  = overlay diffGraph
+    state (\s -> Tuple diffGraph (newGraph s))
+
+-- typechecking the newNeighbours function, as I was getting errors in the monad stack
+neighboursTT :: Int -> Graph Int ->  Effect (Array Int)
+neighboursTT m prev =
+  let
+    normalizer      = edgeCount prev
+    -- newId           = 1 + (vertexCount prev)
+    degrees         = fromFoldable (values (outDegrees prev))
+  in do
+    neighbours <- newNeighbours (vertexCount prev) normalizer degrees m
+    pure neighbours
+
+
+
+
+-- Next 2 functions are versions of the code which should work to simulate the barabasi albert model
+newNeighbours :: Int -> Int -> Array Int -> Int -> Effect (Array Int)
+newNeighbours numNodes maxNum nodeDegrees m = do
+  randoms <- replicateA numNodes (randomInt 1 maxNum)        -- imperative random numbers
+  let
+      flags          = compareArrays randoms nodeDegrees     :: Array Boolean
+      selectionPairs = zip nodeDegrees flags                 :: Array (Tuple Int Boolean)
+      selected       = map fst (filter snd selectionPairs)   :: Array Int
+      shuffled       = shuffle selected                      :: Effect (Array Int) -- imperative because of randoms
+  take m <$> shuffled
+
+baNewnode'' :: Int -> (Graph Int -> Effect (Tuple (Graph Int) (Graph Int))) -- State (Graph Int) (Graph Int)
+baNewnode'' m = (\prev ->
+  do
+    let
+      normalizer      = 2 * (edgeCount prev)
+      newId           = 1 + (vertexCount prev)
+      degrees         = fromFoldable (values (totDegrees prev))
+
+    neighbours :: Array Int <- newNeighbours (vertexCount prev) normalizer degrees m
+
+    let
+      diffGraph  = outStarG newId neighbours
+      newGraph  = overlay diffGraph prev -- pure diffGraph
+
+    pure (Tuple (diffGraph) (newGraph)))
\ No newline at end of file
diff --git a/old/examples/alga-examples/src/Graph.Utils/Monads.purs b/old/examples/alga-examples/src/Graph.Utils/Monads.purs
new file mode 100644
index 00000000..d7b3b51d
--- /dev/null
+++ b/old/examples/alga-examples/src/Graph.Utils/Monads.purs
@@ -0,0 +1,128 @@
+module Graph.Utils.Monads
+   ( addVertex
+   , baNewNodeST
+   , baRunT
+   , baRunTest
+   , cmpSnd
+   , deltaGraph
+   , inDegrees
+   , newNeighbours
+   , outDegrees
+   , outStarG
+   , shuffle
+   , toAdjacencyMap
+   , totDegrees
+   , printGraph
+   ) where
+
+import Prelude
+
+import Algebra.Graph (Graph, connect, foldg, overlay, transpose, vertex, vertexCount, vertices, clique)
+import Algebra.Graph.AdjacencyMap as AM
+import Algebra.Graph.Internal (fromArray)
+import Control.Monad.Reader (Reader, runReader)
+import Control.Monad.Reader.Trans (ask)
+import Control.Monad.State (StateT, get, put, lift, runStateT)
+import Data.Array (filter, fromFoldable, sortBy, take, zip, zipWith, length, unzip)
+import Data.Foldable (foldl)
+import Data.Function (on)
+import Data.List (List)
+import Data.Map (Map, intersectionWith, values)
+import Data.Map.Internal (showTree)
+import Data.Newtype (unwrap)
+import Data.Set (size)
+import Data.Tuple (Tuple(..), fst, snd)
+import Data.Unfoldable (replicateA)
+import Effect (Effect)
+import Effect.Console (log)
+import Random.PseudoRandom (Seed, mkSeed, randomRs)
+
+cmpSnd :: forall a. Tuple a Number -> Tuple a Number -> Ordering
+cmpSnd = compare `on` snd
+
+shuffle :: forall a. Array a -> Reader Seed (Array a)
+shuffle xs = do
+   seed <- ask
+   let
+      randomDraws = randomRs 0.0 1.0 (length xs) seed :: Array Number
+      zipped = zip xs randomDraws :: Array (Tuple a Number)
+   pure (fst (unzip (sortBy cmpSnd zipped)))
+
+-- compareNonEmptys :: NonEmptyArray Int -> NonEmptyArray Int -> NonEmptyArray Boolean
+-- compareNonEmptys xs ys = zipWith (>=) xs ys
+
+newNeighbours :: Array Int -> Int -> Reader Seed (Array Int)
+newNeighbours nodeDegrees m = do
+   seed <- ask
+   let
+      numNodes = length nodeDegrees
+      maxNum = foldl (+) 0 nodeDegrees
+      randomDraws = randomRs 1 maxNum numNodes seed -- imperative random numbers
+      flags = zipWith (>=) randomDraws nodeDegrees :: Array Boolean
+      selectionPairs = zip nodeDegrees flags :: Array (Tuple Int Boolean)
+      selected = fst (unzip (filter snd selectionPairs)) :: Array Int
+      shuffled = shuffle selected
+   take m <$> shuffled
+
+deltaGraph :: Int -> Graph Int -> Reader Seed (Graph Int) -- State (Graph Int) (Graph Int)
+deltaGraph m prev =
+   do
+      let
+         newId = 1 + (vertexCount prev)
+         degrees = fromFoldable (values (totDegrees prev)) -- Array Integers
+      neighbours :: Array Int <- newNeighbours degrees m
+      let
+         diffGraph = outStarG newId neighbours
+      pure diffGraph
+
+baNewNodeST :: Int -> StateT (Graph Int) (Reader Seed) (Graph Int)
+baNewNodeST m = do
+   prev <- get
+   diffNew <- lift (deltaGraph m prev)
+   let
+      newGraph = overlay prev diffNew
+   put newGraph
+   pure diffNew
+
+baRunT ∷ Int → Int → Graph Int -> Seed → Tuple (List (Graph Int)) (Graph Int)
+baRunT m numSteps initG seed =
+   runReader (runStateT (replicateA numSteps (baNewNodeST m)) initG) seed
+
+printGraph :: Graph Int -> Effect Unit
+printGraph = toAdjacencyMap >>> unwrap >>> showTree >>> log
+
+-- test m initial = runStateT (baNewNodeST m) initial
+
+-- Utilities Which Make deltaGraph and baNewNodeST work
+-- Needed to reexport these for constructing degree functions
+toAdjacencyMap :: forall a. Ord a => Graph a -> AM.AdjacencyMap a
+toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect
+
+outDegrees :: forall a. Ord a => Graph a -> Map a Int
+outDegrees g = map size (unwrap (toAdjacencyMap g))
+
+inDegrees :: forall a. Ord a => Graph a -> Map a Int
+inDegrees = transpose >>> outDegrees
+
+totDegrees :: forall a. Ord a => Graph a -> Map a Int
+totDegrees g = intersectionWith (+) (inDegrees g) (outDegrees g)
+
+-- deltaGraph construction
+outStarG :: Int -> Array Int -> Graph Int
+outStarG newId neighbours = connect (vertex newId) (vertices (fromArray neighbours))
+
+-- version required for test case in test/Main.purs
+addVertex :: Graph Int -> Int -> Array Int -> Tuple (Graph Int) (Graph Int)
+addVertex prevGraph newNodeId neighbours = Tuple diffGraph newGraph
+   where
+   diffGraph = connect (vertex newNodeId) (vertices (fromArray neighbours))
+   newGraph = overlay prevGraph diffGraph
+
+baRunTest :: Int -> Int -> Int -> Map Int Int
+baRunTest m t seedI =
+   let
+      seed = mkSeed seedI
+      initGraph = clique (fromArray [ 1, 2, 3, 4 ])
+      outGraph = baRunT m t initGraph seed
+   in
+      totDegrees $ snd outGraph
diff --git a/old/examples/alga-examples/src/Graph.Utils/Run.purs b/old/examples/alga-examples/src/Graph.Utils/Run.purs
new file mode 100644
index 00000000..4c59a75c
--- /dev/null
+++ b/old/examples/alga-examples/src/Graph.Utils/Run.purs
@@ -0,0 +1,129 @@
+module Graph.Utils.Run
+   ( addVertex
+   , baNewNodeST
+   , baRunT
+   , baRunTest
+   , cmpSnd
+   , deltaGraph
+   , inDegrees
+   , newNeighbours
+   , outDegrees
+   , outStarG
+   , shuffle
+   , toAdjacencyMap
+   , totDegrees
+   , printGraph
+   ) where
+
+import Prelude
+
+import Algebra.Graph (Graph, connect, foldg, overlay, transpose, vertex, vertexCount, vertices, clique)
+import Algebra.Graph.AdjacencyMap as AM
+import Algebra.Graph.Internal (fromArray)
+import Run (Run, extract)
+import Run.Reader (READER, runReader, ask)
+import Run.State (STATE, get, put, runState)
+import Type.Row (type (+))
+import Data.Array (filter, fromFoldable, sortBy, take, zip, zipWith, length, unzip)
+import Data.Foldable (foldl)
+import Data.Function (on)
+import Data.List (List)
+import Data.Map (Map, intersectionWith, values)
+import Data.Map.Internal (showTree)
+import Data.Newtype (unwrap)
+import Data.Set (size)
+import Data.Tuple (Tuple(..), fst, snd)
+import Data.Unfoldable (replicateA)
+import Effect (Effect)
+import Effect.Console (log)
+import Random.PseudoRandom (Seed, mkSeed, randomRs)
+
+cmpSnd :: forall a. Tuple a Number -> Tuple a Number -> Ordering
+cmpSnd = compare `on` snd
+
+shuffle :: forall a r. Array a -> Run (READER Seed + r) (Array a)
+shuffle xs = do
+   seed <- ask
+   let
+      randomDraws = randomRs 0.0 1.0 (length xs) seed :: Array Number
+      zipped = zip xs randomDraws :: Array (Tuple a Number)
+   pure (fst (unzip (sortBy cmpSnd zipped)))
+
+-- compareNonEmptys :: NonEmptyArray Int -> NonEmptyArray Int -> NonEmptyArray Boolean
+-- compareNonEmptys xs ys = zipWith (>=) xs ys
+
+newNeighbours :: forall r. Array Int -> Int -> Run (READER Seed + r) (Array Int)
+newNeighbours nodeDegrees m = do
+   seed <- ask
+   let
+      numNodes = length nodeDegrees
+      maxNum = foldl (+) 0 nodeDegrees
+      randomDraws = randomRs 1 maxNum numNodes seed -- imperative random numbers
+      flags = zipWith (>=) randomDraws nodeDegrees :: Array Boolean
+      selectionPairs = zip nodeDegrees flags :: Array (Tuple Int Boolean)
+      selected = fst (unzip (filter snd selectionPairs)) :: Array Int
+      shuffled = shuffle selected
+   take m <$> shuffled
+
+deltaGraph :: forall r. Int -> Graph Int -> Run (READER Seed + r) (Graph Int) -- State (Graph Int) (Graph Int)
+deltaGraph m prev =
+   do
+      let
+         newId = 1 + (vertexCount prev)
+         degrees = fromFoldable (values (totDegrees prev)) -- Array Integers
+      neighbours :: Array Int <- newNeighbours degrees m
+      let
+         diffGraph = outStarG newId neighbours
+      pure diffGraph
+
+baNewNodeST :: forall r. Int -> Run (READER Seed + STATE (Graph Int) + r) (Graph Int)
+baNewNodeST m = do
+   prev <- get
+   diffNew <- deltaGraph m prev
+   let
+      newGraph = overlay prev diffNew
+   put newGraph
+   pure diffNew
+
+baRunT ∷ Int → Int → Graph Int -> Seed → Tuple (Graph Int) (List (Graph Int))
+baRunT m numSteps initG seed =
+   extract $ runReader seed (runState initG (replicateA numSteps (baNewNodeST m)))
+
+printGraph :: Graph Int -> Effect Unit
+printGraph = toAdjacencyMap >>> unwrap >>> showTree >>> log
+
+-- test m initial = runStateT (baNewNodeST m) initial
+
+-- Utilities Which Make deltaGraph and baNewNodeST work
+-- Needed to reexport these for constructing degree functions
+toAdjacencyMap :: forall a. Ord a => Graph a -> AM.AdjacencyMap a
+toAdjacencyMap = foldg AM.empty AM.vertex AM.overlay AM.connect
+
+outDegrees :: forall a. Ord a => Graph a -> Map a Int
+outDegrees g = map size (unwrap (toAdjacencyMap g))
+
+inDegrees :: forall a. Ord a => Graph a -> Map a Int
+inDegrees = transpose >>> outDegrees
+
+totDegrees :: forall a. Ord a => Graph a -> Map a Int
+totDegrees g = intersectionWith (+) (inDegrees g) (outDegrees g)
+
+-- deltaGraph construction
+outStarG :: Int -> Array Int -> Graph Int
+outStarG newId neighbours = connect (vertex newId) (vertices (fromArray neighbours))
+
+-- version required for test case in test/Main.purs
+addVertex :: Graph Int -> Int -> Array Int -> Tuple (Graph Int) (Graph Int)
+addVertex prevGraph newNodeId neighbours = Tuple diffGraph newGraph
+   where
+   diffGraph = connect (vertex newNodeId) (vertices (fromArray neighbours))
+   newGraph = overlay prevGraph diffGraph
+
+baRunTest :: Int -> Int -> Int -> Map Int Int
+baRunTest m t seedI =
+   let
+      seed = mkSeed seedI
+      initGraph = clique (fromArray [ 1, 2, 3, 4 ])
+      outGraph = baRunT m t initGraph seed
+   in
+      totDegrees $ fst outGraph
diff --git a/old/examples/alga-examples/src/Main.purs b/old/examples/alga-examples/src/Main.purs
new file mode 100644
index 00000000..484caf93
--- /dev/null
+++ b/old/examples/alga-examples/src/Main.purs
@@ -0,0 +1,57 @@
+module Main where
+
+import Prelude
+
+import Algebra.Graph (clique)
+import Algebra.Graph.Internal (fromArray)
+import Data.Array (range)
+import Data.Int (fromString)
+import Data.Maybe (Maybe(..))
+import Data.Tuple (fst)
+import Effect (Effect)
+import Effect.Class.Console (logShow)
+import Effect.Console (log)
+import Graph.Utils.Run (baRunT, totDegrees)
+import Node.ReadLine (createConsoleInterface, noCompletion, prompt, setLineHandler, setPrompt, close, question)
+import Random.PseudoRandom (mkSeed)
+
+main :: Effect Unit
+main = do
+   inputInterface <- createConsoleInterface noCompletion
+   setPrompt "> " inputInterface
+   prompt inputInterface
+   log "Begin test?"
+   inputInterface # setLineHandler \s ->
+      if s == "quit" then
+         close inputInterface
+      else do
+         inputInterface # question "How many initial nodes do you want? " \initN -> do
+            let
+               list = case fromString initN of
+                  Just n -> fromArray $ range 1 n
+                  Nothing -> fromArray $ range 1 10
+
+               initGraph = clique list
+            -- log "T = 0"
+            -- logShow (totDegrees initGraph)
+            inputInterface # question "How many edges will a new node be connected to? " \m -> do
+               inputInterface # question "What is the seed for random number generation? " \inpSeed -> do
+                  let
+                     initSeed = mkSeed case fromString inpSeed of
+                        Just n -> n
+                        Nothing -> 1234598134
+                  inputInterface # question "How many timesteps should the code run for? " \t -> do
+                     let
+                        m' = case fromString m of
+                           Just n' -> n'
+                           Nothing -> 3
+                        t' = case fromString t of
+                           Just k' -> k'
+                           Nothing -> 20
+                        graphOne = baRunT m' t' initGraph initSeed
+                        graphTwo = baRunT m' t' initGraph initSeed
+                     log ("T = " <> t)
+                     logShow (totDegrees $ fst graphOne)
+                     logShow (graphTwo == graphOne)
+                     log "Test complete, start again?"
+--printGraph (snd graphOne)
diff --git a/old/examples/alga-examples/src/Talk.purs b/old/examples/alga-examples/src/Talk.purs
new file mode 100644
index 00000000..2f9b8ca1
--- /dev/null
+++ b/old/examples/alga-examples/src/Talk.purs
@@ -0,0 +1,70 @@
+module Talk where
+
+import Prelude
+
+data MGraph a
+   = Empty
+   | Vertex a
+   | Overlay (MGraph a) (MGraph a)
+   | Connect (MGraph a) (MGraph a)
+
+empty :: forall a. MGraph a
+empty = Empty
+
+vertex :: forall a. a -> MGraph a
+vertex = Vertex
+
+overlay :: forall a. MGraph a -> MGraph a -> MGraph a
+overlay = Overlay
+
+connect :: forall a. MGraph a -> MGraph a -> MGraph a
+connect = Connect
+
+edge :: forall a. a -> a -> MGraph a
+edge x y = connect (vertex x) (vertex y)
+
+-- | Generalised 'Graph' folding: recursively collapse a 'Graph' by applying
+-- | the provided functions to the leaves and internal nodes of the expression.
+-- | The order of arguments is: empty, vertex, overlay and connect.
+foldg :: forall a b. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> MGraph a -> b
+foldg e v o c = go
+   where
+   go = case _ of
+      Empty -> e
+      Vertex x -> v x
+      Overlay x y -> o (go x) (go y)
+      Connect x y -> c (go x) (go y)
+
+isEmpty :: forall a. MGraph a -> Boolean
+isEmpty = foldg true (const false) (&&) (&&)
+
+size :: forall a. MGraph a -> Int
+size = foldg 1 (const 1) (+) (+)
+
+-- | We almost have that Graph satisfies the axioms of a semiring, it is a semiring without
+-- | multiplicative inverse and with a new decomposition law. Taking + to be overlay,
+-- | and connect to be * we obtain:
+-- | (Graph, +):
+-- | (a + b) + c = a + (b + c), by structuralEquality
+-- | Empty + a = a = a + Empty
+-- | a + b = b + a, by structuralEquality
+-- | (Graph, *):
+-- | (a * b) * c = a * (b * c), by structuralEquality
+-- | (Empty * a) = a = (a*Empty)
+-- | (Graph,+,*)
+-- | a * (b + c) = (a * b) + (a * c)
+-- | (a + b) * c = (a * c) + (b * c)
+-- | We do not have an annihilation law, ie: connect Empty a != 0 != connect a Empty
+-- | Instead we have:
+-- | x * y * z = (x * y) + (x * z) + (y * z)
+
+type Name =
+   { firstName :: String
+   , surname :: String
+   }
+
+addSuffixJr :: forall r. { surname :: String | r } -> { surname :: String | r }
+addSuffixJr record = record { surname = record.surname <> " Jr." }
+
+data Either a b = Left a | Right b
+data Either3 a b c = Left3 a | Middle3 b | Right3 c
\ No newline at end of file
diff --git a/old/examples/alga-examples/test/Main.purs b/old/examples/alga-examples/test/Main.purs
new file mode 100644
index 00000000..fc4fe8bc
--- /dev/null
+++ b/old/examples/alga-examples/test/Main.purs
@@ -0,0 +1,24 @@
+module Test.Main where
+
+import Prelude
+
+import Algebra.Graph (Graph(..), edgeList, clique)
+import Algebra.Graph.Internal (fromArray)
+import Data.List.Types (List(..), (:))
+import Data.Map (fromFoldable)
+import Data.Tuple (Tuple(..), snd)
+import Effect (Effect)
+import Graph.Utils.Monads (addVertex, baRunTest, outDegrees)
+import Test.Unit (suite, test)
+import Test.Unit.Assert as Assert
+import Test.Unit.Main (runTest)
+
+main :: Effect Unit
+main = runTest do
+   suite "graph utils" do
+      test "Correctness of addVertex" do
+         Assert.equal (edgeList (snd (addVertex Empty 1 [ 2, 3, 4, 5 ]))) (fromArray [ (Tuple 1 2), (Tuple 1 3), (Tuple 1 4), (Tuple 1 5) ])
+      test "outDegrees correct" do -- odd, due to the directional nature of the graphs
+         Assert.equal (outDegrees (clique (fromArray [ 1, 2, 3, 4 ]))) (fromFoldable ((Tuple 1 3) : (Tuple 2 2) : (Tuple 3 1) : (Tuple 4 0) : Nil))
+      test "baRunTest correct" do
+         Assert.equal (show $ baRunTest 3 20 1234598134) ("(fromFoldable [(Tuple 1 4),(Tuple 2 6),(Tuple 3 21),(Tuple 4 17),(Tuple 5 2),(Tuple 6 16),(Tuple 7 3),(Tuple 8 2),(Tuple 9 2),(Tuple 10 3),(Tuple 11 3),(Tuple 12 3),(Tuple 13 3),(Tuple 14 3),(Tuple 15 3),(Tuple 16 3),(Tuple 17 3),(Tuple 18 3),(Tuple 19 3),(Tuple 20 3),(Tuple 21 2),(Tuple 22 2),(Tuple 23 2),(Tuple 24 2)])")
diff --git a/old/examples/hgraphs/CHANGELOG.md b/old/examples/hgraphs/CHANGELOG.md
new file mode 100644
index 00000000..94aadba7
--- /dev/null
+++ b/old/examples/hgraphs/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for hgraphs
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/old/examples/hgraphs/app/Main.hs b/old/examples/hgraphs/app/Main.hs
new file mode 100644
index 00000000..a2f1c615
--- /dev/null
+++ b/old/examples/hgraphs/app/Main.hs
@@ -0,0 +1,84 @@
+{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}
+module Main where
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+import Data.Graph
+import Data.List (elemIndices)
+import Text.Read hiding (lift)
+import Control.Monad
+import Data.Functor.Identity
+import Control.Monad.Trans
+import Control.Applicative
+import Data.Char (isAlpha, isNumber, isPunctuation)
+import GHC.Arr
+import System.Random
+import Control.Monad.Trans.State.Lazy
+type EdgeList = [(Int, Int)]
+
+
+main :: IO Graph
+main = do
+    putStrLn "How many nodes does your graph have? "
+    max <- read <$> getLine 
+    putStrLn "Input your edges: "
+    let edges = graphBuild
+    let out = buildG (0, max) <$> edges
+    out
+
+
+graphBuild :: IO EdgeList
+graphBuild = graphBuildInner []
+
+-- Initial construction with single monad
+graphBuildInner :: EdgeList -> IO EdgeList
+graphBuildInner g = do
+    putStrLn "Edge source:"
+    source <- read <$> getLine
+    putStrLn "Edge sink: "
+    sink <- read <$> getLine
+    let edge = (source, sink) :: (Int, Int)
+    if edge == (0,0) then 
+        pure g
+    else
+        graphBuildInner (g ++ [edge])
+
+probsToArray :: [Float] -> (Int, Int) -> Array Int Float
+probsToArray list bounds = listArray bounds list
+
+probsToEdges :: Int -> [Bool] -> [(Int, Int)]
+probsToEdges newId flags = 
+    let edgeIds = elemIndices True flags in
+    map (\x -> (newId, x)) edgeIds
+
+-- StateT Graph IO [(Int, Int)]
+baUpdate :: StateT Graph IO [Edge]
+baUpdate = do 
+    g <- Control.Monad.Trans.State.Lazy.get 
+    
+    let vertId = (length . vertices) g
+        normalizer :: Float
+        normalizer = fromIntegral (((* 2) . length . edges) g)
+        probs = fmap (\deg -> fromIntegral deg / normalizer) (arraySum (indegree g) (outdegree g))
+        probsL = elems probs
+    
+    randoms <- replicateM (vertId - 1) (randomIO :: StateT Graph IO Float)
+    
+    let prPairs = zip randoms probsL
+        newEdgeFlags = map (uncurry (<)) prPairs
+        newEdges = probsToEdges vertId newEdgeFlags
+        newEdges' = edges g ++ newEdges     -- These 2 lines may need to be changed 
+        newG = buildG (0, vertId) newEdges' --
+    put newG
+    return newEdges
+
+-- Barabasi-Albert Model will use StateT around IO, soon
+barabasiAlbert :: Graph -> Int -> IO ([[(Int, Int)]], Graph)
+barabasiAlbert g i = 
+    runStateT (replicateM i baUpdate) g
+
+-- Does slightly invite the question of why we need the state in this scenario
+
+arraySum :: Array Vertex Int -> Array Vertex Int -> [Int]
+arraySum a1 a2 =
+    zipWith (+) (elems a1) (elems a2)
\ No newline at end of file
diff --git a/old/examples/hgraphs/app/extrabits.hs b/old/examples/hgraphs/app/extrabits.hs
new file mode 100644
index 00000000..19db71df
--- /dev/null
+++ b/old/examples/hgraphs/app/extrabits.hs
@@ -0,0 +1,81 @@
+
+getPassphrase :: MaybeT IO String
+getPassphrase = do 
+    s <- lift getLine
+    guard (isValid s)
+    return s
+
+isValid :: String -> Bool
+isValid s = length s >= 8
+    &&  any isAlpha s
+    && any isNumber s
+    && any isPunctuation s
+
+askPassphrase :: MaybeT IO ()
+askPassphrase = do
+    lift $ putStrLn "Insert passphrase:"
+    val <- msum $ repeat getPassphrase
+    lift $ putStrLn "Storing pw"
+
+-- Transformer bit
+newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
+newtype IdentityT f a = IdentityT { runIdentityT :: f a }
+
+
+instance Monad m => Functor (IdentityT m) where
+    fmap = liftM
+instance Monad a => Applicative (IdentityT a) where 
+    pure x = IdentityT (pure x)
+    (<*>) = ap
+instance Monad m => Monad (IdentityT m) where
+    return = IdentityT . return
+    x >>= f = IdentityT $ runIdentityT . f =<< runIdentityT x
+instance MonadTrans IdentityT where
+    lift = IdentityT 
+instance Monad m => Monad (MaybeT m) where
+    return = MaybeT . return . Just
+    x >>= f = MaybeT $ do maybe_value <- runMaybeT x
+                          case maybe_value of 
+                            Nothing -> return Nothing
+                            Just val -> runMaybeT $ f val
+
+instance Monad m => Applicative (MaybeT m) where
+    pure x = return x
+    (<*>) = ap
+
+instance Monad m => Functor (MaybeT m) where
+    fmap = liftM
+
+instance Monad m => Alternative (MaybeT m) where
+    empty = MaybeT $ return Nothing
+    x <|> y = MaybeT $ do maybe_value <- runMaybeT x
+                          case maybe_value of 
+                            Nothing -> runMaybeT y
+                            Just _ -> return maybe_value
+
+instance Monad m => MonadPlus (MaybeT m) where
+    mzero = empty
+    mplus = (<|>)
+
+instance MonadTrans MaybeT where
+    lift = MaybeT . liftM Just
+
+-- StateT section
+newtype StateT s m a = StateT { runStateT :: s -> m (a, s) }
+
+instance Functor m => Functor (StateT s m) where
+    fmap f m = StateT $ \s ->
+        (\ ~(a, s') -> (f a, s')) <$> runStateT m s
+
+instance (Functor m, Monad m) => Applicative (StateT s m) where
+    pure a = StateT $ \s -> return (a, s)
+    StateT mf <*> StateT mx = StateT $ \s -> -- take the initial state s
+        do
+            ~(f, s') <- mf s -- wraps s as m (f: a -> b, s' : s)
+            ~(x, s'') <- mx s' -- takes s', updates it after running mx action
+            return (f x, s'') -- apply the bound f to the action x, return this, as well as updated state
+instance Monad m => Monad (StateT s m) where
+    return a = StateT $ \s -> return (a, s)
+    (StateT x) >>= f = StateT $ \s -> do
+        (v, s') <- x s
+        runStateT (f v) s'
\ No newline at end of file
diff --git a/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/build/hgraphs/autogen/Paths_hgraphs.hs b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/build/hgraphs/autogen/Paths_hgraphs.hs
new file mode 100644
index 00000000..b93c630c
--- /dev/null
+++ b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/build/hgraphs/autogen/Paths_hgraphs.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoRebindableSyntax #-}
+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}
+{-# OPTIONS_GHC -w #-}
+module Paths_hgraphs (
+    version,
+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,
+    getDataFileName, getSysconfDir
+  ) where
+
+
+import qualified Control.Exception as Exception
+import qualified Data.List as List
+import Data.Version (Version(..))
+import System.Environment (getEnv)
+import Prelude
+
+
+#if defined(VERSION_base)
+
+#if MIN_VERSION_base(4,0,0)
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#else
+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a
+#endif
+
+#else
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#endif
+catchIO = Exception.catch
+
+version :: Version
+version = Version [0,1,0,0] []
+
+getDataFileName :: FilePath -> IO FilePath
+getDataFileName name = do
+  dir <- getDataDir
+  return (dir `joinFileName` name)
+
+getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath
+
+
+
+bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath
+bindir     = "/home/oz20977/.cabal/bin"
+libdir     = "/home/oz20977/.cabal/lib/x86_64-linux-ghc-9.2.4/hgraphs-0.1.0.0-inplace-hgraphs"
+dynlibdir  = "/home/oz20977/.cabal/lib/x86_64-linux-ghc-9.2.4"
+datadir    = "/home/oz20977/.cabal/share/x86_64-linux-ghc-9.2.4/hgraphs-0.1.0.0"
+libexecdir = "/home/oz20977/.cabal/libexec/x86_64-linux-ghc-9.2.4/hgraphs-0.1.0.0"
+sysconfdir = "/home/oz20977/.cabal/etc"
+
+getBinDir     = catchIO (getEnv "hgraphs_bindir")     (\_ -> return bindir)
+getLibDir     = catchIO (getEnv "hgraphs_libdir")     (\_ -> return libdir)
+getDynLibDir  = catchIO (getEnv "hgraphs_dynlibdir")  (\_ -> return dynlibdir)
+getDataDir    = catchIO (getEnv "hgraphs_datadir")    (\_ -> return datadir)
+getLibexecDir = catchIO (getEnv "hgraphs_libexecdir") (\_ -> return libexecdir)
+getSysconfDir = catchIO (getEnv "hgraphs_sysconfdir") (\_ -> return sysconfdir)
+
+
+
+
+joinFileName :: String -> String -> FilePath
+joinFileName ""  fname = fname
+joinFileName "." fname = fname
+joinFileName dir ""    = dir
+joinFileName dir fname
+  | isPathSeparator (List.last dir) = dir ++ fname
+  | otherwise                       = dir ++ pathSeparator : fname
+
+pathSeparator :: Char
+pathSeparator = '/'
+
+isPathSeparator :: Char -> Bool
+isPathSeparator c = c == '/'
diff --git a/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/build/hgraphs/autogen/cabal_macros.h b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/build/hgraphs/autogen/cabal_macros.h
new file mode 100644
index 00000000..42fc591a
--- /dev/null
+++ b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/build/hgraphs/autogen/cabal_macros.h
@@ -0,0 +1,170 @@
+/* DO NOT EDIT: This file is automatically generated by Cabal */
+
+/* package hgraphs-0.1.0.0 */
+#ifndef VERSION_hgraphs
+#define VERSION_hgraphs "0.1.0.0"
+#endif /* VERSION_hgraphs */
+#ifndef MIN_VERSION_hgraphs
+#define MIN_VERSION_hgraphs(major1,major2,minor) (\
+  (major1) <  0 || \
+  (major1) == 0 && (major2) <  1 || \
+  (major1) == 0 && (major2) == 1 && (minor) <= 0)
+#endif /* MIN_VERSION_hgraphs */
+/* package base-4.16.3.0 */
+#ifndef VERSION_base
+#define VERSION_base "4.16.3.0"
+#endif /* VERSION_base */
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(major1,major2,minor) (\
+  (major1) <  4 || \
+  (major1) == 4 && (major2) <  16 || \
+  (major1) == 4 && (major2) == 16 && (minor) <= 3)
+#endif /* MIN_VERSION_base */
+/* package containers-0.6.6 */
+#ifndef VERSION_containers
+#define VERSION_containers "0.6.6"
+#endif /* VERSION_containers */
+#ifndef MIN_VERSION_containers
+#define MIN_VERSION_containers(major1,major2,minor) (\
+  (major1) <  0 || \
+  (major1) == 0 && (major2) <  6 || \
+  (major1) == 0 && (major2) == 6 && (minor) <= 6)
+#endif /* MIN_VERSION_containers */
+/* package effectful-2.1.0.0 */
+#ifndef VERSION_effectful
+#define VERSION_effectful "2.1.0.0"
+#endif /* VERSION_effectful */
+#ifndef MIN_VERSION_effectful
+#define MIN_VERSION_effectful(major1,major2,minor) (\
+  (major1) <  2 || \
+  (major1) == 2 && (major2) <  1 || \
+  (major1) == 2 && (major2) == 1 && (minor) <= 0)
+#endif /* MIN_VERSION_effectful */
+/* package mtl-2.2.2 */
+#ifndef VERSION_mtl
+#define VERSION_mtl "2.2.2"
+#endif /* VERSION_mtl */
+#ifndef MIN_VERSION_mtl
+#define MIN_VERSION_mtl(major1,major2,minor) (\
+  (major1) <  2 || \
+  (major1) == 2 && (major2) <  2 || \
+  (major1) == 2 && (major2) == 2 && (minor) <= 2)
+#endif /* MIN_VERSION_mtl */
+/* package random-1.2.1.1 */
+#ifndef VERSION_random
+#define VERSION_random "1.2.1.1"
+#endif /* VERSION_random */
+#ifndef MIN_VERSION_random
+#define MIN_VERSION_random(major1,major2,minor) (\
+  (major1) <  1 || \
+  (major1) == 1 && (major2) <  2 || \
+  (major1) == 1 && (major2) == 2 && (minor) <= 1)
+#endif /* MIN_VERSION_random */
+/* package transformers-0.5.6.2 */
+#ifndef VERSION_transformers
+#define VERSION_transformers "0.5.6.2"
+#endif /* VERSION_transformers */
+#ifndef MIN_VERSION_transformers
+#define MIN_VERSION_transformers(major1,major2,minor) (\
+  (major1) <  0 || \
+  (major1) == 0 && (major2) <  5 || \
+  (major1) == 0 && (major2) == 5 && (minor) <= 6)
+#endif /* MIN_VERSION_transformers */
+
+/* tool gcc-9 */
+#ifndef TOOL_VERSION_gcc
+#define TOOL_VERSION_gcc "9"
+#endif /* TOOL_VERSION_gcc */
+#ifndef MIN_TOOL_VERSION_gcc
+#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\
+  (major1) <  9 || \
+  (major1) == 9 && (major2) <  0 || \
+  (major1) == 9 && (major2) == 0 && (minor) <= 0)
+#endif /* MIN_TOOL_VERSION_gcc */
+/* tool ghc-9.2.4 */
+#ifndef TOOL_VERSION_ghc
+#define TOOL_VERSION_ghc "9.2.4"
+#endif /* TOOL_VERSION_ghc */
+#ifndef MIN_TOOL_VERSION_ghc
+#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\
+  (major1) <  9 || \
+  (major1) == 9 && (major2) <  2 || \
+  (major1) == 9 && (major2) == 2 && (minor) <= 4)
+#endif /* MIN_TOOL_VERSION_ghc */
+/* tool ghc-pkg-9.2.4 */
+#ifndef TOOL_VERSION_ghc_pkg
+#define TOOL_VERSION_ghc_pkg "9.2.4"
+#endif /* TOOL_VERSION_ghc_pkg */
+#ifndef MIN_TOOL_VERSION_ghc_pkg
+#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\
+  (major1) <  9 || \
+  (major1) == 9 && (major2) <  2 || \
+  (major1) == 9 && (major2) == 2 && (minor) <= 4)
+#endif /* MIN_TOOL_VERSION_ghc_pkg */
+/* tool haddock-2.26.0 */
+#ifndef TOOL_VERSION_haddock
+#define TOOL_VERSION_haddock "2.26.0"
+#endif /* TOOL_VERSION_haddock */
+#ifndef MIN_TOOL_VERSION_haddock
+#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\
+  (major1) <  2 || \
+  (major1) == 2 && (major2) <  26 || \
+  (major1) == 2 && (major2) == 26 && (minor) <= 0)
+#endif /* MIN_TOOL_VERSION_haddock */
+/* tool hpc-0.68 */
+#ifndef TOOL_VERSION_hpc
+#define TOOL_VERSION_hpc "0.68"
+#endif /* TOOL_VERSION_hpc */
+#ifndef MIN_TOOL_VERSION_hpc
+#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\
+  (major1) <  0 || \
+  (major1) == 0 && (major2) <  68 || \
+  (major1) == 0 && (major2) == 68 && (minor) <= 0)
+#endif /* MIN_TOOL_VERSION_hpc */
+/* tool hsc2hs-0.68.8 */
+#ifndef TOOL_VERSION_hsc2hs
+#define TOOL_VERSION_hsc2hs "0.68.8"
+#endif /* TOOL_VERSION_hsc2hs */
+#ifndef MIN_TOOL_VERSION_hsc2hs
+#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\
+  (major1) <  0 || \
+  (major1) == 0 && (major2) <  68 || \
+  (major1) == 0 && (major2) == 68 && (minor) <= 8)
+#endif /* MIN_TOOL_VERSION_hsc2hs */
+/* tool pkg-config-0.29.1 */
+#ifndef TOOL_VERSION_pkg_config
+#define TOOL_VERSION_pkg_config "0.29.1"
+#endif /* TOOL_VERSION_pkg_config */
+#ifndef MIN_TOOL_VERSION_pkg_config
+#define MIN_TOOL_VERSION_pkg_config(major1,major2,minor) (\
+  (major1) <  0 || \
+  (major1) == 0 && (major2) <  29 || \
+  (major1) == 0 && (major2) == 29 && (minor) <= 1)
+#endif /* MIN_TOOL_VERSION_pkg_config */
+/* tool runghc-9.2.4 */
+#ifndef TOOL_VERSION_runghc
+#define TOOL_VERSION_runghc "9.2.4"
+#endif /* TOOL_VERSION_runghc */
+#ifndef MIN_TOOL_VERSION_runghc
+#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\
+  (major1) <  9 || \
+  (major1) == 9 && (major2) <  2 || \
+  (major1) == 9 && (major2) == 2 && (minor) <= 4)
+#endif /* MIN_TOOL_VERSION_runghc */
+/* tool strip-2.34 */
+#ifndef TOOL_VERSION_strip
+#define TOOL_VERSION_strip "2.34"
+#endif /* TOOL_VERSION_strip */
+#ifndef MIN_TOOL_VERSION_strip
+#define MIN_TOOL_VERSION_strip(major1,major2,minor) (\
+  (major1) <  2 || \
+  (major1) == 2 && (major2) <  34 || \
+  (major1) == 2 && (major2) == 34 && (minor) <= 0)
+#endif /* MIN_TOOL_VERSION_strip */
+
+#ifndef CURRENT_COMPONENT_ID
+#define CURRENT_COMPONENT_ID "hgraphs-0.1.0.0-inplace-hgraphs"
+#endif /* CURRENT_COMPONENT_ID */
+#ifndef CURRENT_PACKAGE_VERSION
+#define CURRENT_PACKAGE_VERSION "0.1.0.0"
+#endif /* CURRENT_PACKAGE_VERSION */
diff --git a/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/cache/config b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/cache/config
new file mode 100644
index 00000000..b6fe49e6
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/cache/config differ
diff --git a/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/package.conf.inplace/package.cache b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/package.conf.inplace/package.cache
new file mode 100644
index 00000000..b3cae5cf
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/package.conf.inplace/package.cache differ
diff --git a/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/package.conf.inplace/package.cache.lock b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/package.conf.inplace/package.cache.lock
new file mode 100644
index 00000000..e69de29b
diff --git a/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/setup-config b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/setup-config
new file mode 100644
index 00000000..4307ab70
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/setup-config differ
diff --git a/old/examples/hgraphs/dist-newstyle/cache/compiler b/old/examples/hgraphs/dist-newstyle/cache/compiler
new file mode 100644
index 00000000..bf660b40
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/cache/compiler differ
diff --git a/old/examples/hgraphs/dist-newstyle/cache/config b/old/examples/hgraphs/dist-newstyle/cache/config
new file mode 100644
index 00000000..f2569266
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/cache/config differ
diff --git a/old/examples/hgraphs/dist-newstyle/cache/elaborated-plan b/old/examples/hgraphs/dist-newstyle/cache/elaborated-plan
new file mode 100644
index 00000000..9096d9b7
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/cache/elaborated-plan differ
diff --git a/old/examples/hgraphs/dist-newstyle/cache/improved-plan b/old/examples/hgraphs/dist-newstyle/cache/improved-plan
new file mode 100644
index 00000000..0f49d404
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/cache/improved-plan differ
diff --git a/old/examples/hgraphs/dist-newstyle/cache/plan.json b/old/examples/hgraphs/dist-newstyle/cache/plan.json
new file mode 100644
index 00000000..5498bdfd
--- /dev/null
+++ b/old/examples/hgraphs/dist-newstyle/cache/plan.json
@@ -0,0 +1 @@
+{"cabal-version":"3.6.2.0","cabal-lib-version":"3.6.2.0","compiler-id":"ghc-9.2.4","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"array-0.5.4.0","pkg-name":"array","pkg-version":"0.5.4.0","depends":["base-4.16.3.0"]},{"type":"configured","id":"async-2.2.4-c434ffe05cb7c3eb9f2ee4887737c55c63cf3ef81e010c08008ff998f984c99a","pkg-name":"async","pkg-version":"2.2.4","flags":{"bench":false},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"2b9409023536823233ce3134558565d01b3382e651fa54ac8cb8a99967e023c9","pkg-src-sha256":"484df85be0e76c4fed9376451e48e1d0c6e97952ce79735b72d54297e7e0a725","depends":["base-4.16.3.0","hashable-1.4.1.0-8c93d16cc53e4a7135da3566487335a472b3ab08bf2bfcf76447508f91477efe","stm-2.5.0.2"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"base-4.16.3.0","pkg-name":"base","pkg-version":"4.16.3.0","depends":["ghc-bignum-1.2","ghc-prim-0.8.0","rts"]},{"type":"configured","id":"base-orphans-0.8.7-c83ea082e53ae0cf10a8c377f2446fd177f93efec3c5232596a4ce2e2ab0a3dd","pkg-name":"base-orphans","pkg-version":"0.8.7","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"58d5514b688ec037f53b9d60097b9d87f6b3847da68f65124987d67222c3a334","pkg-src-sha256":"888fd67f0dbe932778f5b170922ce80d0dcab1680ee98f1d6fcc362f20d9e447","depends":["base-4.16.3.0","ghc-prim-0.8.0"],"exe-depends":[],"component-name":"lib"},{"type":"configured","id":"binary-0.8.9.1-0668b4c46528bf761ca9a54c4d855dd00c1d8d1d17831a605b336c730adbc320","pkg-name":"binary","pkg-version":"0.8.9.1","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"81f468c1c75fd6535152ab69b2d32ac6cfcc03e345267b069abe4da56ec95801","pkg-src-sha256":"ac21ca63452dfc9b0bcab87c57699c531d87f7a9bcb6230ca46fba1b7faeebc0","depends":["array-0.5.4.0","base-4.16.3.0","bytestring-0.11.3.1","containers-0.6.6-ad701f1f732595158ed449ad9787f34463326e7108d6c3253f455912aca9f80e"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"bytestring-0.11.3.1","pkg-name":"bytestring","pkg-version":"0.11.3.1","depends":["base-4.16.3.0","deepseq-1.4.6.1","ghc-prim-0.8.0","template-haskell-2.18.0.0"]},{"type":"configured","id":"containers-0.6.6-ad701f1f732595158ed449ad9787f34463326e7108d6c3253f455912aca9f80e","pkg-name":"containers","pkg-version":"0.6.6","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"008d007dfff018954e05ecdb8d628d8e32531f7dc3c6bb7e9bd55118c1224514","pkg-src-sha256":"b8190ed1f102d5f3463a8057660357be63167456e80e2755cdead10d510b2ae8","depends":["array-0.5.4.0","base-4.16.3.0","deepseq-1.4.6.1","template-haskell-2.18.0.0"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"deepseq-1.4.6.1","pkg-name":"deepseq","pkg-version":"1.4.6.1","depends":["array-0.5.4.0","base-4.16.3.0"]},{"type":"pre-existing","id":"directory-1.3.6.2","pkg-name":"directory","pkg-version":"1.3.6.2","depends":["base-4.16.3.0","filepath-1.4.2.2","time-1.11.1.1","unix-2.7.2.2"]},{"type":"configured","id":"effectful-2.1.0.0-719009a650276ee7d0281a73a1dd1b8e394641a9c0edc7dcde7b61e9fb6b0746","pkg-name":"effectful","pkg-version":"2.1.0.0","flags":{"benchmark-foreign-libraries":false},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"53b18b9161560cd98a8acec0883df740bf87027f623d58458e9f65adf83c450a","pkg-src-sha256":"76147d4d761d3267607a5f71c5925cbb2e8ae538aacaf6c6ddd9574eabec739b","depends":["async-2.2.4-c434ffe05cb7c3eb9f2ee4887737c55c63cf3ef81e010c08008ff998f984c99a","base-4.16.3.0","bytestring-0.11.3.1","directory-1.3.6.2","effectful-core-2.1.0.0-a584e7708aeb08fcd5cbe5bc9fc351af2b2694622d0fe13bb484a0ff60f10a1f","process-1.6.13.2","stm-2.5.0.2","time-1.11.1.1","unliftio-0.2.22.0-d5bd80364ec545ccd948d1d21e11f779df51efdf23c8fa901d37a047bbcb4bf9"],"exe-depends":[],"component-name":"lib"},{"type":"configured","id":"effectful-core-2.1.0.0-a584e7708aeb08fcd5cbe5bc9fc351af2b2694622d0fe13bb484a0ff60f10a1f","pkg-name":"effectful-core","pkg-version":"2.1.0.0","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"8cb5e4bc3336a1a17eb8689fe8ae4ebecbe5ee8b088794024d68f5a282c0588b","pkg-src-sha256":"93920bb5b58d6c92f51823c95e436a1a35c40fa677ee4f96014267698c43efd1","depends":["base-4.16.3.0","containers-0.6.6-ad701f1f732595158ed449ad9787f34463326e7108d6c3253f455912aca9f80e","effectful-core-2.1.0.0-l-effectful-internal-utils-e2a47b7946c6751db1123713a7a0c000dcff1327016baa70160a855ab840060e","exceptions-0.10.4","monad-control-1.0.3.1-e097f12cd3edc399972905a99bca3a27608065a19c5942fe006ba5490c848b47","primitive-0.7.4.0-0f1f742d00a689edbb81a766aa59acc03aa6a6b05f37ea7b943ad32694c124f6","transformers-base-0.4.6-3e0e9cd113ebeaa61bdcfe3d05dc603287b898e88dc55aec6ace6fe3522eb40d","unliftio-core-0.2.0.1-f248a2f60cc30199e5ef00745c1fc36bddf4f429f77828337c18597f19fa46b6"],"exe-depends":[],"component-name":"lib"},{"type":"configured","id":"effectful-core-2.1.0.0-l-effectful-internal-utils-e2a47b7946c6751db1123713a7a0c000dcff1327016baa70160a855ab840060e","pkg-name":"effectful-core","pkg-version":"2.1.0.0","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"8cb5e4bc3336a1a17eb8689fe8ae4ebecbe5ee8b088794024d68f5a282c0588b","pkg-src-sha256":"93920bb5b58d6c92f51823c95e436a1a35c40fa677ee4f96014267698c43efd1","depends":["base-4.16.3.0"],"exe-depends":[],"component-name":"lib:effectful-internal-utils"},{"type":"pre-existing","id":"exceptions-0.10.4","pkg-name":"exceptions","pkg-version":"0.10.4","depends":["base-4.16.3.0","mtl-2.2.2","stm-2.5.0.2","template-haskell-2.18.0.0","transformers-0.5.6.2"]},{"type":"pre-existing","id":"filepath-1.4.2.2","pkg-name":"filepath","pkg-version":"1.4.2.2","depends":["base-4.16.3.0"]},{"type":"pre-existing","id":"ghc-bignum-1.2","pkg-name":"ghc-bignum","pkg-version":"1.2","depends":["ghc-prim-0.8.0"]},{"type":"pre-existing","id":"ghc-boot-th-9.2.4","pkg-name":"ghc-boot-th","pkg-version":"9.2.4","depends":["base-4.16.3.0"]},{"type":"pre-existing","id":"ghc-prim-0.8.0","pkg-name":"ghc-prim","pkg-version":"0.8.0","depends":["rts"]},{"type":"configured","id":"hashable-1.4.1.0-8c93d16cc53e4a7135da3566487335a472b3ab08bf2bfcf76447508f91477efe","pkg-name":"hashable","pkg-version":"1.4.1.0","flags":{"containers":true,"integer-gmp":true,"random-initial-seed":false},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"50b2f002c68fe67730ee7a3cd8607486197dd99b084255005ad51ecd6970a41b","pkg-src-sha256":"e1b305c280e66ad827edeaedd6933b9fc4174f626882877eab2a08344e665e87","depends":["base-4.16.3.0","bytestring-0.11.3.1","containers-0.6.6-ad701f1f732595158ed449ad9787f34463326e7108d6c3253f455912aca9f80e","deepseq-1.4.6.1","ghc-bignum-1.2","ghc-prim-0.8.0","text-2.0.1-29e92d3c832091284c360f7b904de394932bf28868ba3956e734f125f74606db"],"exe-depends":[],"component-name":"lib"},{"type":"configured","id":"hgraphs-0.1.0.0-inplace-hgraphs","pkg-name":"hgraphs","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/oz20977/Documents/hgraphs/."},"dist-dir":"/home/oz20977/Documents/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs","depends":["base-4.16.3.0","containers-0.6.6-ad701f1f732595158ed449ad9787f34463326e7108d6c3253f455912aca9f80e","effectful-2.1.0.0-719009a650276ee7d0281a73a1dd1b8e394641a9c0edc7dcde7b61e9fb6b0746","mtl-2.2.2","random-1.2.1.1-cacc1501582bd05c5eec5dea004194a2d9ff55cb8e30c141ffdbf5e9daaf76af","transformers-0.5.6.2"],"exe-depends":[],"component-name":"exe:hgraphs","bin-file":"/home/oz20977/Documents/hgraphs/dist-newstyle/build/x86_64-linux/ghc-9.2.4/hgraphs-0.1.0.0/x/hgraphs/build/hgraphs/hgraphs"},{"type":"configured","id":"monad-control-1.0.3.1-e097f12cd3edc399972905a99bca3a27608065a19c5942fe006ba5490c848b47","pkg-name":"monad-control","pkg-version":"1.0.3.1","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"2d657279839e1a760c86a69f00f0c36473ef6972d413ec0f83a40249c70e098e","pkg-src-sha256":"ae0baea04d99375ef788140367179994a7178d400a8ce0d9026846546772713c","depends":["base-4.16.3.0","stm-2.5.0.2","transformers-0.5.6.2","transformers-base-0.4.6-3e0e9cd113ebeaa61bdcfe3d05dc603287b898e88dc55aec6ace6fe3522eb40d","transformers-compat-0.7.2-e449a3fca743c70bc8fa481203593e03f12f71f63ab8a0db3f9864bdf44fbe4b"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"mtl-2.2.2","pkg-name":"mtl","pkg-version":"2.2.2","depends":["base-4.16.3.0","transformers-0.5.6.2"]},{"type":"pre-existing","id":"pretty-1.1.3.6","pkg-name":"pretty","pkg-version":"1.1.3.6","depends":["base-4.16.3.0","deepseq-1.4.6.1","ghc-prim-0.8.0"]},{"type":"configured","id":"primitive-0.7.4.0-0f1f742d00a689edbb81a766aa59acc03aa6a6b05f37ea7b943ad32694c124f6","pkg-name":"primitive","pkg-version":"0.7.4.0","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"89b88a3e08493b7727fa4089b0692bfbdf7e1e666ef54635f458644eb8358764","pkg-src-sha256":"5b2d6dc2812eb2f6a115f05fcbe3e723d3aeff7894b012c617e075130581add5","depends":["base-4.16.3.0","deepseq-1.4.6.1","template-haskell-2.18.0.0","transformers-0.5.6.2"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"process-1.6.13.2","pkg-name":"process","pkg-version":"1.6.13.2","depends":["base-4.16.3.0","deepseq-1.4.6.1","directory-1.3.6.2","filepath-1.4.2.2","unix-2.7.2.2"]},{"type":"configured","id":"random-1.2.1.1-cacc1501582bd05c5eec5dea004194a2d9ff55cb8e30c141ffdbf5e9daaf76af","pkg-name":"random","pkg-version":"1.2.1.1","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"dea1f11e5569332dc6c8efaad1cb301016a5587b6754943a49f9de08ae0e56d9","pkg-src-sha256":"3e1272f7ed6a4d7bd1712b90143ec326fee9b225789222379fea20a9c90c9b76","depends":["base-4.16.3.0","bytestring-0.11.3.1","deepseq-1.4.6.1","mtl-2.2.2","splitmix-0.1.0.4-c5a30dae3b6eb47ac8ba23a866a9ff6f96961c3b68fcb8f53614067e0454a0ed"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"rts","pkg-name":"rts","pkg-version":"1.0.2","depends":[]},{"type":"configured","id":"splitmix-0.1.0.4-c5a30dae3b6eb47ac8ba23a866a9ff6f96961c3b68fcb8f53614067e0454a0ed","pkg-name":"splitmix","pkg-version":"0.1.0.4","flags":{"optimised-mixer":false},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"804e2574bc7e32d08cbab91e47ee6287b4df7d50851d73f9e778f94a9a7814c7","pkg-src-sha256":"6d065402394e7a9117093dbb4530a21342c9b1e2ec509516c8a8d0ffed98ecaa","depends":["base-4.16.3.0","deepseq-1.4.6.1"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"stm-2.5.0.2","pkg-name":"stm","pkg-version":"2.5.0.2","depends":["array-0.5.4.0","base-4.16.3.0"]},{"type":"pre-existing","id":"template-haskell-2.18.0.0","pkg-name":"template-haskell","pkg-version":"2.18.0.0","depends":["base-4.16.3.0","ghc-boot-th-9.2.4","ghc-prim-0.8.0","pretty-1.1.3.6"]},{"type":"configured","id":"text-2.0.1-29e92d3c832091284c360f7b904de394932bf28868ba3956e734f125f74606db","pkg-name":"text","pkg-version":"2.0.1","flags":{"developer":false,"simdutf":true},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"907ecca6d20c42dafceb709ebac546f5d72e8b7dda3c39b286888c2f09e3bad8","pkg-src-sha256":"b00a2466c50e2c300a85e76424967e40d751652bfa6707d13d300b8b4ba087da","depends":["array-0.5.4.0","base-4.16.3.0","binary-0.8.9.1-0668b4c46528bf761ca9a54c4d855dd00c1d8d1d17831a605b336c730adbc320","bytestring-0.11.3.1","deepseq-1.4.6.1","ghc-prim-0.8.0","template-haskell-2.18.0.0"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"time-1.11.1.1","pkg-name":"time","pkg-version":"1.11.1.1","depends":["base-4.16.3.0","deepseq-1.4.6.1"]},{"type":"pre-existing","id":"transformers-0.5.6.2","pkg-name":"transformers","pkg-version":"0.5.6.2","depends":["base-4.16.3.0"]},{"type":"configured","id":"transformers-base-0.4.6-3e0e9cd113ebeaa61bdcfe3d05dc603287b898e88dc55aec6ace6fe3522eb40d","pkg-name":"transformers-base","pkg-version":"0.4.6","flags":{"orphaninstances":true},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"6f18f320e371c8954c4b6b211e2fdd5d15a6d6310bd605b9d640f47ede408961","pkg-src-sha256":"323bf8689eb691b122661cffa41a25e00fea7a768433fe2dde35d3da7d32cf90","depends":["base-4.16.3.0","base-orphans-0.8.7-c83ea082e53ae0cf10a8c377f2446fd177f93efec3c5232596a4ce2e2ab0a3dd","stm-2.5.0.2","transformers-0.5.6.2","transformers-compat-0.7.2-e449a3fca743c70bc8fa481203593e03f12f71f63ab8a0db3f9864bdf44fbe4b"],"exe-depends":[],"component-name":"lib"},{"type":"configured","id":"transformers-compat-0.7.2-e449a3fca743c70bc8fa481203593e03f12f71f63ab8a0db3f9864bdf44fbe4b","pkg-name":"transformers-compat","pkg-version":"0.7.2","flags":{"five":false,"five-three":true,"four":false,"generic-deriving":true,"mtl":true,"three":false,"two":false},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"044fb9955f63ee138fcebedfdcbe54afe741f2d5892a2d0bdf3a8052bd342643","pkg-src-sha256":"b62c7304c9f3cbc9463d0739aa85cb9489f217ea092b9d625d417514fbcc9d6a","depends":["base-4.16.3.0","ghc-prim-0.8.0","transformers-0.5.6.2"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"unix-2.7.2.2","pkg-name":"unix","pkg-version":"2.7.2.2","depends":["base-4.16.3.0","bytestring-0.11.3.1","time-1.11.1.1"]},{"type":"configured","id":"unliftio-0.2.22.0-d5bd80364ec545ccd948d1d21e11f779df51efdf23c8fa901d37a047bbcb4bf9","pkg-name":"unliftio","pkg-version":"0.2.22.0","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"2a3f0298a293c48eddd10c25cbbd6206b6e745cee2e648e48e16531a3ef21ce8","pkg-src-sha256":"1fc4adb14bbefa303b01163a6dfd61c3bd7f775cebf8ee812d7194fb27ffbb88","depends":["async-2.2.4-c434ffe05cb7c3eb9f2ee4887737c55c63cf3ef81e010c08008ff998f984c99a","base-4.16.3.0","bytestring-0.11.3.1","deepseq-1.4.6.1","directory-1.3.6.2","filepath-1.4.2.2","process-1.6.13.2","stm-2.5.0.2","time-1.11.1.1","transformers-0.5.6.2","unix-2.7.2.2","unliftio-core-0.2.0.1-f248a2f60cc30199e5ef00745c1fc36bddf4f429f77828337c18597f19fa46b6"],"exe-depends":[],"component-name":"lib"},{"type":"configured","id":"unliftio-core-0.2.0.1-f248a2f60cc30199e5ef00745c1fc36bddf4f429f77828337c18597f19fa46b6","pkg-name":"unliftio-core","pkg-version":"0.2.0.1","flags":{},"style":"global","pkg-src":{"type":"repo-tar","repo":{"type":"secure-repo","uri":"http://hackage.haskell.org/"}},"pkg-cabal-sha256":"f9abcdd3f3d28e4840563efb7b8760d2de9b5707bcd6f53a87f6a0d77bb5a9f7","pkg-src-sha256":"919f0d1297ea2f5373118553c1df2a9405d8b9e31a8307e829da67d4953c299a","depends":["base-4.16.3.0","transformers-0.5.6.2"],"exe-depends":[],"component-name":"lib"}]}
\ No newline at end of file
diff --git a/old/examples/hgraphs/dist-newstyle/cache/solver-plan b/old/examples/hgraphs/dist-newstyle/cache/solver-plan
new file mode 100644
index 00000000..f0ce033d
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/cache/solver-plan differ
diff --git a/old/examples/hgraphs/dist-newstyle/cache/source-hashes b/old/examples/hgraphs/dist-newstyle/cache/source-hashes
new file mode 100644
index 00000000..269534e6
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/cache/source-hashes differ
diff --git a/old/examples/hgraphs/dist-newstyle/cache/up-to-date b/old/examples/hgraphs/dist-newstyle/cache/up-to-date
new file mode 100644
index 00000000..1dd8ac9e
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/cache/up-to-date differ
diff --git a/old/examples/hgraphs/dist-newstyle/packagedb/ghc-9.2.4/package.cache b/old/examples/hgraphs/dist-newstyle/packagedb/ghc-9.2.4/package.cache
new file mode 100644
index 00000000..b3cae5cf
Binary files /dev/null and b/old/examples/hgraphs/dist-newstyle/packagedb/ghc-9.2.4/package.cache differ
diff --git a/old/examples/hgraphs/dist-newstyle/packagedb/ghc-9.2.4/package.cache.lock b/old/examples/hgraphs/dist-newstyle/packagedb/ghc-9.2.4/package.cache.lock
new file mode 100644
index 00000000..e69de29b
diff --git a/old/examples/hgraphs/hgraphs.cabal b/old/examples/hgraphs/hgraphs.cabal
new file mode 100644
index 00000000..b2888f11
--- /dev/null
+++ b/old/examples/hgraphs/hgraphs.cabal
@@ -0,0 +1,35 @@
+cabal-version:      2.4
+name:               hgraphs
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+-- license:
+author:             JosephBond
+maintainer:         jecb1998@googlemail.com
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+executable hgraphs
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    base ^>=4.16.3.0, containers >= 0.6.6, effectful >= 2.0.0.0, mtl >= 2.2.2, random >= 1.2.1.1, transformers >= 0.5.6.2
+    hs-source-dirs:   app
+    default-language: Haskell2010
+    default-extensions: OverloadedRecordDot