Prove distributive law for monads!

This commit is contained in:
Frederik Hanghøj Iversen 2018-02-26 19:57:05 +01:00
parent 7cddba97a8
commit 043641462d

View file

@ -75,37 +75,37 @@ module Kleisli {a b : Level} ( : Category a b) where
RR : Object Object RR : Object Object
-- Note name-change from [voe] -- Note name-change from [voe]
ζ : {X : Object} [ X , RR X ] ζ : {X : Object} [ X , RR X ]
rr : {X Y : Object} [ X , RR Y ] [ RR X , RR Y ] bind : {X Y : Object} [ X , RR Y ] [ RR X , RR Y ]
-- Note the correspondance with Haskell:
--
-- RR ~ m
-- ζ ~ pure
-- rr ~ flip (>>=)
--
-- Where those things have these types:
--
-- m : 𝓤𝓤
-- pure : x → m x
-- flip (>>=) :: (a → m b) → m a → m b
--
pure : {X : Object} [ X , RR X ] pure : {X : Object} [ X , RR X ]
pure = ζ pure = ζ
fmap : {A B} [ A , B ] [ RR A , RR B ] fmap : {A B} [ A , B ] [ RR A , RR B ]
fmap f = rr (ζ f) fmap f = bind (ζ f)
-- Why is (>>=) not implementable? -- Why is (>>=) not implementable? - Because in e.g. the category of sets is
-- `m a` a set. This is not necessarily the case.
-- --
-- (>>=) : m a -> (a -> m b) -> m b -- (>>=) : m a -> (a -> m b) -> m b
-- (>=>) : (a -> m b) -> (b -> m c) -> a -> m c -- (>=>) : (a -> m b) -> (b -> m c) -> a -> m c
-- Is really like a lifting operation from ∘ (the low level of functions) to >=> (the level of monads)
_>>>_ : {A B C : Object} (Arrow A B) (Arrow B C) Arrow A C
f >>> g = g f
_>=>_ : {A B C : Object} [ A , RR B ] [ B , RR C ] [ A , RR C ] _>=>_ : {A B C : Object} [ A , RR B ] [ B , RR C ] [ A , RR C ]
f >=> g = rr g f f >=> g = f >>> (bind g)
-- _>>=_ : {A B C : Object} {m : RR A} → [ A , RR B ] → RR C
-- m >>= f = ?
join : {A : Object} [ RR (RR A) , RR A ]
join = bind 𝟙
-- fmap id ≡ id -- fmap id ≡ id
IsIdentity = {X : Object} IsIdentity = {X : Object}
rr ζ 𝟙 {RR X} -- aka. `>>= pure ≡ 𝟙`
bind pure 𝟙 {RR X}
IsNatural = {X Y : Object} (f : [ X , RR Y ]) IsNatural = {X Y : Object} (f : [ X , RR Y ])
rr f ζ f -- aka. `pure >>= f ≡ f`
pure >>> (bind f) f
-- Not stricly a distributive law, since ∘ becomes >=>
IsDistributive = {X Y Z : Object} (g : [ Y , RR Z ]) (f : [ X , RR Y ]) IsDistributive = {X Y Z : Object} (g : [ Y , RR Z ]) (f : [ X , RR Y ])
rr g rr f rr (rr g f) -- `>>= g . >>= f ≡ >>= (>>= g . f) ≡ >>= (\x -> (f x) >>= g)`
(bind f) >>> (bind g) bind (f >=> g)
Fusion = {X Y Z : Object} {g : [ Y , Z ]} {f : [ X , Y ]} Fusion = {X Y Z : Object} {g : [ Y , Z ]} {f : [ X , Y ]}
fmap (g f) fmap g fmap f fmap (g f) fmap g fmap f
@ -118,12 +118,19 @@ module Kleisli {a b : Level} ( : Category a b) where
fusion : Fusion fusion : Fusion
fusion {g = g} {f} = begin fusion {g = g} {f} = begin
fmap (g f) ≡⟨⟩ fmap (g f) ≡⟨⟩
rr (ζ (g f)) ≡⟨ {!!} -- f >=> g = >>= g ∘ f
rr (rr (ζ g) (ζ f)) ≡⟨ sym lem bind ((f >>> g) >>> pure) ≡⟨ cong bind isAssociative
rr (ζ g) rr (ζ f) ≡⟨⟩ bind (f >>> (g >>> pure)) ≡⟨ cong (λ φ bind (f >>> φ)) (sym (isNatural _))
bind (f >>> (pure >>> (bind (g >>> pure)))) ≡⟨⟩
bind (f >>> (pure >>> fmap g)) ≡⟨⟩
bind ((fmap g pure) f) ≡⟨ cong bind (sym isAssociative)
bind
(fmap g (pure f)) ≡⟨ sym lem
bind (ζ g) bind (ζ f) ≡⟨⟩
fmap g fmap f fmap g fmap f
where where
lem : rr (ζ g) rr (ζ f) rr (rr (ζ g) (ζ f)) open Category using (isAssociative)
lem : fmap g fmap f bind (fmap g (pure f))
lem = isDistributive (ζ g) (ζ f) lem = isDistributive (ζ g) (ζ f)
record Monad : Set where record Monad : Set where
@ -161,13 +168,13 @@ module _ {a b : Level} { : Category a b} where
ζ : {X : Object} [ X , RR X ] ζ : {X : Object} [ X , RR X ]
ζ {X} = η X ζ {X} = η X
rr : {X Y : Object} [ X , RR Y ] [ RR X , RR Y ] bind : {X Y : Object} [ X , RR Y ] [ RR X , RR Y ]
rr {X} {Y} f = μ Y func→ R f bind {X} {Y} f = μ Y func→ R f
forthRaw : K.RawMonad forthRaw : K.RawMonad
Kraw.RR forthRaw = RR Kraw.RR forthRaw = RR
Kraw.ζ forthRaw = ζ Kraw.ζ forthRaw = ζ
Kraw.rr forthRaw = rr Kraw.bind forthRaw = bind
module _ {raw : M.RawMonad} (m : M.IsMonad raw) where module _ {raw : M.RawMonad} (m : M.IsMonad raw) where
private private
@ -177,16 +184,16 @@ module _ {a b : Level} { : Category a b} where
isIdentity : IsIdentity isIdentity : IsIdentity
isIdentity {X} = begin isIdentity {X} = begin
rr ζ ≡⟨⟩ bind ζ ≡⟨⟩
rr (η X) ≡⟨⟩ bind (η X) ≡⟨⟩
μ X func→ R (η X) ≡⟨ proj₂ isInverse μ X func→ R (η X) ≡⟨ proj₂ isInverse
𝟙 𝟙
module R = Functor R module R = Functor R
isNatural : IsNatural isNatural : IsNatural
isNatural {X} {Y} f = begin isNatural {X} {Y} f = begin
rr f ζ ≡⟨⟩ bind f ζ ≡⟨⟩
rr f η X ≡⟨⟩ bind f η X ≡⟨⟩
μ Y R.func→ f η X ≡⟨ sym .isAssociative μ Y R.func→ f η X ≡⟨ sym .isAssociative
μ Y (R.func→ f η X) ≡⟨ cong (λ φ μ Y φ) (sym (ηN f)) μ Y (R.func→ f η X) ≡⟨ cong (λ φ μ Y φ) (sym (ηN f))
μ Y (η (R.func* Y) f) ≡⟨ .isAssociative μ Y (η (R.func* Y) f) ≡⟨ .isAssociative
@ -201,10 +208,10 @@ module _ {a b : Level} { : Category a b} where
isDistributive : IsDistributive isDistributive : IsDistributive
isDistributive {X} {Y} {Z} g f = begin isDistributive {X} {Y} {Z} g f = begin
rr g rr f ≡⟨⟩ bind g bind f ≡⟨⟩
μ Z R.func→ g (μ Y R.func→ f) ≡⟨ sym lem2 μ Z R.func→ g (μ Y R.func→ f) ≡⟨ sym lem2
μ Z R.func→ (μ Z R.func→ g f) ≡⟨⟩ μ Z R.func→ (μ Z R.func→ g f) ≡⟨⟩
μ Z R.func→ (rr g f) μ Z R.func→ (bind g f)
where where
-- Proved it in reverse here... otherwise it could be neatly inlined. -- Proved it in reverse here... otherwise it could be neatly inlined.
lem2 lem2
@ -253,18 +260,18 @@ module _ {a b : Level} { : Category a b} where
rawR : RawFunctor rawR : RawFunctor
RawFunctor.func* rawR = RR RawFunctor.func* rawR = RR
RawFunctor.func→ rawR f = rr (ζ f) RawFunctor.func→ rawR f = bind (ζ f)
isFunctorR : IsFunctor rawR isFunctorR : IsFunctor rawR
IsFunctor.isIdentity isFunctorR = begin IsFunctor.isIdentity isFunctorR = begin
rr (ζ 𝟙) ≡⟨ cong rr (proj₁ .isIdentity) bind (ζ 𝟙) ≡⟨ cong bind (proj₁ .isIdentity)
rr ζ ≡⟨ isIdentity bind ζ ≡⟨ isIdentity
𝟙 𝟙
IsFunctor.isDistributive isFunctorR {f = f} {g} = begin IsFunctor.isDistributive isFunctorR {f = f} {g} = begin
rr (ζ (g f)) ≡⟨⟩ bind (ζ (g f)) ≡⟨⟩
fmap (g f) ≡⟨ fusion fmap (g f) ≡⟨ fusion
fmap g fmap f ≡⟨⟩ fmap g fmap f ≡⟨⟩
rr (ζ g) rr (ζ f) bind (ζ g) bind (ζ f)
R : Functor R : Functor
Functor.raw R = rawR Functor.raw R = rawR
@ -303,7 +310,7 @@ module _ {a b : Level} { : Category a b} where
K.RawMonad.RR (forthRawEq _) = RR K.RawMonad.RR (forthRawEq _) = RR
K.RawMonad.ζ (forthRawEq _) = ζ K.RawMonad.ζ (forthRawEq _) = ζ
-- stuck -- stuck
K.RawMonad.rr (forthRawEq i) = {!!} K.RawMonad.bind (forthRawEq i) = {!!}
fortheq : (m : K.Monad) forth (back m) m fortheq : (m : K.Monad) forth (back m) m
fortheq m = K.Monad≡ (forthRawEq m) fortheq m = K.Monad≡ (forthRawEq m)