Use long name

This commit is contained in:
Frederik Hanghøj Iversen 2018-05-11 13:20:03 +02:00
parent 30cf0bb765
commit 4d73514ab5
4 changed files with 162 additions and 142 deletions

View file

@ -10,8 +10,8 @@ open import Cat.Category.NaturalTransformation
open import Cat.Category.Yoneda open import Cat.Category.Yoneda
open import Cat.Category.Monoid open import Cat.Category.Monoid
open import Cat.Category.Monad open import Cat.Category.Monad
open Cat.Category.Monad.Monoidal open import Cat.Category.Monad.Monoidal
open Cat.Category.Monad.Kleisli open import Cat.Category.Monad.Kleisli
open import Cat.Category.Monad.Voevodsky open import Cat.Category.Monad.Voevodsky
open import Cat.Categories.Sets open import Cat.Categories.Sets

View file

@ -28,186 +28,205 @@ import Cat.Category.Monad.Monoidal
import Cat.Category.Monad.Kleisli import Cat.Category.Monad.Kleisli
open import Cat.Categories.Fun open import Cat.Categories.Fun
module Monoidal = Cat.Category.Monad.Monoidal
module Kleisli = Cat.Category.Monad.Kleisli
-- | The monoidal- and kleisli presentation of monads are equivalent. -- | The monoidal- and kleisli presentation of monads are equivalent.
module _ {a b : Level} ( : Category a b) where module _ {a b : Level} ( : Category a b) where
open Cat.Category.NaturalTransformation using (NaturalTransformation ; propIsNatural) open Cat.Category.NaturalTransformation using (NaturalTransformation ; propIsNatural)
private private
module = Category module = Category
open using (Object ; Arrow ; identity ; _<<<_ ; _>>>_) open using (Object ; Arrow ; identity ; _<<<_ ; _>>>_)
module M = Monoidal
module K = Kleisli
module _ (m : M.RawMonad) where module Monoidal = Cat.Category.Monad.Monoidal
open M.RawMonad m module Kleisli = Cat.Category.Monad.Kleisli
forthRaw : K.RawMonad module _ (m : Monoidal.RawMonad) where
K.RawMonad.omap forthRaw = Romap open Monoidal.RawMonad m
K.RawMonad.pure forthRaw = pureT _
K.RawMonad.bind forthRaw = bind
module _ {raw : M.RawMonad} (m : M.IsMonad raw) where toKleisliRaw : Kleisli.RawMonad
private Kleisli.RawMonad.omap toKleisliRaw = Romap
module MI = M.IsMonad m Kleisli.RawMonad.pure toKleisliRaw = pure
forthIsMonad : K.IsMonad (forthRaw raw) Kleisli.RawMonad.bind toKleisliRaw = bind
K.IsMonad.isIdentity forthIsMonad = snd MI.isInverse
K.IsMonad.isNatural forthIsMonad = MI.isNatural
K.IsMonad.isDistributive forthIsMonad = MI.isDistributive
forth : M.Monad K.Monad module _ {raw : Monoidal.RawMonad} (m : Monoidal.IsMonad raw) where
Kleisli.Monad.raw (forth m) = forthRaw (M.Monad.raw m) open Monoidal.IsMonad m
Kleisli.Monad.isMonad (forth m) = forthIsMonad (M.Monad.isMonad m)
module _ (m : K.Monad) where open Kleisli.RawMonad (toKleisliRaw raw) using (_>=>_)
open K.Monad m toKleisliIsMonad : Kleisli.IsMonad (toKleisliRaw raw)
Kleisli.IsMonad.isIdentity toKleisliIsMonad = begin
bind pure ≡⟨⟩
join <<< (fmap pure) ≡⟨ snd isInverse
identity
Kleisli.IsMonad.isNatural toKleisliIsMonad f = begin
pure >=> f ≡⟨⟩
pure >>> bind f ≡⟨⟩
bind f <<< pure ≡⟨⟩
(join <<< fmap f) <<< pure ≡⟨ isNatural f
f
Kleisli.IsMonad.isDistributive toKleisliIsMonad f g = begin
bind g >>> bind f ≡⟨⟩
(join <<< fmap g) >>> (join <<< fmap f) ≡⟨ isDistributive f g
bind (g >=> f)
-- Kleisli.IsMonad.isDistributive toKleisliIsMonad = isDistributive
backRaw : M.RawMonad toKleisli : Monoidal.Monad Kleisli.Monad
M.RawMonad.R backRaw = R Kleisli.Monad.raw (toKleisli m) = toKleisliRaw (Monoidal.Monad.raw m)
M.RawMonad.pureNT backRaw = pureNT Kleisli.Monad.isMonad (toKleisli m) = toKleisliIsMonad (Monoidal.Monad.isMonad m)
M.RawMonad.joinNT backRaw = joinNT
private module _ (m : Kleisli.Monad) where
open M.RawMonad backRaw renaming open Kleisli.Monad m
toMonoidalRaw : Monoidal.RawMonad
Monoidal.RawMonad.R toMonoidalRaw = R
Monoidal.RawMonad.pureNT toMonoidalRaw = pureNT
Monoidal.RawMonad.joinNT toMonoidalRaw = joinNT
open Monoidal.RawMonad toMonoidalRaw renaming
( join to join* ( join to join*
; pure to pure* ; pure to pure*
; bind to bind* ; bind to bind*
; fmap to fmap* ; fmap to fmap*
) ) using ()
module R = Functor (M.RawMonad.R backRaw)
backIsMonad : M.IsMonad backRaw toMonoidalIsMonad : Monoidal.IsMonad toMonoidalRaw
M.IsMonad.isAssociative backIsMonad = begin Monoidal.IsMonad.isAssociative toMonoidalIsMonad = begin
join* <<< R.fmap join* ≡⟨⟩ join* <<< fmap join* ≡⟨⟩
join <<< fmap join ≡⟨ isNaturalForeign join <<< fmap join ≡⟨ isNaturalForeign
join <<< join join <<< join
M.IsMonad.isInverse backIsMonad {X} = inv-l , inv-r Monoidal.IsMonad.isInverse toMonoidalIsMonad {X} = inv-l , inv-r
where where
inv-l = begin inv-l = begin
join <<< pure ≡⟨ fst isInverse join <<< pure ≡⟨ fst isInverse
identity identity
inv-r = begin inv-r = begin
joinT X <<< R.fmap (pureT X) ≡⟨⟩ join* <<< fmap* pure* ≡⟨⟩
join <<< fmap pure ≡⟨ snd isInverse join <<< fmap pure ≡⟨ snd isInverse
identity identity
back : K.Monad M.Monad toMonoidal : Kleisli.Monad Monoidal.Monad
Monoidal.Monad.raw (back m) = backRaw m Monoidal.Monad.raw (toMonoidal m) = toMonoidalRaw m
Monoidal.Monad.isMonad (back m) = backIsMonad m Monoidal.Monad.isMonad (toMonoidal m) = toMonoidalIsMonad m
module _ (m : K.Monad) where module _ (m : Kleisli.Monad) where
private private
open K.Monad m open Kleisli.Monad m
bindEq : {X Y} bindEq : {X Y}
K.RawMonad.bind (forthRaw (backRaw m)) {X} {Y} Kleisli.RawMonad.bind (toKleisliRaw (toMonoidalRaw m)) {X} {Y}
K.RawMonad.bind (K.Monad.raw m) bind
bindEq {X} {Y} = begin bindEq {X} {Y} = funExt lem
K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩
(λ f join <<< fmap f) ≡⟨⟩
(λ f bind (f >>> pure) >>> bind identity) ≡⟨ funExt lem
(λ f bind f) ≡⟨⟩
bind
where where
lem : (f : Arrow X (omap Y)) lem : (f : Arrow X (omap Y))
bind (f >>> pure) >>> bind identity bind (f >>> pure) >>> bind identity
bind f bind f
lem f = begin lem f = begin
join <<< fmap f
≡⟨⟩
bind (f >>> pure) >>> bind identity bind (f >>> pure) >>> bind identity
≡⟨ isDistributive _ _ ≡⟨ isDistributive _ _
bind ((f >>> pure) >=> identity)
≡⟨⟩
bind ((f >>> pure) >>> bind identity) bind ((f >>> pure) >>> bind identity)
≡⟨ cong bind .isAssociative ≡⟨ cong bind .isAssociative
bind (f >>> (pure >>> bind identity)) bind (f >>> (pure >>> bind identity))
≡⟨⟩
bind (f >>> (pure >=> identity))
≡⟨ cong (λ φ bind (f >>> φ)) (isNatural _) ≡⟨ cong (λ φ bind (f >>> φ)) (isNatural _)
bind (f >>> identity) bind (f >>> identity)
≡⟨ cong bind .leftIdentity ≡⟨ cong bind .leftIdentity
bind f bind f
forthRawEq : forthRaw (backRaw m) K.Monad.raw m toKleisliRawEq : toKleisliRaw (toMonoidalRaw m) Kleisli.Monad.raw m
K.RawMonad.omap (forthRawEq _) = omap Kleisli.RawMonad.omap (toKleisliRawEq i) = (begin
K.RawMonad.pure (forthRawEq _) = pure Kleisli.RawMonad.omap (toKleisliRaw (toMonoidalRaw m)) ≡⟨⟩
K.RawMonad.bind (forthRawEq i) = bindEq i Monoidal.RawMonad.Romap (toMonoidalRaw m) ≡⟨⟩
omap
) i
Kleisli.RawMonad.pure (toKleisliRawEq i) = (begin
Kleisli.RawMonad.pure (toKleisliRaw (toMonoidalRaw m)) ≡⟨⟩
Monoidal.RawMonad.pure (toMonoidalRaw m) ≡⟨⟩
pure
) i
Kleisli.RawMonad.bind (toKleisliRawEq i) = bindEq i
fortheq : (m : K.Monad) forth (back m) m toKleislieq : (m : Kleisli.Monad) toKleisli (toMonoidal m) m
fortheq m = K.Monad≡ (forthRawEq m) toKleislieq m = Kleisli.Monad≡ (toKleisliRawEq m)
module _ (m : M.Monad) where module _ (m : Monoidal.Monad) where
private private
open M.Monad m open Monoidal.Monad m
module KM = K.Monad (forth m) -- module KM = Kleisli.Monad (toKleisli m)
open Kleisli.Monad (toKleisli m) renaming
( bind to bind* ; omap to omap* ; join to join*
; fmap to fmap* ; pure to pure* ; R to R*)
using ()
module R = Functor R module R = Functor R
omapEq : KM.omap Romap omapEq : omap* Romap
omapEq = refl omapEq = refl
bindEq : {X Y} {f : Arrow X (Romap Y)} KM.bind f bind f bindEq : {X Y} {f : Arrow X (Romap Y)} bind* f bind f
bindEq {X} {Y} {f} = begin bindEq {X} {Y} {f} = begin
KM.bind f ≡⟨⟩ bind* f ≡⟨⟩
joinT Y <<< fmap f ≡⟨⟩ join <<< fmap f ≡⟨⟩
bind f bind f
joinEq : {X} KM.join joinT X joinEq : {X} join* joinT X
joinEq {X} = begin joinEq {X} = begin
KM.join ≡⟨⟩ join* ≡⟨⟩
KM.bind identity ≡⟨⟩ bind* identity ≡⟨⟩
bind identity ≡⟨⟩ bind identity ≡⟨⟩
joinT X <<< fmap identity ≡⟨ cong (λ φ _ <<< φ) R.isIdentity join <<< fmap identity ≡⟨ cong (λ φ _ <<< φ) R.isIdentity
joinT X <<< identity ≡⟨ .rightIdentity join <<< identity ≡⟨ .rightIdentity
joinT X join
fmapEq : {A B} KM.fmap {A} {B} fmap fmapEq : {A B} fmap* {A} {B} fmap
fmapEq {A} {B} = funExt (λ f begin fmapEq {A} {B} = funExt (λ f begin
KM.fmap f ≡⟨⟩ fmap* f ≡⟨⟩
KM.bind (f >>> KM.pure) ≡⟨⟩ bind* (f >>> pure*) ≡⟨⟩
bind (f >>> pureT _) ≡⟨⟩ bind (f >>> pure) ≡⟨⟩
fmap (f >>> pureT B) >>> joinT B ≡⟨⟩ fmap (f >>> pure) >>> join ≡⟨⟩
fmap (f >>> pureT B) >>> joinT B ≡⟨ cong (λ φ φ >>> joinT B) R.isDistributive fmap (f >>> pure) >>> join ≡⟨ cong (λ φ φ >>> joinT B) R.isDistributive
fmap f >>> fmap (pureT B) >>> joinT B ≡⟨ .isAssociative fmap f >>> fmap pure >>> join ≡⟨ .isAssociative
joinT B <<< fmap (pureT B) <<< fmap f ≡⟨ cong (λ φ φ <<< fmap f) (snd isInverse) join <<< fmap pure <<< fmap f ≡⟨ cong (λ φ φ <<< fmap f) (snd isInverse)
identity <<< fmap f ≡⟨ .leftIdentity identity <<< fmap f ≡⟨ .leftIdentity
fmap f fmap f
) )
rawEq : Functor.raw KM.R Functor.raw R rawEq : Functor.raw R* Functor.raw R
RawFunctor.omap (rawEq i) = omapEq i RawFunctor.omap (rawEq i) = omapEq i
RawFunctor.fmap (rawEq i) = fmapEq i RawFunctor.fmap (rawEq i) = fmapEq i
Req : M.RawMonad.R (backRaw (forth m)) R Req : Monoidal.RawMonad.R (toMonoidalRaw (toKleisli m)) R
Req = Functor≡ rawEq Req = Functor≡ rawEq
pureTEq : M.RawMonad.pureT (backRaw (forth m)) pureT pureTEq : Monoidal.RawMonad.pureT (toMonoidalRaw (toKleisli m)) pureT
pureTEq = funExt (λ X refl) pureTEq = funExt (λ X refl)
pureNTEq : (λ i NaturalTransformation Functors.identity (Req i)) pureNTEq : (λ i NaturalTransformation Functors.identity (Req i))
[ M.RawMonad.pureNT (backRaw (forth m)) pureNT ] [ Monoidal.RawMonad.pureNT (toMonoidalRaw (toKleisli m)) pureNT ]
pureNTEq = lemSigP (λ i propIsNatural Functors.identity (Req i)) _ _ pureTEq pureNTEq = lemSigP (λ i propIsNatural Functors.identity (Req i)) _ _ pureTEq
joinTEq : M.RawMonad.joinT (backRaw (forth m)) joinT joinTEq : Monoidal.RawMonad.joinT (toMonoidalRaw (toKleisli m)) joinT
joinTEq = funExt (λ X begin joinTEq = funExt (λ X begin
M.RawMonad.joinT (backRaw (forth m)) X ≡⟨⟩ Monoidal.RawMonad.joinT (toMonoidalRaw (toKleisli m)) X ≡⟨⟩
KM.join ≡⟨⟩ join* ≡⟨⟩
joinT X <<< fmap identity ≡⟨ cong (λ φ joinT X <<< φ) R.isIdentity join <<< fmap identity ≡⟨ cong (λ φ join <<< φ) R.isIdentity
joinT X <<< identity ≡⟨ .rightIdentity join <<< identity ≡⟨ .rightIdentity
joinT X ) join )
joinNTEq : (λ i NaturalTransformation F[ Req i Req i ] (Req i)) joinNTEq : (λ i NaturalTransformation F[ Req i Req i ] (Req i))
[ M.RawMonad.joinNT (backRaw (forth m)) joinNT ] [ Monoidal.RawMonad.joinNT (toMonoidalRaw (toKleisli m)) joinNT ]
joinNTEq = lemSigP (λ i propIsNatural F[ Req i Req i ] (Req i)) _ _ joinTEq joinNTEq = lemSigP (λ i propIsNatural F[ Req i Req i ] (Req i)) _ _ joinTEq
backRawEq : backRaw (forth m) M.Monad.raw m toMonoidalRawEq : toMonoidalRaw (toKleisli m) Monoidal.Monad.raw m
M.RawMonad.R (backRawEq i) = Req i Monoidal.RawMonad.R (toMonoidalRawEq i) = Req i
M.RawMonad.pureNT (backRawEq i) = pureNTEq i Monoidal.RawMonad.pureNT (toMonoidalRawEq i) = pureNTEq i
M.RawMonad.joinNT (backRawEq i) = joinNTEq i Monoidal.RawMonad.joinNT (toMonoidalRawEq i) = joinNTEq i
backeq : (m : M.Monad) back (forth m) m toMonoidaleq : (m : Monoidal.Monad) toMonoidal (toKleisli m) m
backeq m = M.Monad≡ (backRawEq m) toMonoidaleq m = Monoidal.Monad≡ (toMonoidalRawEq m)
eqv : isEquiv M.Monad K.Monad forth
eqv = gradLemma forth back fortheq backeq
open import Cat.Equivalence open import Cat.Equivalence
Monoidal≊Kleisli : M.Monad K.Monad Monoidal≊Kleisli : Monoidal.Monad Kleisli.Monad
Monoidal≊Kleisli = forth , back , funExt backeq , funExt fortheq Monoidal≊Kleisli = toKleisli , toMonoidal , funExt toMonoidaleq , funExt toKleislieq
Monoidal≡Kleisli : M.Monad K.Monad Monoidal≡Kleisli : Monoidal.Monad Kleisli.Monad
Monoidal≡Kleisli = isoToPath Monoidal≊Kleisli Monoidal≡Kleisli = isoToPath Monoidal≊Kleisli

