fredefox/cat
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Rename eta and mu

Browse source
This commit is contained in:
Frederik Hanghøj Iversen 2018-03-06 09:30:41 +01:00
parent f8e08288a0
commit 35419ad86e
1 changed files with 69 additions and 71 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

140
src/Cat/Category/Monad.agda
View file

@ -25,34 +25,32 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
-- TODO rename fields here -- TODO rename fields here
-- R ~ m -- R ~ m
R : EndoFunctor ℂ R : EndoFunctor ℂ
-- η ~ pure pureNT : NaturalTransformation F.identity R
ηNatTrans : NaturalTransformation F.identity R joinNT : NaturalTransformation F[ R ∘ R ] R
-- μ ~ join
μNatTrans : NaturalTransformation F[ R ∘ R ] R
η : Transformation F.identity R pureT : Transformation F.identity R
η = proj₁ ηNatTrans pureT = proj₁ pureNT
ηNat : Natural F.identity R η pureN : Natural F.identity R pureT
ηNat = proj₂ ηNatTrans pureN = proj₂ pureNT
μ : Transformation F[ R ∘ R ] R joinT : Transformation F[ R ∘ R ] R
μ = proj₁ μNatTrans joinT = proj₁ joinNT
μNat : Natural F[ R ∘ R ] R μ joinN : Natural F[ R ∘ R ] R joinT
μNat = proj₂ μNatTrans joinN = proj₂ joinNT
private private
module R = Functor R module R = Functor R
IsAssociative : Set _ IsAssociative : Set _
IsAssociative = {X : Object} IsAssociative = {X : Object}
→ μ X ∘ R.func→ (μ X) ≡ μ X ∘ μ (R.func* X) → joinT X ∘ R.func→ (joinT X) ≡ joinT X ∘ joinT (R.func* X)
IsInverse : Set _ IsInverse : Set _
IsInverse = {X : Object} IsInverse = {X : Object}
→ μ X ∘ η (R.func* X) ≡ 𝟙 → joinT X ∘ pureT (R.func* X) ≡ 𝟙
× μ X ∘ R.func→ (η X) ≡ 𝟙 × joinT X ∘ R.func→ (pureT X) ≡ 𝟙
IsNatural = ∀ {X Y} f → μ Y ∘ R.func→ f ∘ η X ≡ f IsNatural = ∀ {X Y} f → joinT Y ∘ R.func→ f ∘ pureT X ≡ f
IsDistributive = ∀ {X Y Z} (g : Arrow Y (R.func* Z)) (f : Arrow X (R.func* Y)) IsDistributive = ∀ {X Y Z} (g : Arrow Y (R.func* Z)) (f : Arrow X (R.func* Y))
→ μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) → joinT Z ∘ R.func→ g ∘ (joinT Y ∘ R.func→ f)
≡ μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡ joinT Z ∘ R.func→ (joinT Z ∘ R.func→ g ∘ f)
record IsMonad (raw : RawMonad) : Set ℓ where record IsMonad (raw : RawMonad) : Set ℓ where
open RawMonad raw public open RawMonad raw public
@ -66,10 +64,10 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
isNatural : IsNatural isNatural : IsNatural
isNatural {X} {Y} f = begin isNatural {X} {Y} f = begin
μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ joinT Y ∘ R.func→ f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩
μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηNat f)) ⟩ joinT Y ∘ (R.func→ f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩
μ Y ∘ (η (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ joinT Y ∘ (pureT (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩
μ Y ∘ η (R.func* Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ joinT Y ∘ pureT (R.func* Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩
𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩
f ∎ f ∎
@ -98,33 +96,33 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
a ∘ b ∘ c ∘ d ∎ a ∘ b ∘ c ∘ d ∎
where where
asc = ℂ.isAssociative asc = ℂ.isAssociative
lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) lemmm : joinT Z ∘ R.func→ (joinT Z) ≡ joinT Z ∘ joinT (R.func* Z)
lemmm = isAssociative lemmm = isAssociative
lem4 : μ (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ μ Y lem4 : joinT (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ joinT Y
lem4 = μNat g lem4 = joinN g
done = begin done = begin
μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) joinT Z ∘ R.func→ (joinT Z ∘ R.func→ g ∘ f)
≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ ≡⟨ cong (λ φ → joinT Z ∘ φ) distrib ⟩
μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) joinT Z ∘ (R.func→ (joinT Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f)
≡⟨⟩ ≡⟨⟩
μ Z ∘ (R.func→ (μ Z) ∘ R².func→ g ∘ R.func→ f) joinT Z ∘ (R.func→ (joinT Z) ∘ R².func→ g ∘ R.func→ f)
≡⟨ cong (_∘_ (μ Z)) (sym ℂ.isAssociative) ⟩ -- ●-solver? ≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩ -- ●-solver?
μ Z ∘ (R.func→ (μ Z) ∘ (R².func→ g ∘ R.func→ f)) joinT Z ∘ (R.func→ (joinT Z) ∘ (R².func→ g ∘ R.func→ f))
≡⟨ ℂ.isAssociative ⟩ ≡⟨ ℂ.isAssociative ⟩
(μ Z ∘ R.func→ (μ Z)) ∘ (R².func→ g ∘ R.func→ f) (joinT Z ∘ R.func→ (joinT Z)) ∘ (R².func→ g ∘ R.func→ f)
≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) isAssociative ⟩ ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) isAssociative ⟩
(μ Z ∘ μ (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) (joinT Z ∘ joinT (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f)
≡⟨ ℂ.isAssociative ⟩ -- ●-solver? ≡⟨ ℂ.isAssociative ⟩ -- ●-solver?
μ Z ∘ μ (R.func* Z) ∘ R².func→ g ∘ R.func→ f joinT Z ∘ joinT (R.func* Z) ∘ R².func→ g ∘ R.func→ f
≡⟨⟩ -- ●-solver + lem4 ≡⟨⟩ -- ●-solver + lem4
((μ Z ∘ μ (R.func* Z)) ∘ R².func→ g) ∘ R.func→ f ((joinT Z ∘ joinT (R.func* Z)) ∘ R².func→ g) ∘ R.func→ f
≡⟨ cong (_∘ R.func→ f) (sym ℂ.isAssociative) ⟩ ≡⟨ cong (_∘ R.func→ f) (sym ℂ.isAssociative) ⟩
(μ Z ∘ (μ (R.func* Z) ∘ R².func→ g)) ∘ R.func→ f (joinT Z ∘ (joinT (R.func* Z) ∘ R².func→ g)) ∘ R.func→ f
≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (μ Z)) lem4) ⟩ ≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (joinT Z)) lem4) ⟩
(μ Z ∘ (R.func→ g ∘ μ Y)) ∘ R.func→ f ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩ (joinT Z ∘ (R.func→ g ∘ joinT Y)) ∘ R.func→ f ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩
μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f joinT Z ∘ R.func→ g ∘ joinT Y ∘ R.func→ f
≡⟨ sym (Category.isAssociative ℂ) ⟩ ≡⟨ sym (Category.isAssociative ℂ) ⟩
μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) joinT Z ∘ R.func→ g ∘ (joinT Y ∘ R.func→ f)
∎ ∎
record Monad : Set ℓ where record Monad : Set ℓ where
@ -279,19 +277,19 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
module R = Functor R module R = Functor R
module R⁰ = Functor R⁰ module R⁰ = Functor R⁰
module R² = Functor R² module R² = Functor R²
η : Transformation R⁰ R pureT : Transformation R⁰ R
η A = pure pureT A = pure
ηNatural : Natural R⁰ R η pureTNatural : Natural R⁰ R pureT
ηNatural {A} {B} f = begin pureTNatural {A} {B} f = begin
η B ∘ R⁰.func→ f ≡⟨⟩ pureT B ∘ R⁰.func→ f ≡⟨⟩
pure ∘ f ≡⟨ sym (isNatural _) ⟩ pure ∘ f ≡⟨ sym (isNatural _) ⟩
bind (pure ∘ f) ∘ pure ≡⟨⟩ bind (pure ∘ f) ∘ pure ≡⟨⟩
fmap f ∘ pure ≡⟨⟩ fmap f ∘ pure ≡⟨⟩
R.func→ f ∘ η A ∎ R.func→ f ∘ pureT A ∎
μ : Transformation R² R joinT : Transformation R² R
μ C = join joinT C = join
μNatural : Natural R² R μ joinTNatural : Natural R² R joinT
μNatural f = begin joinTNatural f = begin
join ∘ R².func→ f ≡⟨⟩ join ∘ R².func→ f ≡⟨⟩
bind 𝟙 ∘ R².func→ f ≡⟨⟩ bind 𝟙 ∘ R².func→ f ≡⟨⟩
R².func→ f >>> bind 𝟙 ≡⟨⟩ R².func→ f >>> bind 𝟙 ≡⟨⟩
@ -319,13 +317,13 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
R.func→ f ∘ join ∎ R.func→ f ∘ join ∎
where where
ηNatTrans : NaturalTransformation R⁰ R pureNT : NaturalTransformation R⁰ R
proj₁ ηNatTrans = η proj₁ pureNT = pureT
proj₂ ηNatTrans = ηNatural proj₂ pureNT = pureTNatural
μNatTrans : NaturalTransformation R² R joinNT : NaturalTransformation R² R
proj₁ μNatTrans = μ proj₁ joinNT = joinT
proj₂ μNatTrans = μNatural proj₂ joinNT = joinTNatural
isNaturalForeign : IsNaturalForeign isNaturalForeign : IsNaturalForeign
isNaturalForeign = begin isNaturalForeign = begin
@ -421,10 +419,10 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where
RR = func* R RR = func* R
pure : {X : Object} → ℂ [ X , RR X ] pure : {X : Object} → ℂ [ X , RR X ]
pure {X} = η X pure {X} = pureT X
bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ]
bind {X} {Y} f = μ Y ∘ func→ R f bind {X} {Y} f = joinT Y ∘ func→ R f
forthRaw : K.RawMonad forthRaw : K.RawMonad
Kraw.RR forthRaw = RR Kraw.RR forthRaw = RR
@ -452,8 +450,8 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where
backRaw : M.RawMonad backRaw : M.RawMonad
MR.R backRaw = R MR.R backRaw = R
MR.ηNatTrans backRaw = ηNatTrans MR.pureNT backRaw = pureNT
MR.μNatTrans backRaw = μNatTrans MR.joinNT backRaw = joinNT
private private
open MR backRaw open MR backRaw
@ -461,19 +459,19 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where
backIsMonad : M.IsMonad backRaw backIsMonad : M.IsMonad backRaw
MI.isAssociative backIsMonad {X} = begin MI.isAssociative backIsMonad {X} = begin
μ X ∘ R.func→ (μ X) ≡⟨⟩ joinT X ∘ R.func→ (joinT X) ≡⟨⟩
join ∘ fmap (μ X) ≡⟨⟩ join ∘ fmap (joinT X) ≡⟨⟩
join ∘ fmap join ≡⟨ isNaturalForeign ⟩ join ∘ fmap join ≡⟨ isNaturalForeign ⟩
join ∘ join ≡⟨⟩ join ∘ join ≡⟨⟩
μ X ∘ μ (R.func* X) ∎ joinT X ∘ joinT (R.func* X) ∎
MI.isInverse backIsMonad {X} = inv-l , inv-r MI.isInverse backIsMonad {X} = inv-l , inv-r
where where
inv-l = begin inv-l = begin
μ X ∘ η (R.func* X) ≡⟨⟩ joinT X ∘ pureT (R.func* X) ≡⟨⟩
join ∘ pure ≡⟨ proj₁ isInverse ⟩ join ∘ pure ≡⟨ proj₁ isInverse ⟩
𝟙 ∎ 𝟙 ∎
inv-r = begin inv-r = begin
μ X ∘ R.func→ (η X) ≡⟨⟩ joinT X ∘ R.func→ (pureT X) ≡⟨⟩
join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩ join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩
𝟙 ∎ 𝟙 ∎
@ -490,13 +488,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where
≡ K.RawMonad.bind (K.Monad.raw m) ≡ K.RawMonad.bind (K.Monad.raw m)
bindEq {X} {Y} = begin bindEq {X} {Y} = begin
K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩ K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩
(λ f → μ Y ∘ func→ R f) ≡⟨⟩ (λ f → joinT Y ∘ func→ R f) ≡⟨⟩
(λ f → join ∘ fmap f) ≡⟨⟩ (λ f → join ∘ fmap f) ≡⟨⟩
(λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩ (λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩
(λ f → bind f) ≡⟨⟩ (λ f → bind f) ≡⟨⟩
bind ∎ bind ∎
where where
μ = proj₁ μNatTrans joinT = proj₁ joinNT
lem : (f : Arrow X (RR Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f lem : (f : Arrow X (RR Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f
lem f = begin lem f = begin
bind (f >>> pure) >>> bind 𝟙 bind (f >>> pure) >>> bind 𝟙
@ -569,13 +567,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where
open NaturalTransformation ℂ ℂ open NaturalTransformation ℂ ℂ
postulate postulate
ηNatTransEq : (λ i → NaturalTransformation F.identity (Req i)) pureNTEq : (λ i → NaturalTransformation F.identity (Req i))
[ M.RawMonad.ηNatTrans (backRaw (forth m)) ≡ ηNatTrans ] [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ]
backRawEq : backRaw (forth m) ≡ M.Monad.raw m backRawEq : backRaw (forth m) ≡ M.Monad.raw m
-- stuck -- stuck
M.RawMonad.R (backRawEq i) = Req i M.RawMonad.R (backRawEq i) = Req i
M.RawMonad.ηNatTrans (backRawEq i) = {!!} -- ηNatTransEq i M.RawMonad.pureNT (backRawEq i) = {!!} -- pureNTEq i
M.RawMonad.μNatTrans (backRawEq i) = {!!} M.RawMonad.joinNT (backRawEq i) = {!!}
backeq : (m : M.Monad) → back (forth m) ≡ m backeq : (m : M.Monad) → back (forth m) ≡ m
backeq m = M.Monad≡ (backRawEq m) backeq m = M.Monad≡ (backRawEq m)