From e171bf8948f8655eccdf27ba4824bdb28d497076 Mon Sep 17 00:00:00 2001 From: Jacques Comeaux Date: Tue, 4 Aug 2026 06:37:48 -0500 Subject: Construct monoidal merge functor --- Data/WiringDiagram/Looped/Core.agda | 162 ++++++++++++++++++++++++ Data/WiringDiagram/Looped/Monoidal.agda | 214 ++++++++++++++++++++++++++++++++ 2 files changed, 376 insertions(+) create mode 100644 Data/WiringDiagram/Looped/Core.agda create mode 100644 Data/WiringDiagram/Looped/Monoidal.agda (limited to 'Data/WiringDiagram/Looped') 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 + } -- cgit v1.2.3