Expand definition of isDistributive somewhat

Also contains some side-tracks
This commit is contained in:
Frederik Hanghøj Iversen 2018-02-24 20:37:21 +01:00
parent e7abab0e4c
commit 9d09363f78
2 changed files with 61 additions and 10 deletions

View file

@ -41,6 +41,8 @@ record RawCategory (a b : Level) : Set (lsuc (a ⊔ b)) where
codomain : { a b : Object } Arrow a b Object codomain : { a b : Object } Arrow a b Object
codomain {b = b} _ = b codomain {b = b} _ = b
-- TODO: It seems counter-intuitive that the normal-form is on the
-- right-hand-side.
IsAssociative : Set (a b) IsAssociative : Set (a b)
IsAssociative = {A B C D} {f : Arrow A B} {g : Arrow B C} {h : Arrow C D} IsAssociative = {A B C D} {f : Arrow A B} {g : Arrow B C} {h : Arrow C D}
h (g f) (h g) f h (g f) (h g) f

View file

@ -21,10 +21,11 @@ module Monoidal {a b : Level} ( : Category a b) where
open NaturalTransformation open NaturalTransformation
record RawMonad : Set where record RawMonad : Set where
field field
-- R ~ m
R : Functor R : Functor
-- pure -- η ~ pure
ηNat : NaturalTransformation F.identity R ηNat : NaturalTransformation F.identity R
-- (>=>) -- μ ~ join
μNat : NaturalTransformation F[ R R ] R μNat : NaturalTransformation F[ R R ] R
η : Transformation F.identity R η : Transformation F.identity R
@ -59,6 +60,33 @@ module Monoidal {a b : Level} ( : Category a b) where
raw : RawMonad raw : RawMonad
isMonad : IsMonad raw isMonad : IsMonad raw
open IsMonad isMonad public open IsMonad isMonad public
module R = Functor R
module RR = Functor F[ R R ]
module _ {X Y Z : _} {g : [ Y , R.func* Z ]} {f : [ X , R.func* Y ]} where
lem : μ Z R.func→ g (μ Y R.func→ f) μ Z R.func→ (μ Z R.func→ g f)
lem = begin
μ Z R.func→ g (μ Y R.func→ f) ≡⟨ {!!}
μ Z R.func→ (μ Z R.func→ g f)
where
open Category using () renaming (isAssociative to c-assoc)
μN : Natural F[ R R ] R μ
-- μN : (f : [ Y , R.func* Z ]) → μ (R.func* Z) ∘ RR.func→ f ≡ R.func→ f ∘ μ Y
μN = proj₂ μNat
μg : μ (R.func* Z) RR.func→ g R.func→ g μ Y
μg = μN g
μf : μ (R.func* Y) RR.func→ f R.func→ f μ X
μf = μN f
ηN : Natural F.identity R η
ηN = proj₂ ηNat
ηg : η (R.func* Z) g R.func→ g η Y
ηg = ηN g
-- Alternate route:
res = begin
μ Z R.func→ g (μ Y R.func→ f) ≡⟨ c-assoc
μ Z R.func→ g μ Y R.func→ f ≡⟨ {!!}
μ Z (R.func→ g μ Y) R.func→ f ≡⟨ {!!}
μ Z (μ (R.func* Z) RR.func→ g) R.func→ f ≡⟨ {!!}
μ Z R.func→ (μ Z R.func→ g f)
-- "A monad in the Kleisli form" [voe] -- "A monad in the Kleisli form" [voe]
module Kleisli {a b : Level} ( : Category a b) where module Kleisli {a b : Level} ( : Category a b) where
@ -93,12 +121,32 @@ module Kleisli {a b : Level} ( : Category a b) where
_>=>_ : {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 = [ rr g f ]
-- fmap id ≡ id
IsIdentity = {X : Object} IsIdentity = {X : Object}
rr ζ 𝟙 {RR X} rr ζ 𝟙 {RR X}
IsNatural = {X Y : Object} (f : [ X , RR Y ]) IsNatural = {X Y : Object} (f : [ X , RR Y ])
( [ rr f ζ ]) f rr f ζ f
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 ]) rr g rr f rr (rr g f)
-- I assume `Fusion` is admissable - it certainly looks more like the
-- distributive law for monads I know from Haskell.
Fusion = {X Y Z : Object} (g : [ Y , Z ]) (f : [ X , Y ])
rr (ζ g f) rr (ζ g) rr (ζ f)
-- NatDist2Fus : IsNatural → IsDistributive → Fusion
-- NatDist2Fus isNatural isDistributive g f =
-- let
-- ζf = ζ ∘ f
-- ζg = ζ ∘ g
-- Nζf : rr (ζ ∘ f) ∘ ζ ≡ ζ ∘ f
-- Nζf = isNatural ζf
-- Nζg : rr (ζ ∘ g) ∘ ζ ≡ ζ ∘ g
-- Nζg = isNatural ζg
-- ζgf = ζ ∘ g ∘ f
-- Nζgf : rr (ζ ∘ g ∘ f) ∘ ζ ≡ ζ ∘ g ∘ f
-- Nζgf = isNatural ζgf
-- res : rr (ζ ∘ g ∘ f) ≡ rr (ζ ∘ g) ∘ rr (ζ ∘ f)
-- res = {!!}
-- in res
record IsMonad (raw : RawMonad) : Set where record IsMonad (raw : RawMonad) : Set where
open RawMonad raw public open RawMonad raw public
@ -130,9 +178,6 @@ module _ {a b : Level} { : Category a b} where
RR : Object Object RR : Object Object
RR = func* R RR = func* R
R→ : {A B : Object} [ A , B ] [ RR A , RR B ]
R→ = func→ R
ζ : {X : Object} [ X , RR X ] ζ : {X : Object} [ X , RR X ]
ζ {X} = η X ζ {X} = η X
@ -168,13 +213,17 @@ module _ {a b : Level} { : Category a b} where
𝟙 f ≡⟨ proj₂ .isIdentity 𝟙 f ≡⟨ proj₂ .isIdentity
f f
where where
module = Category
open NaturalTransformation open NaturalTransformation
module = Category
ηN : Natural F.identity R η ηN : Natural F.identity R η
ηN = proj₂ ηNat ηN = proj₂ ηNat
isDistributive : IsDistributive isDistributive : IsDistributive
isDistributive = {!!} isDistributive {X} {Y} {Z} g f = begin
rr g rr f ≡⟨⟩
μ Z R.func→ g (μ Y R.func→ f) ≡⟨ {!!}
μ Z R.func→ (μ Z R.func→ g f) ≡⟨⟩
μ Z R.func→ (rr g f)
forthIsMonad : K.IsMonad (forthRaw raw) forthIsMonad : K.IsMonad (forthRaw raw)
Kis.isIdentity forthIsMonad = isIdentity Kis.isIdentity forthIsMonad = isIdentity
@ -189,7 +238,7 @@ module _ {a b : Level} { : Category a b} where
back = {!!} back = {!!}
fortheq : (m : K.Monad) forth (back m) m fortheq : (m : K.Monad) forth (back m) m
fortheq = {!!} fortheq m = {!!}
backeq : (m : M.Monad) back (forth m) m backeq : (m : M.Monad) back (forth m) m
backeq = {!!} backeq = {!!}