View file

@ -18,7 +18,7 @@ private
open Category using (Object ; Arrow ; identity ; _<<<_) open Category using (Object ; Arrow ; identity ; _<<<_)
open import Cat.Category.NaturalTransformation open import Cat.Category.NaturalTransformation
using (NaturalTransformation ; Transformation ; Natural) using (NaturalTransformation ; Transformation ; Natural ; NaturalTransformation≡)
record RawMonad : Set where record RawMonad : Set where
field field
@ -78,15 +78,39 @@ record IsMonad (raw : RawMonad) : Set where
isNatural : IsNatural isNatural : IsNatural
isNatural {X} {Y} f = begin isNatural {X} {Y} f = begin
joinT Y <<< R.fmap f <<< pureT X ≡⟨ sym .isAssociative join <<< fmap f <<< pure ≡⟨ sym .isAssociative
joinT Y <<< (R.fmap f <<< pureT X) ≡⟨ cong (λ φ joinT Y <<< φ) (sym (pureN f)) join <<< (fmap f <<< pure) ≡⟨ cong (λ φ join <<< φ) (sym (pureN f))
joinT Y <<< (pureT (R.omap Y) <<< f) ≡⟨ .isAssociative join <<< (pure <<< f) ≡⟨ .isAssociative
joinT Y <<< pureT (R.omap Y) <<< f ≡⟨ cong (λ φ φ <<< f) (fst isInverse) join <<< pure <<< f ≡⟨ cong (λ φ φ <<< f) (fst isInverse)
identity <<< f ≡⟨ .leftIdentity identity <<< f ≡⟨ .leftIdentity
f f
isDistributive : IsDistributive isDistributive : IsDistributive
isDistributive {X} {Y} {Z} g f = sym aux isDistributive {X} {Y} {Z} g f = begin
join <<< fmap g <<< (join <<< fmap f)
≡⟨ Category.isAssociative
join <<< fmap g <<< join <<< fmap f
≡⟨ cong (_<<< fmap f) (sym .isAssociative)
(join <<< (fmap g <<< join)) <<< fmap f
≡⟨ cong (λ φ φ <<< fmap f) (cong (_<<<_ join) (sym (joinN g)))
(join <<< (join <<< R².fmap g)) <<< fmap f
≡⟨ cong (_<<< fmap f) .isAssociative
((join <<< join) <<< R².fmap g) <<< fmap f
≡⟨⟩
join <<< join <<< R².fmap g <<< fmap f
≡⟨ sym .isAssociative
(join <<< join) <<< (R².fmap g <<< fmap f)
≡⟨ cong (λ φ φ <<< (R².fmap g <<< fmap f)) (sym isAssociative)
(join <<< fmap join) <<< (R².fmap g <<< fmap f)
≡⟨ sym .isAssociative
join <<< (fmap join <<< (R².fmap g <<< fmap f))
≡⟨ cong (_<<<_ join) .isAssociative
join <<< (fmap join <<< R².fmap g <<< fmap f)
≡⟨⟩
join <<< (fmap join <<< fmap (fmap g) <<< fmap f)
≡⟨ cong (λ φ join <<< φ) (sym distrib3)
join <<< fmap (join <<< fmap g <<< f)
where where
module R² = Functor F[ R R ] module R² = Functor F[ R R ]
distrib3 : {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} distrib3 : {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B}
@ -96,31 +120,6 @@ record IsMonad (raw : RawMonad) : Set where
R.fmap (a <<< b <<< c) ≡⟨ R.isDistributive R.fmap (a <<< b <<< c) ≡⟨ R.isDistributive
R.fmap (a <<< b) <<< R.fmap c ≡⟨ cong (_<<< _) R.isDistributive R.fmap (a <<< b) <<< R.fmap c ≡⟨ cong (_<<< _) R.isDistributive
R.fmap a <<< R.fmap b <<< R.fmap c R.fmap a <<< R.fmap b <<< R.fmap c
aux = begin
joinT Z <<< R.fmap (joinT Z <<< R.fmap g <<< f)
≡⟨ cong (λ φ joinT Z <<< φ) distrib3
joinT Z <<< (R.fmap (joinT Z) <<< R.fmap (R.fmap g) <<< R.fmap f)
≡⟨⟩
joinT Z <<< (R.fmap (joinT Z) <<< R².fmap g <<< R.fmap f)
≡⟨ cong (_<<<_ (joinT Z)) (sym .isAssociative)
joinT Z <<< (R.fmap (joinT Z) <<< (R².fmap g <<< R.fmap f))
≡⟨ .isAssociative
(joinT Z <<< R.fmap (joinT Z)) <<< (R².fmap g <<< R.fmap f)
≡⟨ cong (λ φ φ <<< (R².fmap g <<< R.fmap f)) isAssociative
(joinT Z <<< joinT (R.omap Z)) <<< (R².fmap g <<< R.fmap f)
≡⟨ .isAssociative
joinT Z <<< joinT (R.omap Z) <<< R².fmap g <<< R.fmap f
≡⟨⟩
((joinT Z <<< joinT (R.omap Z)) <<< R².fmap g) <<< R.fmap f
≡⟨ cong (_<<< R.fmap f) (sym .isAssociative)
(joinT Z <<< (joinT (R.omap Z) <<< R².fmap g)) <<< R.fmap f
≡⟨ cong (λ φ φ <<< R.fmap f) (cong (_<<<_ (joinT Z)) (joinN g))
(joinT Z <<< (R.fmap g <<< joinT Y)) <<< R.fmap f
≡⟨ cong (_<<< R.fmap f) .isAssociative
joinT Z <<< R.fmap g <<< joinT Y <<< R.fmap f
≡⟨ sym (Category.isAssociative )
joinT Z <<< R.fmap g <<< (joinT Y <<< R.fmap f)
record Monad : Set where record Monad : Set where
field field

View file

@ -10,6 +10,8 @@ open import Cat.Category
open import Cat.Category.Functor as F open import Cat.Category.Functor as F
import Cat.Category.NaturalTransformation import Cat.Category.NaturalTransformation
open import Cat.Category.Monad open import Cat.Category.Monad
import Cat.Category.Monad.Monoidal as Monoidal
import Cat.Category.Monad.Kleisli as Kleisli
open import Cat.Categories.Fun open import Cat.Categories.Fun
open import Cat.Equivalence open import Cat.Equivalence