2 files changed, 376 insertions, 0 deletions
diff --git a/Data/WiringDiagram/Looped/Core.agda b/Data/WiringDiagram/Looped/Core.agda
new file mode 100644
index 0000000..b26f4b7
--- /dev/null
+++ b/Data/WiringDiagram/Looped/Core.agda
@@ -0,0 +1,162 @@
+{-# OPTIONS --without-K --safe #-}
+
+open import Categories.Category using (Category)
+open import Categories.Functor using (Functor; _∘F_)
+open import Category.Dagger.Semiadditive using (SemiadditiveDagger; IdempotentSemiadditiveDagger)
+open import Category.KaroubiComplete using (KaroubiComplete)
+open import Data.WiringDiagram.Balanced using (BWD)
+open import Level using (Level)
+
+module Data.WiringDiagram.Looped.Core
+    {o ℓ e o′ ℓ′ e′ : Level}
+    {𝒞 : Category o ℓ e}
+    {𝒟 : Category o′ ℓ′ e′}
+    {S : IdempotentSemiadditiveDagger 𝒞}
+    (let module S = IdempotentSemiadditiveDagger S)
+    (let S′ = S.semiadditiveDagger)
+    (karoubiComplete : KaroubiComplete 𝒟)
+    (F : Functor (BWD S′) 𝒟)
+  where
+
+import Categories.Morphism.Idempotent as Idempotent
+import Categories.Morphism.Reasoning as ⇒-Reasoning
+
+open import Categories.Category using (Category)
+open import Categories.Functor.Properties using ([_]-resp-∘)
+open import Category.Dagger.2-Poset using (Dagger-2-Poset; Maps; Map)
+open import Data.WiringDiagram.Balanced S′ using (Include; Push; Pull)
+open import Data.WiringDiagram.Core S′ using (loop; id-⧈; _□_)
+open import Data.WiringDiagram.Equalities S using (loop∘loop; loop∘push∘loop; loop∘pull∘loop)
+
+module BWD = Category (BWD S′)
+module F = Functor F
+module 𝒞 = Category 𝒞
+module 𝒟 = Category 𝒟
+
+open Category using (op)
+open Idempotent 𝒟 using (IsSplitIdempotent)
+
+module _ (A : 𝒞.Obj) where
+
+  open KaroubiComplete karoubiComplete using (split)
+  open IsSplitIdempotent (split ([ F ]-resp-∘ (loop∘loop {A})))
+
+  Unlooped Looped : 𝒟.Obj
+  Unlooped = F.₀ A
+  Looped = obj
+
+  L : Unlooped 𝒟.⇒ Unlooped
+  L = F.₁ loop
+
+  π : Unlooped 𝒟.⇒ Looped
+  π = retract
+
+  forget : Looped 𝒟.⇒ Unlooped
+  forget = section
+
+  forget∘π : forget 𝒟.∘ π 𝒟.≈ L
+  forget∘π = splits
+
+  π∘forget : π 𝒟.∘ forget 𝒟.≈ 𝒟.id
+  π∘forget = retracts
+
+  π∘l : π 𝒟.∘ L 𝒟.≈ π
+  π∘l = retract-absorb
+
+  l∘forget : L 𝒟.∘ forget 𝒟.≈ forget
+  l∘forget = section-absorb
+
+  l∘l : L 𝒟.∘ L 𝒟.≈ L
+  l∘l = [ F ]-resp-∘ loop∘loop
+
+module Push = Functor Push
+module Pull = Functor Pull
+
+S-≤ : Dagger-2-Poset
+S-≤ = S.dagger-2-poset
+
+Merge : Functor (Maps S-≤) 𝒟
+Merge = record
+    { F₀ = Looped
+    ; F₁ = λ {A} {B} f → π B ∘ F.₁ (Push.₁ (map f)) ∘ forget A
+    ; identity = iden
+    ; homomorphism = λ {f = f} {g} → homo {f = f} {g}
+    ; F-resp-≈ = resp
+    }
+  where
+    open Map
+    open Category 𝒟 using (_∘_)
+    open 𝒟.HomReasoning
+    open ⇒-Reasoning 𝒟
+    iden : {A : 𝒞.Obj} → π A ∘ F.₁ (Push.₁ 𝒞.id) ∘ forget A 𝒟.≈ 𝒟.id
+    iden {A} = begin
+        π A ∘ F.₁ (Push.₁ 𝒞.id) ∘ forget A  ≈⟨ refl⟩∘⟨ F.F-resp-≈ Push.identity ⟩∘⟨refl ⟩
+        π A ∘ F.₁ BWD.id ∘ forget A         ≈⟨ refl⟩∘⟨ elimˡ F.identity ⟩
+        π A ∘ forget A                      ≈⟨ π∘forget A ⟩
+        𝒟.id                                ∎
+    homo
+        : {X Y Z : 𝒞.Obj}
+          {f : Map S-≤ X Y}
+          {g : Map S-≤ Y Z}
+        → π Z ∘ F.₁ (Push.₁ (map g 𝒞.∘ map f)) ∘ forget X 𝒟.≈ (π Z ∘ F.₁ (Push.₁ (map g)) ∘ forget Y) ∘ π Y ∘ F.₁ (Push.₁ (map f)) ∘ forget X
+    homo {X} {Y} {Z} {f′} {g′} = begin
+        π Z ∘ F.₁ (Push.₁ (g 𝒞.∘ f)) ∘ forget X                                 ≈⟨ refl⟩∘⟨ F.F-resp-≈ Push.homomorphism ⟩∘⟨refl ⟩
+        π Z ∘ F.₁ (Push.₁ g BWD.∘ Push.₁ f) ∘ forget X                          ≈⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+        π Z ∘ F.₁ (Push.₁ g) ∘ F.₁ (Push.₁ f) ∘ forget X                        ≈⟨ pushˡ (𝒟.Equiv.sym (π∘l Z)) ⟩
+        π Z ∘ L Z ∘ F.₁ (Push.₁ g) ∘ F.₁ (Push.₁ f) ∘ forget X                  ≈⟨ refl⟩∘⟨ pullˡ (𝒟.Equiv.sym F.homomorphism) ⟩
+        π Z ∘ F.₁ (loop BWD.∘ Push.₁ g) ∘ F.₁ (Push.₁ f) ∘ forget X             ≈⟨ refl⟩∘⟨ F.F-resp-≈ (loop∘push∘loop g (entire g′)) ⟩∘⟨refl ⟨
+        π Z ∘ F.₁ (loop BWD.∘ Push.₁ g BWD.∘ loop) ∘ F.₁ (Push.₁ f) ∘ forget X  ≈⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+        π Z ∘ L Z ∘ F.₁ (Push.₁ g BWD.∘ loop) ∘ F.₁ (Push.₁ f) ∘ forget X       ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+        π Z ∘ L Z ∘ F.₁ (Push.₁ g) ∘ L Y ∘ F.₁ (Push.₁ f) ∘ forget X            ≈⟨ pullˡ (π∘l Z) ⟩
+        π Z ∘ F.₁ (Push.₁ g) ∘ L Y ∘ F.₁ (Push.₁ f) ∘ forget X                  ≈⟨ pushʳ (pushʳ (pushˡ (𝒟.Equiv.sym (forget∘π Y)))) ⟩
+        (π Z ∘ F.₁ (Push.₁ g) ∘ forget Y) ∘ π Y ∘ F.₁ (Push.₁ f) ∘ forget X     ∎
+      where
+        f : X 𝒞.⇒ Y
+        f = map f′
+        g : Y 𝒞.⇒ Z
+        g = map g′
+    resp : {A B : 𝒞.Obj} {f g : A 𝒞.⇒ B} → f 𝒞.≈ g → π B ∘ F.₁ (Push.₁ f) ∘ forget A 𝒟.≈ π B ∘ F.₁ (Push.₁ g) ∘ forget A
+    resp {A} {B} {f} {g} f≈g = refl⟩∘⟨ F.F-resp-≈ (Push.F-resp-≈ f≈g) ⟩∘⟨refl
+
+Split : Functor (op (Maps S-≤)) 𝒟
+Split = record
+    { F₀ = Looped
+    ; F₁ = λ {A} {B} f → π B ∘ F.₁ (Pull.₁ (map f)) ∘ forget A
+    ; identity = iden
+    ; homomorphism = λ {f = f} {g} → homo {f = f} {g}
+    ; F-resp-≈ = resp
+    }
+  where
+    open Map
+    open Category 𝒟 using (_∘_)
+    open 𝒟.HomReasoning
+    open ⇒-Reasoning 𝒟
+    iden : {A : 𝒞.Obj} → π A ∘ F.₁ (Pull.₁ 𝒞.id) ∘ forget A 𝒟.≈ 𝒟.id
+    iden {A} = begin
+        π A ∘ F.₁ (Pull.₁ 𝒞.id) ∘ forget A  ≈⟨ refl⟩∘⟨ F.F-resp-≈ Pull.identity ⟩∘⟨refl ⟩
+        π A ∘ F.₁ BWD.id ∘ forget A         ≈⟨ refl⟩∘⟨ elimˡ F.identity ⟩
+        π A ∘ forget A                      ≈⟨ π∘forget A ⟩
+        𝒟.id                                ∎
+    homo
+        : {X Y Z : 𝒞.Obj}
+          {f : Map S-≤ Y X}
+          {g : Map S-≤ Z Y}
+        → π Z ∘ F.₁ (Pull.₁ (map f 𝒞.∘ map g)) ∘ forget X 𝒟.≈ (π Z ∘ F.₁ (Pull.₁ (map g)) ∘ forget Y) ∘ π Y ∘ F.₁ (Pull.₁ (map f)) ∘ forget X
+    homo {X} {Y} {Z} {f′} {g′} = begin
+        π Z ∘ F.₁ (Pull.₁ (f 𝒞.∘ g)) ∘ forget X                                 ≈⟨ refl⟩∘⟨ F.F-resp-≈ Pull.homomorphism ⟩∘⟨refl ⟩
+        π Z ∘ F.₁ (Pull.₁ g BWD.∘ Pull.₁ f) ∘ forget X                          ≈⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+        π Z ∘ F.₁ (Pull.₁ g) ∘ F.₁ (Pull.₁ f) ∘ forget X                        ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ l∘forget X ⟨
+        π Z ∘ F.₁ (Pull.₁ g) ∘ F.₁ (Pull.₁ f) ∘ L X ∘ forget X                  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (𝒟.Equiv.sym F.homomorphism) ⟩
+        π Z ∘ F.₁ (Pull.₁ g) ∘ F.₁ (Pull.₁ f BWD.∘ loop) ∘ forget X             ≈⟨ refl⟩∘⟨ refl⟩∘⟨ F.F-resp-≈ (loop∘pull∘loop f (functional f′)) ⟩∘⟨refl ⟨
+        π Z ∘ F.₁ (Pull.₁ g) ∘ F.₁ (loop BWD.∘ Pull.₁ f BWD.∘ loop) ∘ forget X  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+        π Z ∘ F.₁ (Pull.₁ g) ∘ L Y ∘ F.₁ (Pull.₁ f BWD.∘ loop) ∘ forget X       ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+        π Z ∘ F.₁ (Pull.₁ g) ∘ L Y ∘ F.₁ (Pull.₁ f) ∘ L X ∘ forget X            ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ l∘forget X ⟩
+        π Z ∘ F.₁ (Pull.₁ g) ∘ L Y ∘ F.₁ (Pull.₁ f) ∘ forget X                  ≈⟨ pushʳ (pushʳ (pushˡ (𝒟.Equiv.sym (forget∘π Y)))) ⟩
+        (π Z ∘ F.₁ (Pull.₁ g) ∘ forget Y) ∘ π Y ∘ F.₁ (Pull.₁ f) ∘ forget X     ∎
+      where
+        f : Y 𝒞.⇒ X
+        f = map f′
+        g : Z 𝒞.⇒ Y
+        g = map g′
+    resp : {A B : 𝒞.Obj} {f g : B 𝒞.⇒ A} → f 𝒞.≈ g → π B ∘ F.₁ (Pull.₁ f) ∘ forget A 𝒟.≈ π B ∘ F.₁ (Pull.₁ g) ∘ forget A
+    resp {A} {B} {f} {g} f≈g = refl⟩∘⟨ F.F-resp-≈ (Pull.F-resp-≈ f≈g) ⟩∘⟨refl
diff --git a/Data/WiringDiagram/Looped/Monoidal.agda b/Data/WiringDiagram/Looped/Monoidal.agda
new file mode 100644
index 0000000..d0115ac
--- /dev/null
+++ b/Data/WiringDiagram/Looped/Monoidal.agda
@@ -0,0 +1,214 @@
+{-# OPTIONS --without-K --safe #-}
+{-# OPTIONS --lossy-unification #-}
+
+open import Categories.Category using (Category)
+open import Categories.Category.Monoidal.Bundle using (MonoidalCategory)
+open import Categories.Functor using (Functor; _∘F_)
+open import Categories.Functor.Monoidal using (StrongMonoidalFunctor; MonoidalFunctor; IsMonoidalFunctor)
+open import Category.Dagger.2-Poset using (Map)
+open import Category.Dagger.Semiadditive using (IdempotentSemiadditiveDagger)
+open import Category.KaroubiComplete using (KaroubiComplete)
+open import Data.WiringDiagram.Monoidal using (BWD-MC)
+open import Level using (Level; suc; _⊔_)
+
+open MonoidalCategory using (U)
+
+module Data.WiringDiagram.Looped.Monoidal
+    {o ℓ e o′ ℓ′ e′ : Level}
+    {𝒞 : Category o ℓ e}
+    {𝒟 : MonoidalCategory o′ ℓ′ e′}
+    {S : IdempotentSemiadditiveDagger 𝒞}
+    (let module S = IdempotentSemiadditiveDagger S)
+    (let S′ = S.semiadditiveDagger)
+    (karoubiComplete : KaroubiComplete (U 𝒟))
+    (F : MonoidalFunctor (BWD-MC S′) 𝒟)
+  where
+
+module F = MonoidalFunctor F
+
+import Categories.Category.Monoidal.Reasoning as ⊗-Reasoning
+import Categories.Morphism.Reasoning as ⇒-Reasoning
+
+open import Categories.Category.Product using (_⁂_)
+open import Categories.Functor.Properties using ([_]-resp-square)
+open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper)
+open import Data.Product using (_,_)
+open import Data.WiringDiagram.Balanced S′ using (Include; Push; Pull)
+open import Data.WiringDiagram.Core S′ using (loop)
+open import Data.WiringDiagram.Equalities S using (loop∘loop; loop∘push∘loop; loop∘pull∘loop)
+open import Data.WiringDiagram.Looped.Core {S = S} karoubiComplete F.F using (Merge; Looped; π; forget; L; π∘l; forget∘π; π∘forget; l∘forget; l∘l)
+open import Data.WiringDiagram.Monoidal S′ using (Push-MF; loop⊞loop; module BalancedPush)
+
+module BWD = BWD-MC S′
+module Merge = Functor Merge
+module Push = Functor Push
+module Push-MF = StrongMonoidalFunctor Push-MF
+module maps-MC = MonoidalCategory S.maps-MC
+module S-MC = MonoidalCategory S.monoidalCategory
+module 𝒞 = Category 𝒞
+module 𝒟 = MonoidalCategory 𝒟
+
+open BWD using () renaming (_∘_ to _∘′_; _⊗₁_ to _⊞₁_)
+open BalancedPush using (Push-⊞₁; Push-assoc; Push-π₂; Push-π₁)
+open Map using (map; entire)
+open maps-MC using () renaming (_⊗₁_ to _⊗₁′_)
+open 𝒟 using (_⇒_; _∘_; id; _≈_; _⊗₀_; _⊗₁_)
+open S using (_⊕_; _×₁_)
+
+ε : 𝒟.unit ⇒ Looped maps-MC.unit
+ε = π maps-MC.unit ∘ F.ε
+
+η : (X Y : 𝒞.Obj) → Looped X ⊗₀ Looped Y ⇒ Looped (X maps-MC.⊗₀ Y)
+η X Y = π (X maps-MC.⊗₀ Y) ∘ F.⊗-homo.η (X , Y) ∘ forget X ⊗₁ forget Y
+
+private module Shorthands where
+
+  φ : {X Y : 𝒞.Obj} → F.₀ X ⊗₀ F.₀ Y ⇒ F.₀ (X maps-MC.⊗₀ Y)
+  φ {X} {Y} = F.⊗-homo.η (X , Y)
+
+  fo : {X : 𝒞.Obj} → Looped X ⇒ F.₀ X
+  fo {X} = forget X
+
+  π′ : {X : 𝒞.Obj} → F.₀ X ⇒ Looped X
+  π′ {X} = π X
+
+  L′ : {X : 𝒞.Obj} → F.₀ X ⇒ F.₀ X
+  L′ {X} = L X
+
+comm
+    : {X X′ Y Y′ : 𝒞.Obj}
+      (f : X maps-MC.⇒ X′)
+      (g : Y maps-MC.⇒ Y′)
+    → η X′ Y′ ∘ Merge.₁ f ⊗₁ Merge.₁ g 𝒟.≈ Merge.₁ (f maps-MC.⊗₁ g) ∘ η X Y
+comm {X} {X′} {Y} {Y′} f g = begin
+    (π′ ∘ φ ∘ fo ⊗₁ fo) ∘ (π′ ∘ F.₁ (Push.₁ f′) ∘ fo) ⊗₁ (π′ ∘ F.₁ (Push.₁ g′) ∘ fo)  ≈⟨ pullʳ (pullʳ (sym ⊗-distrib-over-∘)) ⟩
+    π′ ∘ φ ∘ (fo ∘ π X′ ∘ F.₁ (Push.₁ f′) ∘ fo) ⊗₁ (fo ∘ π Y′ ∘ F.₁ (Push.₁ g′) ∘ fo) ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (forget∘π X′) ⟩⊗⟨ pullˡ (forget∘π Y′) ⟩
+    π′ ∘ φ ∘ (L X′ ∘ F.₁ (Push.₁ f′) ∘ fo) ⊗₁ (L Y′ ∘ F.₁ (Push.₁ g′) ∘ fo)           ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩⊗⟨ pushˡ F.homomorphism  ⟨
+    π′ ∘ φ ∘ (F.₁ (loop ∘′ Push.₁ f′) ∘ fo) ⊗₁ (F.₁ (loop ∘′ Push.₁ g′) ∘ fo)         ≈⟨ refl⟩∘⟨ refl⟩∘⟨ ⊗-distrib-over-∘ ⟩
+    π′ ∘ φ ∘ F.₁ (loop ∘′ Push.₁ f′) ⊗₁ F.₁ (loop ∘′ Push.₁ g′) ∘ fo ⊗₁ fo            ≈⟨ refl⟩∘⟨ extendʳ (F.⊗-homo.commute _) ⟩  
+    π′ ∘ F.₁ ((loop ∘′ Push.₁ f′) ⊞₁ (loop ∘′ Push.₁ g′)) ∘ φ ∘ fo ⊗₁ fo              ≈⟨ refl⟩∘⟨ F.F-resp-≈ (⊗-Reasoning.⊗-distrib-over-∘ BWD.monoidal) ⟩∘⟨refl ⟩
+    π′ ∘ F.₁ (loop ⊞₁ loop ∘′ Push.₁ f′ ⊞₁ Push.₁ g′) ∘ φ ∘ fo ⊗₁ fo                  ≈⟨ refl⟩∘⟨ F.F-resp-≈ (BWD.∘-resp-≈ˡ loop⊞loop) ⟩∘⟨refl ⟩
+    π′ ∘ F.₁ (loop ∘′ Push.₁ f′ ⊞₁ Push.₁ g′) ∘ φ ∘ fo ⊗₁ fo                          ≈⟨ refl⟩∘⟨ F.F-resp-≈ (BWD.∘-resp-≈ʳ (Push-⊞₁ f′ g′)) ⟩∘⟨refl ⟩
+    π′ ∘ F.₁ (loop ∘′ Push.₁ (f′ ×₁ g′)) ∘ φ ∘ fo ⊗₁ fo                               ≈⟨ refl⟩∘⟨ F.F-resp-≈ (loop∘push∘loop (f′ ×₁ g′) (entire (f ⊗₁′ g))) ⟩∘⟨refl ⟨
+    π′ ∘ F.₁ (loop ∘′ Push.₁ (f′ ×₁ g′) ∘′ loop) ∘ φ ∘ fo ⊗₁ fo                       ≈⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+    π′ ∘ L (X′ ⊕ Y′) ∘ F.₁ (Push.₁ (f′ ×₁ g′) ∘′ loop) ∘ φ ∘ fo ⊗₁ fo                 ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+    π′ ∘ L (X′ ⊕ Y′) ∘ F.₁ (Push.₁ (f′ ×₁ g′)) ∘ L (X ⊕ Y) ∘ φ ∘ fo ⊗₁ fo             ≈⟨ pullˡ (π∘l (X′ ⊕ Y′)) ⟩
+    π′ ∘ F.₁ (Push.₁ (f′ ×₁ g′)) ∘ L (X ⊕ Y) ∘ φ ∘ fo ⊗₁ fo                           ≈⟨ pushʳ (pushʳ (pushˡ (sym (forget∘π (X ⊕ Y))))) ⟩
+    (π′ ∘ F.₁ (Push.₁ (f′ ×₁ g′)) ∘ forget (X ⊕ Y)) ∘ π (X ⊕ Y) ∘ φ ∘ fo ⊗₁ fo        ∎
+  where
+    f′ : X 𝒞.⇒ X′
+    f′ = map f
+    g′ : Y 𝒞.⇒ Y′
+    g′ = map g
+    open Shorthands
+    open 𝒟.Equiv
+    open ⊗-Reasoning 𝒟.monoidal
+    open ⇒-Reasoning (U 𝒟)
+
+⊗-homo : NaturalTransformation (𝒟.⊗ ∘F (Merge ⁂ Merge)) (Merge ∘F maps-MC.⊗)
+⊗-homo = ntHelper record
+    { η = λ (X , Y) → η X Y
+    ; commute = λ (f , g) → comm f g
+    }
+
+associativity
+    : {X Y Z : 𝒞.Obj}
+    → Merge.₁ maps-MC.associator.from ∘ η (X ⊕ Y) Z ∘ η X Y ⊗₁ id ≈ η X (Y ⊕ Z) ∘ id ⊗₁ η Y Z ∘ 𝒟.associator.from
+associativity {X} {Y} {Z} = begin
+    (π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ fo) ∘ η (X ⊕ Y) Z ∘ η X Y ⊗₁ id           ≈⟨ pullʳ (pullʳ (extendʳ (pullˡ (forget∘π ((X ⊕ Y) ⊕ Z))))) ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ (φ ∘ fo ⊗₁ fo) ∘ η X Y ⊗₁ id          ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ pullʳ merge₁ʳ ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ φ ∘ (fo ∘ π′ ∘ φ ∘ fo ⊗₁ fo) ⊗₁ fo    ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (forget∘π (X ⊕ Y)) ⟩⊗⟨refl ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ φ ∘ (L′ ∘ φ ∘ fo ⊗₁ fo) ⊗₁ fo         ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩⊗⟨ (l∘forget Z) ⟨
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ φ ∘ (L′ ∘ φ ∘ fo ⊗₁ fo) ⊗₁ (L′ ∘ fo)  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ ⊗-distrib-over-∘ ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ φ ∘ L′ ⊗₁ L′ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo   ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ extendʳ (F.⊗-homo.commute _) ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ F.₁ (loop ⊞₁ loop) ∘ φ ∘ _ ⊗₁ fo      ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ F.F-resp-≈ loop⊞loop ⟩∘⟨refl ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ L′ ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo         ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (l∘l ((X ⊕ Y) ⊕ Z)) ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ L′ ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo              ≈⟨ refl⟩∘⟨ pullˡ (sym F.homomorphism) ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ ∘′ loop) ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo           ≈⟨ pushˡ (sym (π∘l (X ⊕ (Y ⊕ Z)))) ⟩
+    π′ ∘ L′ ∘ F.₁ (Push.₁ S.assocˡ ∘′ loop) ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo      ≈⟨ refl⟩∘⟨ pullˡ (sym F.homomorphism) ⟩
+    π′ ∘ F.₁ (loop ∘′ Push.₁ S.assocˡ ∘′ loop) ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo   ≈⟨ refl⟩∘⟨ F.F-resp-≈ (loop∘push∘loop S.assocˡ (entire maps-MC.associator.from)) ⟩∘⟨refl ⟩
+    π′ ∘ F.₁ (loop ∘′ Push.₁ S.assocˡ) ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo           ≈⟨ refl⟩∘⟨ pushˡ F.homomorphism ⟩
+    π′ ∘ L′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo              ≈⟨ pullˡ (π∘l (X ⊕ (Y ⊕ Z))) ⟩
+    π′ ∘ F.₁ (Push.₁ S.assocˡ) ∘ φ ∘ (φ ∘ fo ⊗₁ fo) ⊗₁ fo                   ≈⟨ refl⟩∘⟨ F.F-resp-≈ Push-assoc ⟩∘⟨ pushʳ split₁ˡ ⟩
+    π′ ∘ F.₁ BWD.associator.from ∘ (φ ∘ φ ⊗₁ id) ∘ (fo ⊗₁ fo) ⊗₁ fo         ≈⟨ refl⟩∘⟨ extendʳ F.associativity ⟩
+    π′ ∘ φ ∘ (id ⊗₁ φ ∘ 𝒟.associator.from) ∘ (fo ⊗₁ fo) ⊗₁ fo               ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullʳ 𝒟.assoc-commute-from ⟩
+    π′ ∘ φ ∘ id ⊗₁ φ ∘ fo ⊗₁ (fo ⊗₁ fo) ∘ 𝒟.associator.from                 ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ merge₂ˡ ⟩
+    π′ ∘ φ ∘ fo ⊗₁ (φ ∘ fo ⊗₁ fo) ∘ 𝒟.associator.from                       ≈⟨ pushˡ (sym (π∘l (X ⊕ (Y ⊕ Z)))) ⟩
+    π′ ∘ L′ ∘ φ ∘ fo ⊗₁ (φ ∘ fo ⊗₁ fo) ∘ 𝒟.associator.from                  ≈⟨ refl⟩∘⟨ F.F-resp-≈ loop⊞loop ⟩∘⟨refl ⟨
+    π′ ∘ F.₁ (loop ⊞₁ loop) ∘ φ ∘ fo ⊗₁ (φ ∘ fo ⊗₁ fo) ∘ 𝒟.associator.from  ≈⟨ refl⟩∘⟨ extendʳ (F.⊗-homo.sym-commute _) ⟩
+    π′ ∘ φ ∘ L′ ⊗₁ L′ ∘ fo ⊗₁ (φ ∘ fo ⊗₁ fo) ∘ 𝒟.associator.from            ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (sym ⊗-distrib-over-∘) ⟩
+    π′ ∘ φ ∘ (L′ ∘ fo) ⊗₁ (L′ ∘ φ ∘ fo ⊗₁ fo) ∘ 𝒟.associator.from           ≈⟨ refl⟩∘⟨ refl⟩∘⟨ l∘forget X ⟩⊗⟨ pushˡ (sym (forget∘π (Y ⊕ Z))) ⟩∘⟨refl ⟩
+    π′ ∘ φ ∘ fo ⊗₁ (fo ∘ π′ ∘ φ ∘ fo ⊗₁ fo) ∘ 𝒟.associator.from             ≈⟨ pushʳ (pushʳ (pushˡ split₂ʳ)) ⟩
+    (π′ ∘ φ ∘ fo ⊗₁ fo) ∘ id ⊗₁ (π′ ∘ φ ∘ fo ⊗₁ fo) ∘ 𝒟.associator.from     ∎
+  where
+    open Shorthands
+    open ⊗-Reasoning 𝒟.monoidal
+    open ⇒-Reasoning 𝒟.U
+    open 𝒟.Equiv
+
+unitaryˡ
+    : {X : 𝒞.Obj}
+    → Merge.₁ maps-MC.unitorˡ.from ∘ η maps-MC.unit X ∘ ε ⊗₁ id ≈ 𝒟.unitorˡ.from
+unitaryˡ {X} = begin
+    (π′ ∘ F.₁ (Push.₁ S.π₂) ∘ fo) ∘ (π′ ∘ φ ∘ fo ⊗₁ fo) ∘ ε ⊗₁ id     ≈⟨ pullʳ (pullʳ (extendʳ (pullˡ (forget∘π (S.𝟘 ⊕ X))))) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ L′ ∘ (φ ∘ fo ⊗₁ fo) ∘ ε ⊗₁ id            ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ pullʳ merge₁ʳ ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ L′ ∘ φ ∘ (fo ∘ ε) ⊗₁ fo                  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (forget∘π S.𝟘) ⟩⊗⟨ sym (l∘forget X) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ L′ ∘ φ ∘ (L′ ∘ F.ε) ⊗₁ (L′ ∘ fo)         ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ ⊗-distrib-over-∘ ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ L′ ∘ φ ∘ L′ ⊗₁ L′ ∘ F.ε ⊗₁ fo            ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ extendʳ (F.⊗-homo.commute _) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ L′ ∘ F.₁ (loop ⊞₁ loop) ∘ φ ∘ F.ε ⊗₁ fo  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ F.F-resp-≈ loop⊞loop ⟩∘⟨refl ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ L′ ∘ L′ ∘ φ ∘ F.ε ⊗₁ fo                  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (l∘l (S.𝟘 ⊕ X)) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ L′ ∘ φ ∘ F.ε ⊗₁ fo                       ≈⟨ refl⟩∘⟨ pullˡ (sym F.homomorphism) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂ ∘′ loop) ∘ φ ∘ F.ε ⊗₁ fo                    ≈⟨ pushˡ (sym (π∘l X)) ⟩
+    π′ ∘ L′ ∘ F.₁ (Push.₁ S.π₂ ∘′ loop) ∘ φ ∘ F.ε ⊗₁ fo               ≈⟨ refl⟩∘⟨ extendʳ ([ F.F ]-resp-square (loop∘push∘loop S.π₂ (entire maps-MC.unitorˡ.from))) ⟩
+    π′ ∘ L′ ∘ F.₁ (Push.₁ S.π₂) ∘ φ ∘ F.ε ⊗₁ fo                       ≈⟨ pullˡ (π∘l X) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₂) ∘ φ ∘ F.ε ⊗₁ fo                            ≈⟨ refl⟩∘⟨ F.F-resp-≈ Push-π₂ ⟩∘⟨ pushʳ serialize₁₂ ⟩
+    π′ ∘ F.₁ BWD.unitorˡ.from ∘ (φ ∘ F.ε ⊗₁ id) ∘ id ⊗₁ fo            ≈⟨ refl⟩∘⟨ pullˡ F.unitaryˡ ⟩
+    π′ ∘ 𝒟.unitorˡ.from ∘ id ⊗₁ fo                                    ≈⟨ refl⟩∘⟨ 𝒟.unitorˡ-commute-from ⟩
+    π′ ∘ fo ∘ 𝒟.unitorˡ.from                                          ≈⟨ cancelˡ (π∘forget X) ⟩
+    𝒟.unitorˡ.from                                                    ∎
+  where
+    open Shorthands
+    open ⊗-Reasoning 𝒟.monoidal
+    open ⇒-Reasoning 𝒟.U
+    open 𝒟.Equiv
+
+unitaryʳ
+    : {X : 𝒞.Obj}
+    → Merge.₁ maps-MC.unitorʳ.from ∘ η X maps-MC.unit ∘ id ⊗₁ ε ≈ 𝒟.unitorʳ.from
+unitaryʳ {X} = begin
+    (π′ ∘ F.₁ (Push.₁ S.π₁) ∘ fo) ∘ (π′ ∘ φ ∘ fo ⊗₁ fo) ∘ id ⊗₁ ε     ≈⟨ pullʳ (pullʳ (extendʳ (pullˡ (forget∘π (X ⊕ S.𝟘))))) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ L′ ∘ (φ ∘ fo ⊗₁ fo) ∘ id ⊗₁ ε            ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ pullʳ merge₂ʳ ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ L′ ∘ φ ∘ fo ⊗₁ (fo ∘ ε)                  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ sym (l∘forget X) ⟩⊗⟨ pullˡ (forget∘π S.𝟘) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ L′ ∘ φ ∘ (L′ ∘ fo) ⊗₁ (L′ ∘ F.ε)         ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ ⊗-distrib-over-∘ ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ L′ ∘ φ ∘ L′ ⊗₁ L′ ∘ fo ⊗₁ F.ε            ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ extendʳ (F.⊗-homo.commute _) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ L′ ∘ F.₁ (loop ⊞₁ loop) ∘ φ ∘ fo ⊗₁ F.ε  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ F.F-resp-≈ loop⊞loop ⟩∘⟨refl ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ L′ ∘ L′ ∘ φ ∘ fo ⊗₁ F.ε                  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (l∘l (X ⊕ S.𝟘)) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ L′ ∘ φ ∘ fo ⊗₁ F.ε                       ≈⟨ refl⟩∘⟨ pullˡ (sym F.homomorphism) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁ ∘′ loop) ∘ φ ∘ fo ⊗₁ F.ε                    ≈⟨ pushˡ (sym (π∘l X)) ⟩
+    π′ ∘ L′ ∘ F.₁ (Push.₁ S.π₁ ∘′ loop) ∘ φ ∘ fo ⊗₁ F.ε               ≈⟨ refl⟩∘⟨ extendʳ ([ F.F ]-resp-square (loop∘push∘loop S.π₁ (entire maps-MC.unitorʳ.from))) ⟩
+    π′ ∘ L′ ∘ F.₁ (Push.₁ S.π₁) ∘ φ ∘ fo ⊗₁ F.ε                       ≈⟨ pullˡ (π∘l X) ⟩
+    π′ ∘ F.₁ (Push.₁ S.π₁) ∘ φ ∘ fo ⊗₁ F.ε                            ≈⟨ refl⟩∘⟨ F.F-resp-≈ Push-π₁ ⟩∘⟨ pushʳ serialize₂₁ ⟩
+    π′ ∘ F.₁ BWD.unitorʳ.from ∘ (φ ∘ id ⊗₁ F.ε) ∘ fo ⊗₁ id            ≈⟨ refl⟩∘⟨ pullˡ F.unitaryʳ ⟩
+    π′ ∘ 𝒟.unitorʳ.from ∘ fo ⊗₁ id                                    ≈⟨ refl⟩∘⟨ 𝒟.unitorʳ-commute-from ⟩
+    π′ ∘ fo ∘ 𝒟.unitorʳ.from                                          ≈⟨ cancelˡ (π∘forget X) ⟩
+    𝒟.unitorʳ.from                                                    ∎
+  where
+    open Shorthands
+    open ⊗-Reasoning 𝒟.monoidal
+    open ⇒-Reasoning 𝒟.U
+    open 𝒟.Equiv
+
+Merge-IsMF : IsMonoidalFunctor S.maps-MC 𝒟 Merge
+Merge-IsMF = record
+    { ε = ε
+    ; ⊗-homo = ⊗-homo
+    ; associativity = associativity
+    ; unitaryˡ = unitaryˡ
+    ; unitaryʳ = unitaryʳ
+    }
+
+Merge-MF : MonoidalFunctor S.maps-MC 𝒟
+Merge-MF = record
+    { F = Merge
+    ; isMonoidal = Merge-IsMF
+    }