From 7cddba97a85f83d360174b2ae070513ec01c5fdb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Sun, 25 Feb 2018 19:03:30 +0100 Subject: [PATCH 01/91] Shorten definition --- src/Cat/Category/Monad.agda | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 92805e0..9b80df3 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -35,19 +35,13 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private module R = Functor R - module RR = Functor F[ R ∘ R ] - module _ {X : Object} where - IsAssociative' : Set _ - IsAssociative' = μ X ∘ R.func→ (μ X) ≡ μ X ∘ μ (R.func* X) - IsInverse' : Set _ - IsInverse' - = μ X ∘ η (R.func* X) ≡ 𝟙 - × μ X ∘ R.func→ (η X) ≡ 𝟙 - - -- We don't want the objects to be indexes of the type, but rather just - -- universally quantify over *all* objects of the category. - IsAssociative = {X : Object} → IsAssociative' {X} - IsInverse = {X : Object} → IsInverse' {X} + IsAssociative : Set _ + IsAssociative = {X : Object} + → μ X ∘ R.func→ (μ X) ≡ μ X ∘ μ (R.func* X) + IsInverse : Set _ + IsInverse = {X : Object} + → μ X ∘ η (R.func* X) ≡ 𝟙 + × μ X ∘ R.func→ (η X) ≡ 𝟙 record IsMonad (raw : RawMonad) : Set ℓ where open RawMonad raw public From 043641462d6739fe03b7ba0a25ec32f729978a7a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 26 Feb 2018 19:57:05 +0100 Subject: [PATCH 02/91] Prove distributive law for monads! --- src/Cat/Category/Monad.agda | 83 ++++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 38 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 9b80df3..9afb396 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -75,37 +75,37 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where RR : Object → Object -- Note name-change from [voe] ζ : {X : Object} → ℂ [ X , RR X ] - rr : {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 - -- + bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] pure : {X : Object} → ℂ [ X , RR X ] pure = ζ fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ RR A , RR B ] - fmap f = rr (ζ ∘ f) - -- Why is (>>=) not implementable? + fmap f = bind (ζ ∘ f) + -- 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 -- (>=>) : (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 ] - 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 IsIdentity = {X : Object} - → rr ζ ≡ 𝟙 {RR X} + -- aka. `>>= pure ≡ 𝟙` + → bind pure ≡ 𝟙 {RR X} 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 ]) - → 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 ]} → fmap (g ∘ f) ≡ fmap g ∘ fmap f @@ -118,12 +118,19 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where fusion : Fusion fusion {g = g} {f} = begin fmap (g ∘ f) ≡⟨⟩ - rr (ζ ∘ (g ∘ f)) ≡⟨ {!!} ⟩ - rr (rr (ζ ∘ g) ∘ (ζ ∘ f)) ≡⟨ sym lem ⟩ - rr (ζ ∘ g) ∘ rr (ζ ∘ f) ≡⟨⟩ + -- f >=> g = >>= g ∘ f + bind ((f >>> g) >>> pure) ≡⟨ cong bind isAssociative ⟩ + 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 ∎ 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) record Monad : Set ℓ where @@ -161,13 +168,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where ζ : {X : Object} → ℂ [ X , RR X ] ζ {X} = η X - rr : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] - rr {X} {Y} f = μ Y ∘ func→ R f + bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] + bind {X} {Y} f = μ Y ∘ func→ R f forthRaw : K.RawMonad Kraw.RR forthRaw = RR Kraw.ζ forthRaw = ζ - Kraw.rr forthRaw = rr + Kraw.bind forthRaw = bind module _ {raw : M.RawMonad} (m : M.IsMonad raw) where private @@ -177,16 +184,16 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where isIdentity : IsIdentity isIdentity {X} = begin - rr ζ ≡⟨⟩ - rr (η X) ≡⟨⟩ + bind ζ ≡⟨⟩ + bind (η X) ≡⟨⟩ μ X ∘ func→ R (η X) ≡⟨ proj₂ isInverse ⟩ 𝟙 ∎ module R = Functor R isNatural : IsNatural isNatural {X} {Y} f = begin - rr f ∘ ζ ≡⟨⟩ - rr f ∘ η X ≡⟨⟩ + bind f ∘ ζ ≡⟨⟩ + bind f ∘ η X ≡⟨⟩ μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηN f)) ⟩ μ Y ∘ (η (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ @@ -201,10 +208,10 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where isDistributive : IsDistributive 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→ (μ Z ∘ R.func→ g ∘ f) ≡⟨⟩ - μ Z ∘ R.func→ (rr g ∘ f) ∎ + μ Z ∘ R.func→ (bind g ∘ f) ∎ where -- Proved it in reverse here... otherwise it could be neatly inlined. lem2 @@ -253,18 +260,18 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where rawR : RawFunctor ℂ ℂ RawFunctor.func* rawR = RR - RawFunctor.func→ rawR f = rr (ζ ∘ f) + RawFunctor.func→ rawR f = bind (ζ ∘ f) isFunctorR : IsFunctor ℂ ℂ rawR IsFunctor.isIdentity isFunctorR = begin - rr (ζ ∘ 𝟙) ≡⟨ cong rr (proj₁ ℂ.isIdentity) ⟩ - rr ζ ≡⟨ isIdentity ⟩ + bind (ζ ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ + bind ζ ≡⟨ isIdentity ⟩ 𝟙 ∎ IsFunctor.isDistributive isFunctorR {f = f} {g} = begin - rr (ζ ∘ (g ∘ f)) ≡⟨⟩ + bind (ζ ∘ (g ∘ f)) ≡⟨⟩ fmap (g ∘ f) ≡⟨ fusion ⟩ fmap g ∘ fmap f ≡⟨⟩ - rr (ζ ∘ g) ∘ rr (ζ ∘ f) ∎ + bind (ζ ∘ g) ∘ bind (ζ ∘ f) ∎ R : Functor ℂ ℂ Functor.raw R = rawR @@ -303,7 +310,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where K.RawMonad.RR (forthRawEq _) = RR K.RawMonad.ζ (forthRawEq _) = ζ -- stuck - K.RawMonad.rr (forthRawEq i) = {!!} + K.RawMonad.bind (forthRawEq i) = {!!} fortheq : (m : K.Monad) → forth (back m) ≡ m fortheq m = K.Monad≡ (forthRawEq m) From 47882b1110a8947efb584a6f3549851f9dc1dc18 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 26 Feb 2018 19:58:27 +0100 Subject: [PATCH 03/91] Rename zeta to pure --- src/Cat/Category/Monad.agda | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 9afb396..e59865a 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -74,12 +74,10 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where field RR : Object → Object -- Note name-change from [voe] - ζ : {X : Object} → ℂ [ X , RR X ] + pure : {X : Object} → ℂ [ X , RR X ] bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] - pure : {X : Object} → ℂ [ X , RR X ] - pure = ζ fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ RR A , RR B ] - fmap f = bind (ζ ∘ f) + fmap f = bind (pure ∘ f) -- Why is (>>=) not implementable? - Because in e.g. the category of sets is -- `m a` a set. This is not necessarily the case. -- @@ -126,12 +124,12 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where bind ((fmap g ∘ pure) ∘ f) ≡⟨ cong bind (sym isAssociative) ⟩ bind (fmap g ∘ (pure ∘ f)) ≡⟨ sym lem ⟩ - bind (ζ ∘ g) ∘ bind (ζ ∘ f) ≡⟨⟩ + bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ fmap g ∘ fmap f ∎ where open Category ℂ using (isAssociative) lem : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) - lem = isDistributive (ζ ∘ g) (ζ ∘ f) + lem = isDistributive (pure ∘ g) (pure ∘ f) record Monad : Set ℓ where field @@ -165,15 +163,15 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where RR : Object → Object RR = func* R - ζ : {X : Object} → ℂ [ X , RR X ] - ζ {X} = η X + pure : {X : Object} → ℂ [ X , RR X ] + pure {X} = η X bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] bind {X} {Y} f = μ Y ∘ func→ R f forthRaw : K.RawMonad Kraw.RR forthRaw = RR - Kraw.ζ forthRaw = ζ + Kraw.pure forthRaw = pure Kraw.bind forthRaw = bind module _ {raw : M.RawMonad} (m : M.IsMonad raw) where @@ -184,7 +182,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where isIdentity : IsIdentity isIdentity {X} = begin - bind ζ ≡⟨⟩ + bind pure ≡⟨⟩ bind (η X) ≡⟨⟩ μ X ∘ func→ R (η X) ≡⟨ proj₂ isInverse ⟩ 𝟙 ∎ @@ -192,7 +190,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module R = Functor R isNatural : IsNatural isNatural {X} {Y} f = begin - bind f ∘ ζ ≡⟨⟩ + bind f ∘ pure ≡⟨⟩ bind f ∘ η X ≡⟨⟩ μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηN f)) ⟩ @@ -260,18 +258,18 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where rawR : RawFunctor ℂ ℂ RawFunctor.func* rawR = RR - RawFunctor.func→ rawR f = bind (ζ ∘ f) + RawFunctor.func→ rawR f = bind (pure ∘ f) isFunctorR : IsFunctor ℂ ℂ rawR IsFunctor.isIdentity isFunctorR = begin - bind (ζ ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ - bind ζ ≡⟨ isIdentity ⟩ + bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ + bind pure ≡⟨ isIdentity ⟩ 𝟙 ∎ IsFunctor.isDistributive isFunctorR {f = f} {g} = begin - bind (ζ ∘ (g ∘ f)) ≡⟨⟩ + bind (pure ∘ (g ∘ f)) ≡⟨⟩ fmap (g ∘ f) ≡⟨ fusion ⟩ fmap g ∘ fmap f ≡⟨⟩ - bind (ζ ∘ g) ∘ bind (ζ ∘ f) ∎ + bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ R : Functor ℂ ℂ Functor.raw R = rawR @@ -308,7 +306,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open K.RawMonad (K.Monad.raw m) forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m K.RawMonad.RR (forthRawEq _) = RR - K.RawMonad.ζ (forthRawEq _) = ζ + K.RawMonad.pure (forthRawEq _) = pure -- stuck K.RawMonad.bind (forthRawEq i) = {!!} From 67993be27bdb083b06796bf54369f8333e6a9773 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 26 Feb 2018 19:59:11 +0100 Subject: [PATCH 04/91] Add reverse function composition to category --- src/Cat/Category.agda | 3 +++ src/Cat/Category/Monad.agda | 8 +------- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index d70fc65..3a275c8 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -86,6 +86,9 @@ record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where codomain : { a b : Object } → Arrow a b → Object codomain {b = b} _ = b + _>>>_ : {A B C : Object} → (Arrow A B) → (Arrow B C) → Arrow A C + f >>> g = g ∘ f + -- | Laws about the data -- TODO: It seems counter-intuitive that the normal-form is on the diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index e59865a..d7d2dc9 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -69,7 +69,7 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private ℓ = ℓa ⊔ ℓb - open Category ℂ using (Arrow ; 𝟙 ; Object ; _∘_) + open Category ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) record RawMonad : Set ℓ where field RR : Object → Object @@ -80,12 +80,6 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where fmap f = bind (pure ∘ f) -- 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 - -- (>=>) : (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 ] f >=> g = f >>> (bind g) -- _>>=_ : {A B C : Object} {m : RR A} → ℂ [ A , RR B ] → RR C From a0944d69b1740c9ff4a574c7cf2c0222e70c14b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 26 Feb 2018 20:08:48 +0100 Subject: [PATCH 05/91] Documentation in Monad --- src/Cat/Category/Monad.agda | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index d7d2dc9..e457106 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -70,34 +70,49 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where ℓ = ℓa ⊔ ℓb open Category ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) + + -- | Data for a monad. + -- + -- Note that (>>=) is not expressible in a general category because objects + -- are not generally types. record RawMonad : Set ℓ where field RR : Object → Object -- Note name-change from [voe] pure : {X : Object} → ℂ [ X , RR X ] bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] + + -- | functor map + -- + -- This should perhaps be defined in a "Klesli-version" of functors as well? fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ RR A , RR B ] fmap f = bind (pure ∘ f) - -- Why is (>>=) not implementable? - Because in e.g. the category of sets is - -- `m a` a set. This is not necessarily the case. + + -- | Composition of monads aka. the kleisli-arrow. _>=>_ : {A B C : Object} → ℂ [ A , RR B ] → ℂ [ B , RR C ] → ℂ [ A , RR C ] f >=> g = f >>> (bind g) - -- _>>=_ : {A B C : Object} {m : RR A} → ℂ [ A , RR B ] → RR C - -- m >>= f = ? + + -- | Flattening nested monads. join : {A : Object} → ℂ [ RR (RR A) , RR A ] join = bind 𝟙 - -- fmap id ≡ id + ------------------ + -- * Monad laws -- + ------------------ + + -- There may be better names than what I've chosen here. + IsIdentity = {X : Object} - -- aka. `>>= pure ≡ 𝟙` → bind pure ≡ 𝟙 {RR X} IsNatural = {X Y : Object} (f : ℂ [ X , RR Y ]) - -- 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 ]) - -- `>>= g . >>= f ≡ >>= (>>= g . f) ≡ >>= (\x -> (f x) >>= g)` → (bind f) >>> (bind g) ≡ bind (f >=> g) + + -- | Functor map fusion. + -- + -- This is really a functor law. Should we have a kleisli-representation of + -- functors as well and make them a super-class? Fusion = {X Y Z : Object} {g : ℂ [ Y , Z ]} {f : ℂ [ X , Y ]} → fmap (g ∘ f) ≡ fmap g ∘ fmap f From 5b5d21f777afc5c7ca03ba1d6d04fe979e235479 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 26 Feb 2018 20:23:31 +0100 Subject: [PATCH 06/91] Formatting --- src/Cat/Category/Monad.agda | 85 +++++++++++++++++++------------------ 1 file changed, 44 insertions(+), 41 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index e457106..bf3b4ec 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -24,14 +24,14 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- R ~ m R : Functor ℂ ℂ -- η ~ pure - ηNat : NaturalTransformation F.identity R + ηNatTrans : NaturalTransformation F.identity R -- μ ~ join - μNat : NaturalTransformation F[ R ∘ R ] R + μNatTrans : NaturalTransformation F[ R ∘ R ] R η : Transformation F.identity R - η = proj₁ ηNat + η = proj₁ ηNatTrans μ : Transformation F[ R ∘ R ] R - μ = proj₁ μNat + μ = proj₁ μNatTrans private module R = Functor R @@ -122,17 +122,17 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isIdentity : IsIdentity isNatural : IsNatural isDistributive : IsDistributive + + -- | Map fusion is admissable. fusion : Fusion fusion {g = g} {f} = begin - fmap (g ∘ f) ≡⟨⟩ - -- f >=> g = >>= g ∘ f + fmap (g ∘ f) ≡⟨⟩ bind ((f >>> g) >>> pure) ≡⟨ cong bind isAssociative ⟩ 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 (fmap g ∘ (pure ∘ f)) ≡⟨ sym lem ⟩ bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ fmap g ∘ fmap f ∎ where @@ -155,7 +155,9 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where res : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] res = {!!} --- Problem 2.3 +-- | The monoidal- and kleisli presentation of monads are equivalent. +-- +-- This is problem 2.3 in [voe]. module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private open Category ℂ using (Object ; Arrow ; 𝟙 ; _∘_) @@ -179,15 +181,15 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where bind {X} {Y} f = μ Y ∘ func→ R f forthRaw : K.RawMonad - Kraw.RR forthRaw = RR - Kraw.pure forthRaw = pure + Kraw.RR forthRaw = RR + Kraw.pure forthRaw = pure Kraw.bind forthRaw = bind module _ {raw : M.RawMonad} (m : M.IsMonad raw) where private open M.IsMonad m open K.RawMonad (forthRaw raw) - module Kis = K.IsMonad + module R = Functor R isIdentity : IsIdentity isIdentity {X} = begin @@ -196,10 +198,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where μ X ∘ func→ R (η X) ≡⟨ proj₂ isInverse ⟩ 𝟙 ∎ - module R = Functor R isNatural : IsNatural isNatural {X} {Y} f = begin - bind f ∘ pure ≡⟨⟩ + bind f ∘ pure ≡⟨⟩ bind f ∘ η X ≡⟨⟩ μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηN f)) ⟩ @@ -211,11 +212,11 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open NaturalTransformation module ℂ = Category ℂ ηN : Natural ℂ ℂ F.identity R η - ηN = proj₂ ηNat + ηN = proj₂ ηNatTrans isDistributive : IsDistributive isDistributive {X} {Y} {Z} g f = begin - bind g ∘ bind f ≡⟨⟩ + bind g ∘ bind f ≡⟨⟩ μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ≡⟨ sym lem2 ⟩ μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨⟩ μ Z ∘ R.func→ (bind g ∘ f) ∎ @@ -243,16 +244,17 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d comm = {!!} - μN = proj₂ μNat + μN = proj₂ μNatTrans lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) lemmm = isAssociative lem4 : μ (R.func* Z) ∘ RR.func→ g ≡ R.func→ g ∘ μ Y lem4 = μN g + module KI = K.IsMonad forthIsMonad : K.IsMonad (forthRaw raw) - Kis.isIdentity forthIsMonad = isIdentity - Kis.isNatural forthIsMonad = isNatural - Kis.isDistributive forthIsMonad = isDistributive + KI.isIdentity forthIsMonad = isIdentity + KI.isNatural forthIsMonad = isNatural + KI.isDistributive forthIsMonad = isDistributive forth : M.Monad → K.Monad Kleisli.Monad.raw (forth m) = forthRaw (M.Monad.raw m) @@ -262,41 +264,42 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private module ℂ = Category ℂ open K.Monad m - module Mraw = M.RawMonad open NaturalTransformation ℂ ℂ rawR : RawFunctor ℂ ℂ - RawFunctor.func* rawR = RR + RawFunctor.func* rawR = RR RawFunctor.func→ rawR f = bind (pure ∘ f) isFunctorR : IsFunctor ℂ ℂ rawR - IsFunctor.isIdentity isFunctorR = begin + IsFunctor.isIdentity isFunctorR = begin bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ bind pure ≡⟨ isIdentity ⟩ - 𝟙 ∎ + 𝟙 ∎ + IsFunctor.isDistributive isFunctorR {f = f} {g} = begin - bind (pure ∘ (g ∘ f)) ≡⟨⟩ - fmap (g ∘ f) ≡⟨ fusion ⟩ - fmap g ∘ fmap f ≡⟨⟩ + bind (pure ∘ (g ∘ f)) ≡⟨⟩ + fmap (g ∘ f) ≡⟨ fusion ⟩ + fmap g ∘ fmap f ≡⟨⟩ bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ R : Functor ℂ ℂ Functor.raw R = rawR Functor.isFunctor R = isFunctorR - R2 : Functor ℂ ℂ - R2 = F[ R ∘ R ] + R² : Functor ℂ ℂ + R² = F[ R ∘ R ] - ηNat : NaturalTransformation F.identity R - ηNat = {!!} + ηNatTrans : NaturalTransformation F.identity R + ηNatTrans = {!!} - μNat : NaturalTransformation R2 R - μNat = {!!} + μNatTrans : NaturalTransformation R² R + μNatTrans = {!!} + module MR = M.RawMonad backRaw : M.RawMonad - Mraw.R backRaw = R - Mraw.ηNat backRaw = ηNat - Mraw.μNat backRaw = μNat + MR.R backRaw = R + MR.ηNatTrans backRaw = ηNatTrans + MR.μNatTrans backRaw = μNatTrans module _ (m : K.Monad) where open K.Monad m @@ -314,10 +317,10 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module _ (m : K.Monad) where open K.RawMonad (K.Monad.raw m) forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m - K.RawMonad.RR (forthRawEq _) = RR + K.RawMonad.RR (forthRawEq _) = RR K.RawMonad.pure (forthRawEq _) = pure -- stuck - K.RawMonad.bind (forthRawEq i) = {!!} + K.RawMonad.bind (forthRawEq i) = {!!} fortheq : (m : K.Monad) → forth (back m) ≡ m fortheq m = K.Monad≡ (forthRawEq m) @@ -326,9 +329,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open M.RawMonad (M.Monad.raw m) backRawEq : backRaw (forth m) ≡ M.Monad.raw m -- stuck - M.RawMonad.R (backRawEq i) = {!!} - M.RawMonad.ηNat (backRawEq i) = {!!} - M.RawMonad.μNat (backRawEq i) = {!!} + M.RawMonad.R (backRawEq i) = {!!} + M.RawMonad.ηNatTrans (backRawEq i) = {!!} + M.RawMonad.μNatTrans (backRawEq i) = {!!} backeq : (m : M.Monad) → back (forth m) ≡ m backeq m = M.Monad≡ (backRawEq m) From 101b2639e14ba9aa267bc96a4909569c8a9932fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 26 Feb 2018 20:31:47 +0100 Subject: [PATCH 07/91] Move proof to category definition --- src/Cat/Category/Monad.agda | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index bf3b4ec..40e936a 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -30,8 +30,13 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where η : Transformation F.identity R η = proj₁ ηNatTrans + ηNat : Natural F.identity R η + ηNat = proj₂ ηNatTrans + μ : Transformation F[ R ∘ R ] R μ = proj₁ μNatTrans + μNat : Natural F[ R ∘ R ] R μ + μNat = proj₂ μNatTrans private module R = Functor R @@ -42,6 +47,7 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where IsInverse = {X : Object} → μ X ∘ η (R.func* X) ≡ 𝟙 × μ X ∘ R.func→ (η X) ≡ 𝟙 + IsNatural' = ∀ {X Y f} → μ Y ∘ R.func→ f ∘ η X ≡ f record IsMonad (raw : RawMonad) : Set ℓ where open RawMonad raw public @@ -49,6 +55,19 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isAssociative : IsAssociative isInverse : IsInverse + private + module R = Functor R + module ℂ = Category ℂ + + isNatural' : IsNatural' + isNatural' {X} {Y} {f} = begin + μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ + μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηNat f)) ⟩ + μ Y ∘ (η (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ + μ Y ∘ η (R.func* Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ + 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ + f ∎ + record Monad : Set ℓ where field raw : RawMonad @@ -202,11 +221,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where isNatural {X} {Y} f = begin bind f ∘ pure ≡⟨⟩ bind f ∘ η X ≡⟨⟩ - μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ - μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηN f)) ⟩ - μ Y ∘ (η (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ - μ Y ∘ η (R.func* Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ - 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ + μ Y ∘ R.func→ f ∘ η X ≡⟨ isNatural' ⟩ f ∎ where open NaturalTransformation From 1aaf81552c498f01c3a8d9a5292a3f3a1b77c638 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 26 Feb 2018 20:36:39 +0100 Subject: [PATCH 08/91] Move another proof to category definition --- src/Cat/Category/Monad.agda | 63 ++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 32 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 40e936a..aed92c1 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -48,12 +48,15 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where → μ X ∘ η (R.func* X) ≡ 𝟙 × μ X ∘ R.func→ (η X) ≡ 𝟙 IsNatural' = ∀ {X Y f} → μ Y ∘ R.func→ f ∘ η X ≡ f + IsDistributive' = ∀ {X Y Z} {f : Arrow X (R.func* Y)} {g : Arrow Y (R.func* Z)} + → μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) + ≡ μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) record IsMonad (raw : RawMonad) : Set ℓ where open RawMonad raw public field isAssociative : IsAssociative - isInverse : IsInverse + isInverse : IsInverse private module R = Functor R @@ -68,6 +71,31 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ f ∎ + isDistributive' : IsDistributive' + isDistributive' {X} {Y} {Z} {f} {g} = begin + μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ + μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) ≡⟨⟩ + μ Z ∘ (R.func→ (μ Z) ∘ R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? + (μ Z ∘ R.func→ (μ Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) lemmm ⟩ + (μ Z ∘ μ (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? + μ Z ∘ μ (R.func* Z) ∘ R².func→ g ∘ R.func→ f ≡⟨ {!!} ⟩ -- ●-solver + lem4 + μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f ≡⟨ sym (Category.isAssociative ℂ) ⟩ + μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ∎ + where + module R² = Functor F[ R ∘ R ] + distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} + → R.func→ (a ∘ b ∘ c) + ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c + distrib = {!!} + comm : ∀ {A B C D E} + → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} + → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d + comm = {!!} + lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) + lemmm = isAssociative + lem4 : μ (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ μ Y + lem4 = μNat g + record Monad : Set ℓ where field raw : RawMonad @@ -212,7 +240,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where isIdentity : IsIdentity isIdentity {X} = begin - bind pure ≡⟨⟩ + bind pure ≡⟨⟩ bind (η X) ≡⟨⟩ μ X ∘ func→ R (η X) ≡⟨ proj₂ isInverse ⟩ 𝟙 ∎ @@ -232,38 +260,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where isDistributive : IsDistributive isDistributive {X} {Y} {Z} g f = begin bind g ∘ bind f ≡⟨⟩ - μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ≡⟨ sym lem2 ⟩ + μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ≡⟨ sym isDistributive' ⟩ μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨⟩ μ Z ∘ R.func→ (bind g ∘ f) ∎ - where - -- Proved it in reverse here... otherwise it could be neatly inlined. - lem2 - : μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) - ≡ μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) - lem2 = begin - μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ - μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) ≡⟨⟩ - μ Z ∘ (R.func→ (μ Z) ∘ RR.func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? - (μ Z ∘ R.func→ (μ Z)) ∘ (RR.func→ g ∘ R.func→ f) ≡⟨ cong (λ φ → φ ∘ (RR.func→ g ∘ R.func→ f)) lemmm ⟩ - (μ Z ∘ μ (R.func* Z)) ∘ (RR.func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? - μ Z ∘ μ (R.func* Z) ∘ RR.func→ g ∘ R.func→ f ≡⟨ {!!} ⟩ -- ●-solver + lem4 - μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f ≡⟨ sym (Category.isAssociative ℂ) ⟩ - μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ∎ - where - module RR = Functor F[ R ∘ R ] - distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} - → R.func→ (a ∘ b ∘ c) - ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c - distrib = {!!} - comm : ∀ {A B C D E} - → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} - → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d - comm = {!!} - μN = proj₂ μNatTrans - lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) - lemmm = isAssociative - lem4 : μ (R.func* Z) ∘ RR.func→ g ≡ R.func→ g ∘ μ Y - lem4 = μN g module KI = K.IsMonad forthIsMonad : K.IsMonad (forthRaw raw) From 70221377d3898778dfe6ad9f43852b5f75ea08b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 28 Feb 2018 18:55:32 +0100 Subject: [PATCH 09/91] Move proof of equivalence to `IsMonad` making them lemmas --- src/Cat/Category/Monad.agda | 97 +++++++++++++------------------------ 1 file changed, 34 insertions(+), 63 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index aed92c1..a1f9d3b 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -47,10 +47,10 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where IsInverse = {X : Object} → μ X ∘ η (R.func* X) ≡ 𝟙 × μ X ∘ R.func→ (η X) ≡ 𝟙 - IsNatural' = ∀ {X Y f} → μ Y ∘ R.func→ f ∘ η X ≡ f - IsDistributive' = ∀ {X Y Z} {f : Arrow X (R.func* Y)} {g : Arrow Y (R.func* Z)} - → μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) - ≡ μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) + IsNatural = ∀ {X Y} f → μ Y ∘ R.func→ f ∘ η X ≡ f + IsDistributive = ∀ {X Y Z} (g : Arrow Y (R.func* Z)) (f : Arrow X (R.func* Y)) + → μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) + ≡ μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) record IsMonad (raw : RawMonad) : Set ℓ where open RawMonad raw public @@ -62,8 +62,8 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where module R = Functor R module ℂ = Category ℂ - isNatural' : IsNatural' - isNatural' {X} {Y} {f} = begin + isNatural : IsNatural + isNatural {X} {Y} f = begin μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηNat f)) ⟩ μ Y ∘ (η (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ @@ -71,30 +71,31 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ f ∎ - isDistributive' : IsDistributive' - isDistributive' {X} {Y} {Z} {f} {g} = begin - μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ - μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) ≡⟨⟩ - μ Z ∘ (R.func→ (μ Z) ∘ R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? - (μ Z ∘ R.func→ (μ Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) lemmm ⟩ - (μ Z ∘ μ (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? - μ Z ∘ μ (R.func* Z) ∘ R².func→ g ∘ R.func→ f ≡⟨ {!!} ⟩ -- ●-solver + lem4 - μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f ≡⟨ sym (Category.isAssociative ℂ) ⟩ - μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ∎ + isDistributive : IsDistributive + isDistributive {X} {Y} {Z} g f = sym done where - module R² = Functor F[ R ∘ R ] - distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} - → R.func→ (a ∘ b ∘ c) - ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c - distrib = {!!} - comm : ∀ {A B C D E} - → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} - → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d - comm = {!!} - lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) - lemmm = isAssociative - lem4 : μ (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ μ Y - lem4 = μNat g + module R² = Functor F[ R ∘ R ] + distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} + → R.func→ (a ∘ b ∘ c) + ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c + distrib = {!!} + comm : ∀ {A B C D E} + → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} + → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d + comm = {!!} + lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) + lemmm = isAssociative + lem4 : μ (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ μ Y + lem4 = μNat g + done = begin + μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ + μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) ≡⟨⟩ + μ Z ∘ (R.func→ (μ Z) ∘ R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? + (μ Z ∘ R.func→ (μ Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) lemmm ⟩ + (μ Z ∘ μ (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? + μ Z ∘ μ (R.func* Z) ∘ R².func→ g ∘ R.func→ f ≡⟨ {!!} ⟩ -- ●-solver + lem4 + μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f ≡⟨ sym (Category.isAssociative ℂ) ⟩ + μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ∎ record Monad : Set ℓ where field @@ -233,42 +234,12 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Kraw.bind forthRaw = bind module _ {raw : M.RawMonad} (m : M.IsMonad raw) where - private - open M.IsMonad m - open K.RawMonad (forthRaw raw) - module R = Functor R - - isIdentity : IsIdentity - isIdentity {X} = begin - bind pure ≡⟨⟩ - bind (η X) ≡⟨⟩ - μ X ∘ func→ R (η X) ≡⟨ proj₂ isInverse ⟩ - 𝟙 ∎ - - isNatural : IsNatural - isNatural {X} {Y} f = begin - bind f ∘ pure ≡⟨⟩ - bind f ∘ η X ≡⟨⟩ - μ Y ∘ R.func→ f ∘ η X ≡⟨ isNatural' ⟩ - f ∎ - where - open NaturalTransformation - module ℂ = Category ℂ - ηN : Natural ℂ ℂ F.identity R η - ηN = proj₂ ηNatTrans - - isDistributive : IsDistributive - isDistributive {X} {Y} {Z} g f = begin - bind g ∘ bind f ≡⟨⟩ - μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ≡⟨ sym isDistributive' ⟩ - μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨⟩ - μ Z ∘ R.func→ (bind g ∘ f) ∎ - + module MI = M.IsMonad m module KI = K.IsMonad forthIsMonad : K.IsMonad (forthRaw raw) - KI.isIdentity forthIsMonad = isIdentity - KI.isNatural forthIsMonad = isNatural - KI.isDistributive forthIsMonad = isDistributive + KI.isIdentity forthIsMonad = proj₂ MI.isInverse + KI.isNatural forthIsMonad = MI.isNatural + KI.isDistributive forthIsMonad = MI.isDistributive forth : M.Monad → K.Monad Kleisli.Monad.raw (forth m) = forthRaw (M.Monad.raw m) From 3c77c69cf69e6a02db65995e3f861cbef057a80c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 28 Feb 2018 19:00:21 +0100 Subject: [PATCH 10/91] Move functor definition to Kleisli.Monad --- src/Cat/Category/Monad.agda | 46 ++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index a1f9d3b..703904d 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -117,7 +117,8 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private ℓ = ℓa ⊔ ℓb - open Category ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) + module ℂ = Category ℂ + open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) -- | Data for a monad. -- @@ -188,6 +189,29 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where lem : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) lem = isDistributive (pure ∘ g) (pure ∘ f) + -- | This formulation gives rise to the following endo-functor. + private + rawR : RawFunctor ℂ ℂ + RawFunctor.func* rawR = RR + RawFunctor.func→ rawR f = bind (pure ∘ f) + + isFunctorR : IsFunctor ℂ ℂ rawR + IsFunctor.isIdentity isFunctorR = begin + bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ + bind pure ≡⟨ isIdentity ⟩ + 𝟙 ∎ + + IsFunctor.isDistributive isFunctorR {f = f} {g} = begin + bind (pure ∘ (g ∘ f)) ≡⟨⟩ + fmap (g ∘ f) ≡⟨ fusion ⟩ + fmap g ∘ fmap f ≡⟨⟩ + bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ + + -- TODO: Naming! + R : Functor ℂ ℂ + Functor.raw R = rawR + Functor.isFunctor R = isFunctorR + record Monad : Set ℓ where field raw : RawMonad @@ -251,26 +275,6 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open K.Monad m open NaturalTransformation ℂ ℂ - rawR : RawFunctor ℂ ℂ - RawFunctor.func* rawR = RR - RawFunctor.func→ rawR f = bind (pure ∘ f) - - isFunctorR : IsFunctor ℂ ℂ rawR - IsFunctor.isIdentity isFunctorR = begin - bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ - bind pure ≡⟨ isIdentity ⟩ - 𝟙 ∎ - - IsFunctor.isDistributive isFunctorR {f = f} {g} = begin - bind (pure ∘ (g ∘ f)) ≡⟨⟩ - fmap (g ∘ f) ≡⟨ fusion ⟩ - fmap g ∘ fmap f ≡⟨⟩ - bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ - - R : Functor ℂ ℂ - Functor.raw R = rawR - Functor.isFunctor R = isFunctorR - R² : Functor ℂ ℂ R² = F[ R ∘ R ] From f2b1a36a7578d3847ab904e0b76656a1300fbc24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 28 Feb 2018 19:03:11 +0100 Subject: [PATCH 11/91] Define and use `Endofunctor` --- src/Cat/Category/Functor.agda | 3 +++ src/Cat/Category/Monad.agda | 6 +++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Cat/Category/Functor.agda b/src/Cat/Category/Functor.agda index d648728..898a331 100644 --- a/src/Cat/Category/Functor.agda +++ b/src/Cat/Category/Functor.agda @@ -45,6 +45,9 @@ module _ {ℓc ℓc' ℓd ℓd'} open Functor +EndoFunctor : ∀ {ℓa ℓb} (ℂ : Category ℓa ℓb) → Set _ +EndoFunctor ℂ = Functor ℂ ℂ + module _ {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 703904d..d10c5a0 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -22,7 +22,7 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where record RawMonad : Set ℓ where field -- R ~ m - R : Functor ℂ ℂ + R : EndoFunctor ℂ -- η ~ pure ηNatTrans : NaturalTransformation F.identity R -- μ ~ join @@ -208,7 +208,7 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ -- TODO: Naming! - R : Functor ℂ ℂ + R : EndoFunctor ℂ Functor.raw R = rawR Functor.isFunctor R = isFunctorR @@ -275,7 +275,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open K.Monad m open NaturalTransformation ℂ ℂ - R² : Functor ℂ ℂ + R² : EndoFunctor ℂ R² = F[ R ∘ R ] ηNatTrans : NaturalTransformation F.identity R From 9d3b17245fdd95aeef7f73b9db5ec26f5e3b597d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 28 Feb 2018 19:31:53 +0100 Subject: [PATCH 12/91] Provide \zeta --- src/Cat/Category/Monad.agda | 45 ++++++++++++++++++++++++++++--------- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index d10c5a0..a69e978 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -192,8 +192,8 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- | This formulation gives rise to the following endo-functor. private rawR : RawFunctor ℂ ℂ - RawFunctor.func* rawR = RR - RawFunctor.func→ rawR f = bind (pure ∘ f) + RawFunctor.func* rawR = RR + RawFunctor.func→ rawR = fmap isFunctorR : IsFunctor ℂ ℂ rawR IsFunctor.isIdentity isFunctorR = begin @@ -212,6 +212,38 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where Functor.raw R = rawR Functor.isFunctor R = isFunctorR + private + open NaturalTransformation ℂ ℂ + + R⁰ : EndoFunctor ℂ + R⁰ = F.identity + R² : EndoFunctor ℂ + R² = F[ R ∘ R ] + module R = Functor R + module R⁰ = Functor R⁰ + module R² = Functor R² + ηTrans : Transformation R⁰ R + ηTrans A = pure + ηNatural : Natural R⁰ R ηTrans + ηNatural {A} {B} f = begin + ηTrans B ∘ R⁰.func→ f ≡⟨⟩ + pure ∘ f ≡⟨ sym (isNatural _) ⟩ + bind (pure ∘ f) ∘ pure ≡⟨⟩ + fmap f ∘ pure ≡⟨⟩ + R.func→ f ∘ ηTrans A ∎ + μTrans : Transformation R² R + μTrans = {!!} + μNatural : Natural R² R μTrans + μNatural = {!!} + + ηNatTrans : NaturalTransformation R⁰ R + proj₁ ηNatTrans = ηTrans + proj₂ ηNatTrans = ηNatural + + μNatTrans : NaturalTransformation R² R + proj₁ μNatTrans = μTrans + proj₂ μNatTrans = μNatural + record Monad : Set ℓ where field raw : RawMonad @@ -275,15 +307,6 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open K.Monad m open NaturalTransformation ℂ ℂ - R² : EndoFunctor ℂ - R² = F[ R ∘ R ] - - ηNatTrans : NaturalTransformation F.identity R - ηNatTrans = {!!} - - μNatTrans : NaturalTransformation R² R - μNatTrans = {!!} - module MR = M.RawMonad backRaw : M.RawMonad MR.R backRaw = R From e8b29e1f7f7d312eafbd0d75cb4803fdbbc0a97d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 28 Feb 2018 23:41:59 +0100 Subject: [PATCH 13/91] \mu is join and it's a natural transformation! --- src/Cat/Category/Monad.agda | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index a69e978..01c30b8 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -232,9 +232,35 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where fmap f ∘ pure ≡⟨⟩ R.func→ f ∘ ηTrans A ∎ μTrans : Transformation R² R - μTrans = {!!} + μTrans C = join μNatural : Natural R² R μTrans - μNatural = {!!} + μNatural f = begin + join ∘ R².func→ f ≡⟨⟩ + bind 𝟙 ∘ R².func→ f ≡⟨⟩ + R².func→ f >>> bind 𝟙 ≡⟨⟩ + fmap (fmap f) >>> bind 𝟙 ≡⟨⟩ + fmap (bind (f >>> pure)) >>> bind 𝟙 ≡⟨⟩ + bind (bind (f >>> pure) >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((bind (f >>> pure) >>> pure) >=> 𝟙) + ≡⟨⟩ + bind ((bind (f >>> pure) >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (bind (f >>> pure) >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (bind (f >>> pure) >>> φ)) (isNatural _) ⟩ + bind (bind (f >>> pure) >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind (bind (f >>> pure)) + ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ + bind (𝟙 >>> bind (f >>> pure)) ≡⟨⟩ + bind (𝟙 >=> (f >>> pure)) + ≡⟨ sym (isDistributive _ _) ⟩ + bind 𝟙 >>> bind (f >>> pure) ≡⟨⟩ + bind 𝟙 >>> fmap f ≡⟨⟩ + bind 𝟙 >>> R.func→ f ≡⟨⟩ + R.func→ f ∘ bind 𝟙 ≡⟨⟩ + R.func→ f ∘ join ∎ + where ηNatTrans : NaturalTransformation R⁰ R proj₁ ηNatTrans = ηTrans From 64a0292755c4745e670e92b86060416252eade59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 14:19:46 +0100 Subject: [PATCH 14/91] Cosmetics --- src/Cat/Category/Monad.agda | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 01c30b8..77a8b0f 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -21,6 +21,7 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where open NaturalTransformation ℂ ℂ record RawMonad : Set ℓ where field + -- TODO rename fields here -- R ~ m R : EndoFunctor ℂ -- η ~ pure @@ -316,8 +317,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Kraw.bind forthRaw = bind module _ {raw : M.RawMonad} (m : M.IsMonad raw) where - module MI = M.IsMonad m - module KI = K.IsMonad + private + module MI = M.IsMonad m + module KI = K.IsMonad forthIsMonad : K.IsMonad (forthRaw raw) KI.isIdentity forthIsMonad = proj₂ MI.isInverse KI.isNatural forthIsMonad = MI.isNatural @@ -328,10 +330,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Kleisli.Monad.isMonad (forth m) = forthIsMonad (M.Monad.isMonad m) module _ (m : K.Monad) where - private - module ℂ = Category ℂ - open K.Monad m - open NaturalTransformation ℂ ℂ + open K.Monad m module MR = M.RawMonad backRaw : M.RawMonad @@ -339,13 +338,11 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where MR.ηNatTrans backRaw = ηNatTrans MR.μNatTrans backRaw = μNatTrans - module _ (m : K.Monad) where - open K.Monad m - open M.RawMonad (backRaw m) - module Mis = M.IsMonad - - backIsMonad : M.IsMonad (backRaw m) - backIsMonad = {!!} + module MI = M.IsMonad + -- also prove these in K.Monad! + backIsMonad : M.IsMonad backRaw + MI.isAssociative backIsMonad = {!isAssociative!} + MI.isInverse backIsMonad = {!!} back : K.Monad → M.Monad Monoidal.Monad.raw (back m) = backRaw m From ae46a48861087078898e672e80e8e0217e1ef846 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 14:58:01 +0100 Subject: [PATCH 15/91] Define goals in Kleisli --- src/Cat/Category/Monad.agda | 57 +++++++++++++++++++++++++++++++------ 1 file changed, 48 insertions(+), 9 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 77a8b0f..cd16bc9 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -117,9 +117,8 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private ℓ = ℓa ⊔ ℓb - - module ℂ = Category ℂ - open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) + module ℂ = Category ℂ + open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) -- | Data for a monad. -- @@ -166,6 +165,13 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where Fusion = {X Y Z : Object} {g : ℂ [ Y , Z ]} {f : ℂ [ X , Y ]} → fmap (g ∘ f) ≡ fmap g ∘ fmap f + -- In the ("foreign") formulation of a monad `IsNatural`'s analogue here would be: + IsNaturalForeign : Set _ + IsNaturalForeign = {X : Object} → join {X} ∘ fmap join ≡ join ∘ join + + IsInverse : Set _ + IsInverse = {X : Object} → join {X} ∘ pure ≡ 𝟙 × join {X} ∘ fmap pure ≡ 𝟙 + record IsMonad (raw : RawMonad) : Set ℓ where open RawMonad raw public field @@ -271,6 +277,21 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where proj₁ μNatTrans = μTrans proj₂ μNatTrans = μNatural + isNaturalForeign : IsNaturalForeign + isNaturalForeign = begin + join ∘ fmap join ≡⟨ {!!} ⟩ + join ∘ join ∎ + + isInverse : IsInverse + isInverse = inv-l , inv-r + where + inv-l = begin + join ∘ pure ≡⟨ {!!} ⟩ + 𝟙 ∎ + inv-r = begin + join ∘ fmap pure ≡⟨ {!!} ⟩ + 𝟙 ∎ + record Monad : Set ℓ where field raw : RawMonad @@ -330,19 +351,37 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Kleisli.Monad.isMonad (forth m) = forthIsMonad (M.Monad.isMonad m) module _ (m : K.Monad) where - open K.Monad m + private + open K.Monad m + module MR = M.RawMonad + module MI = M.IsMonad - module MR = M.RawMonad backRaw : M.RawMonad MR.R backRaw = R MR.ηNatTrans backRaw = ηNatTrans MR.μNatTrans backRaw = μNatTrans - module MI = M.IsMonad - -- also prove these in K.Monad! + private + open MR backRaw + module R = Functor (MR.R backRaw) + backIsMonad : M.IsMonad backRaw - MI.isAssociative backIsMonad = {!isAssociative!} - MI.isInverse backIsMonad = {!!} + MI.isAssociative backIsMonad {X} = begin + μ X ∘ R.func→ (μ X) ≡⟨⟩ + join ∘ fmap (μ X) ≡⟨⟩ + join ∘ fmap join ≡⟨ isNaturalForeign ⟩ + join ∘ join ≡⟨⟩ + μ X ∘ μ (R.func* X) ∎ + MI.isInverse backIsMonad {X} = inv-l , inv-r + where + inv-l = begin + μ X ∘ η (R.func* X) ≡⟨⟩ + join ∘ pure ≡⟨ proj₁ isInverse ⟩ + 𝟙 ∎ + inv-r = begin + μ X ∘ R.func→ (η X) ≡⟨⟩ + join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩ + 𝟙 ∎ back : K.Monad → M.Monad Monoidal.Monad.raw (back m) = backRaw m From ff2952e9ad461d6c92f41de38e92cd521f9fc831 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 14:58:49 +0100 Subject: [PATCH 16/91] Make postulate --- src/Cat/Category/Monad.agda | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index cd16bc9..7e9b661 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -76,14 +76,13 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isDistributive {X} {Y} {Z} g f = sym done where module R² = Functor F[ R ∘ R ] - distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} - → R.func→ (a ∘ b ∘ c) - ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c - distrib = {!!} - comm : ∀ {A B C D E} - → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} - → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d - comm = {!!} + postulate + distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} + → R.func→ (a ∘ b ∘ c) + ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c + comm : ∀ {A B C D E} + → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} + → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) lemmm = isAssociative lem4 : μ (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ μ Y @@ -110,8 +109,7 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where Monad.isMonad (Monad≡ {m} {n} eq i) = res i where -- TODO: PathJ nightmare + `propIsMonad`. - res : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - res = {!!} + postulate res : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] -- "A monad in the Kleisli form" [voe] module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where From f526fd60100dbfd6f2ba540684e8768d15a395a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 17:50:06 +0100 Subject: [PATCH 17/91] Prove inverse law --- src/Cat/Category/Monad.agda | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 7e9b661..5c815c9 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -284,10 +284,21 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isInverse = inv-l , inv-r where inv-l = begin - join ∘ pure ≡⟨ {!!} ⟩ + pure >>> join ≡⟨⟩ + pure >>> bind 𝟙 ≡⟨ isNatural _ ⟩ 𝟙 ∎ inv-r = begin - join ∘ fmap pure ≡⟨ {!!} ⟩ + fmap pure >>> join ≡⟨⟩ + bind (pure >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((pure >>> pure) >=> 𝟙) ≡⟨⟩ + bind ((pure >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (pure >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (pure >>> φ)) (isNatural _) ⟩ + bind (pure >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind pure ≡⟨ isIdentity ⟩ 𝟙 ∎ record Monad : Set ℓ where From a7f31bb3e29f539f34fb14cf656e6795baa5247e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 18:00:51 +0100 Subject: [PATCH 18/91] Prove "foreign naturality condition" --- src/Cat/Category/Monad.agda | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 5c815c9..26347a2 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -277,8 +277,22 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isNaturalForeign : IsNaturalForeign isNaturalForeign = begin - join ∘ fmap join ≡⟨ {!!} ⟩ - join ∘ join ∎ + fmap join >>> join ≡⟨⟩ + bind (join >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((join >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (join >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (join >>> φ)) (isNatural _) ⟩ + bind (join >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind join ≡⟨⟩ + bind (bind 𝟙) + ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ + bind (𝟙 >>> bind 𝟙) ≡⟨⟩ + bind (𝟙 >=> 𝟙) ≡⟨ sym (isDistributive _ _) ⟩ + bind 𝟙 >>> bind 𝟙 ≡⟨⟩ + join >>> join ∎ isInverse : IsInverse isInverse = inv-l , inv-r From f2164a6717be967a4a725a71c34a98981a4d58ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 20:12:49 +0100 Subject: [PATCH 19/91] Prove equality principle for monads --- src/Cat/Category/Monad.agda | 39 +++++++++++++++++++++++++++++-------- 1 file changed, 31 insertions(+), 8 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 26347a2..e582d63 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -7,7 +7,7 @@ open import Data.Product open import Cubical -open import Cat.Category +open import Cat.Category hiding (propIsAssociative) open import Cat.Category.Functor as F open import Cat.Category.NaturalTransformation open import Cat.Categories.Fun @@ -103,13 +103,36 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isMonad : IsMonad raw open IsMonad isMonad public - postulate propIsMonad : ∀ {raw} → isProp (IsMonad raw) - Monad≡ : {m n : Monad} → Monad.raw m ≡ Monad.raw n → m ≡ n - Monad.raw (Monad≡ eq i) = eq i - Monad.isMonad (Monad≡ {m} {n} eq i) = res i - where - -- TODO: PathJ nightmare + `propIsMonad`. - postulate res : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + private + module _ {m : RawMonad} where + open RawMonad m + propIsAssociative : isProp IsAssociative + propIsAssociative x y i {X} + = Category.arrowsAreSets ℂ _ _ (x {X}) (y {X}) i + propIsInverse : isProp IsInverse + propIsInverse x y i {X} = e1 i , e2 i + where + xX = x {X} + yX = y {X} + e1 = Category.arrowsAreSets ℂ _ _ (proj₁ xX) (proj₁ yX) + e2 = Category.arrowsAreSets ℂ _ _ (proj₂ xX) (proj₂ yX) + open IsMonad + propIsMonad : (raw : _) → isProp (IsMonad raw) + IsMonad.isAssociative (propIsMonad raw a b i) j + = propIsAssociative {raw} + (isAssociative a) (isAssociative b) i j + IsMonad.isInverse (propIsMonad raw a b i) + = propIsInverse {raw} + (isInverse a) (isInverse b) i + + module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where + open import Cubical.NType.Properties + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq + + Monad≡ : m ≡ n + Monad.raw (Monad≡ i) = eq i + Monad.isMonad (Monad≡ i) = eqIsMonad i -- "A monad in the Kleisli form" [voe] module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where From 2ceb027f7a20617f9b445970808f213da6fa826e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 20:23:34 +0100 Subject: [PATCH 20/91] Prove monad-equality principle for kleisly monads --- src/Cat/Category/Monad.agda | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index e582d63..6872902 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -6,8 +6,9 @@ open import Agda.Primitive open import Data.Product open import Cubical +open import Cubical.NType.Properties using (lemPropF) -open import Cat.Category hiding (propIsAssociative) +open import Cat.Category hiding (propIsAssociative ; propIsIdentity) open import Cat.Category.Functor as F open import Cat.Category.NaturalTransformation open import Cat.Categories.Fun @@ -126,7 +127,6 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where (isInverse a) (isInverse b) i module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where - open import Cubical.NType.Properties eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] eqIsMonad = lemPropF propIsMonad eq @@ -344,14 +344,27 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isMonad : IsMonad raw open IsMonad isMonad public - postulate propIsMonad : ∀ {raw} → isProp (IsMonad raw) - Monad≡ : {m n : Monad} → Monad.raw m ≡ Monad.raw n → m ≡ n - Monad.raw (Monad≡ eq i) = eq i - Monad.isMonad (Monad≡ {m} {n} eq i) = res i - where - -- TODO: PathJ nightmare + `propIsMonad`. - res : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - res = {!!} + module _ (raw : RawMonad) where + open RawMonad raw + postulate + propIsIdentity : isProp IsIdentity + propIsNatural : isProp IsNatural + propIsDistributive : isProp IsDistributive + open IsMonad + propIsMonad : (raw : _) → isProp (IsMonad raw) + IsMonad.isIdentity (propIsMonad raw x y i) + = propIsIdentity raw (isIdentity x) (isIdentity y) i + IsMonad.isNatural (propIsMonad raw x y i) + = propIsNatural raw (isNatural x) (isNatural y) i + IsMonad.isDistributive (propIsMonad raw x y i) + = propIsDistributive raw (isDistributive x) (isDistributive y) i + module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq + + Monad≡ : m ≡ n + Monad.raw (Monad≡ i) = eq i + Monad.isMonad (Monad≡ i) = eqIsMonad i -- | The monoidal- and kleisli presentation of monads are equivalent. -- From c4e3625746ca351a0a66c84a36f30a82dd3709d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 1 Mar 2018 20:47:36 +0100 Subject: [PATCH 21/91] Finish proof of distributivity --- src/Cat/Category/Monad.agda | 59 +++++++++++++++++++++++++++---------- 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 6872902..0079f6e 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -77,26 +77,55 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isDistributive {X} {Y} {Z} g f = sym done where module R² = Functor F[ R ∘ R ] - postulate - distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} - → R.func→ (a ∘ b ∘ c) - ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c - comm : ∀ {A B C D E} - → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} - → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d + distrib : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} + → R.func→ (a ∘ b ∘ c) + ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c + distrib {a = a} {b} {c} = begin + R.func→ (a ∘ b ∘ c) ≡⟨ distr ⟩ + R.func→ (a ∘ b) ∘ R.func→ c ≡⟨ cong (_∘ _) distr ⟩ + R.func→ a ∘ R.func→ b ∘ R.func→ c ∎ + where + distr = R.isDistributive + comm : ∀ {A B C D E} + → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} + → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d + comm {a = a} {b} {c} {d} = begin + a ∘ (b ∘ c ∘ d) ≡⟨⟩ + a ∘ ((b ∘ c) ∘ d) ≡⟨ cong (_∘_ a) (sym asc) ⟩ + a ∘ (b ∘ (c ∘ d)) ≡⟨ asc ⟩ + (a ∘ b) ∘ (c ∘ d) ≡⟨ asc ⟩ + ((a ∘ b) ∘ c) ∘ d ≡⟨⟩ + a ∘ b ∘ c ∘ d ∎ + where + asc = ℂ.isAssociative lemmm : μ Z ∘ R.func→ (μ Z) ≡ μ Z ∘ μ (R.func* Z) lemmm = isAssociative lem4 : μ (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ μ Y lem4 = μNat g done = begin - μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) ≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ - μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) ≡⟨⟩ - μ Z ∘ (R.func→ (μ Z) ∘ R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? - (μ Z ∘ R.func→ (μ Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) lemmm ⟩ - (μ Z ∘ μ (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ {!!} ⟩ -- ●-solver? - μ Z ∘ μ (R.func* Z) ∘ R².func→ g ∘ R.func→ f ≡⟨ {!!} ⟩ -- ●-solver + lem4 - μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f ≡⟨ sym (Category.isAssociative ℂ) ⟩ - μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) ∎ + μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) + ≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ + μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) + ≡⟨⟩ + μ Z ∘ (R.func→ (μ Z) ∘ R².func→ g ∘ R.func→ f) + ≡⟨ cong (_∘_ (μ Z)) (sym ℂ.isAssociative) ⟩ -- ●-solver? + μ Z ∘ (R.func→ (μ Z) ∘ (R².func→ g ∘ R.func→ f)) + ≡⟨ ℂ.isAssociative ⟩ + (μ Z ∘ R.func→ (μ Z)) ∘ (R².func→ g ∘ R.func→ f) + ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) isAssociative ⟩ + (μ Z ∘ μ (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) + ≡⟨ ℂ.isAssociative ⟩ -- ●-solver? + μ Z ∘ μ (R.func* Z) ∘ R².func→ g ∘ R.func→ f + ≡⟨⟩ -- ●-solver + lem4 + ((μ Z ∘ μ (R.func* Z)) ∘ R².func→ g) ∘ R.func→ f + ≡⟨ cong (_∘ R.func→ f) (sym ℂ.isAssociative) ⟩ + (μ Z ∘ (μ (R.func* Z) ∘ R².func→ g)) ∘ R.func→ f + ≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (μ Z)) lem4) ⟩ + (μ Z ∘ (R.func→ g ∘ μ Y)) ∘ R.func→ f ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩ + μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f + ≡⟨ sym (Category.isAssociative ℂ) ⟩ + μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) + ∎ record Monad : Set ℓ where field From b079f5e4261a232e06c72933731902f65e14b659 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Fri, 2 Mar 2018 13:31:46 +0100 Subject: [PATCH 22/91] Prove propositionality for IsMonad --- src/Cat/Category.agda | 2 +- src/Cat/Category/Monad.agda | 15 ++++++++++----- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index 3a275c8..d66811d 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -194,7 +194,7 @@ record IsCategory {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) : Set (lsuc -- -- Proves that all projections of `IsCategory` are mere propositions as well as -- `IsCategory` itself being a mere proposition. -module _ {ℓa ℓb : Level} {C : RawCategory ℓa ℓb} where +module Propositionality {ℓa ℓb : Level} {C : RawCategory ℓa ℓb} where open RawCategory C module _ (ℂ : IsCategory C) where open IsCategory ℂ using (isAssociative ; arrowsAreSets ; isIdentity ; Univalent) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 0079f6e..e7305d3 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -8,7 +8,7 @@ open import Data.Product open import Cubical open import Cubical.NType.Properties using (lemPropF) -open import Cat.Category hiding (propIsAssociative ; propIsIdentity) +open import Cat.Category open import Cat.Category.Functor as F open import Cat.Category.NaturalTransformation open import Cat.Categories.Fun @@ -375,10 +375,15 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where module _ (raw : RawMonad) where open RawMonad raw - postulate - propIsIdentity : isProp IsIdentity - propIsNatural : isProp IsNatural - propIsDistributive : isProp IsDistributive + propIsIdentity : isProp IsIdentity + propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i + propIsNatural : isProp IsNatural + propIsNatural x y i = λ f + → ℂ.arrowsAreSets _ _ (x f) (y f) i + propIsDistributive : isProp IsDistributive + propIsDistributive x y i = λ g f + → ℂ.arrowsAreSets _ _ (x g f) (y g f) i + open IsMonad propIsMonad : (raw : _) → isProp (IsMonad raw) IsMonad.isIdentity (propIsMonad raw x y i) From 8f8800cb67d8cfabac2464989585cf28453922f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 10:28:16 +0100 Subject: [PATCH 23/91] More stuff about kleisli \equiv monoidal --- src/Cat.agda | 30 +++---- src/Cat/Categories/Cube.agda | 50 ++++++------ src/Cat/Categories/Free.agda | 6 +- src/Cat/Category/Functor.agda | 38 +++++++++ src/Cat/Category/Monad.agda | 88 +++++++++++++++++---- src/Cat/Category/NaturalTransformation.agda | 13 ++- src/Cat/Category/Yoneda.agda | 14 ++-- 7 files changed, 166 insertions(+), 73 deletions(-) diff --git a/src/Cat.agda b/src/Cat.agda index 20c5d69..478b725 100644 --- a/src/Cat.agda +++ b/src/Cat.agda @@ -1,19 +1,19 @@ module Cat where -import Cat.Category +open import Cat.Category -import Cat.Category.Functor -import Cat.Category.Product -import Cat.Category.Exponential -import Cat.Category.CartesianClosed -import Cat.Category.NaturalTransformation -import Cat.Category.Yoneda -import Cat.Category.Monad +open import Cat.Category.Functor +open import Cat.Category.Product +open import Cat.Category.Exponential +open import Cat.Category.CartesianClosed +open import Cat.Category.NaturalTransformation +open import Cat.Category.Yoneda +open import Cat.Category.Monad -import Cat.Categories.Sets -import Cat.Categories.Cat -import Cat.Categories.Rel -import Cat.Categories.Free -import Cat.Categories.Fun -import Cat.Categories.Cube -import Cat.Categories.CwF +open import Cat.Categories.Sets +open import Cat.Categories.Cat +open import Cat.Categories.Rel +open import Cat.Categories.Free +open import Cat.Categories.Fun +open import Cat.Categories.Cube +open import Cat.Categories.CwF diff --git a/src/Cat/Categories/Cube.agda b/src/Cat/Categories/Cube.agda index fdee75e..00f10e3 100644 --- a/src/Cat/Categories/Cube.agda +++ b/src/Cat/Categories/Cube.agda @@ -26,24 +26,24 @@ open Category hiding (_∘_) open Functor module _ {ℓ ℓ' : Level} (Ns : Set ℓ) where - -- Ns is the "namespace" - ℓo = (suc zero ⊔ ℓ) + private + -- Ns is the "namespace" + ℓo = (suc zero ⊔ ℓ) - FiniteDecidableSubset : Set ℓ - FiniteDecidableSubset = Ns → Dec ⊤ + FiniteDecidableSubset : Set ℓ + FiniteDecidableSubset = Ns → Dec ⊤ - isTrue : Bool → Set - isTrue false = ⊥ - isTrue true = ⊤ + isTrue : Bool → Set + isTrue false = ⊥ + isTrue true = ⊤ - elmsof : FiniteDecidableSubset → Set ℓ - elmsof P = Σ Ns (λ σ → True (P σ)) -- (σ : Ns) → isTrue (P σ) + elmsof : FiniteDecidableSubset → Set ℓ + elmsof P = Σ Ns (λ σ → True (P σ)) -- (σ : Ns) → isTrue (P σ) - 𝟚 : Set - 𝟚 = Bool + 𝟚 : Set + 𝟚 = Bool - module _ (I J : FiniteDecidableSubset) where - private + module _ (I J : FiniteDecidableSubset) where Hom' : Set ℓ Hom' = elmsof I → elmsof J ⊎ 𝟚 isInl : {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} → A ⊎ B → Set @@ -63,18 +63,18 @@ module _ {ℓ ℓ' : Level} (Ns : Set ℓ) where ; (inj₂ _) → Lift ⊤ } - Hom = Σ Hom' rules + Hom = Σ Hom' rules - module Raw = RawCategory - -- The category of names and substitutions - Rawℂ : RawCategory ℓ ℓ -- ℓo (lsuc lzero ⊔ ℓo) - Raw.Object Rawℂ = FiniteDecidableSubset - Raw.Arrow Rawℂ = Hom - Raw.𝟙 Rawℂ {o} = inj₁ , λ { (i , ii) (j , jj) eq → Σ≡ eq {!refl!} } - Raw._∘_ Rawℂ = {!!} + module Raw = RawCategory + -- The category of names and substitutions + Rawℂ : RawCategory ℓ ℓ -- ℓo (lsuc lzero ⊔ ℓo) + Raw.Object Rawℂ = FiniteDecidableSubset + Raw.Arrow Rawℂ = Hom + Raw.𝟙 Rawℂ {o} = inj₁ , λ { (i , ii) (j , jj) eq → Σ≡ eq {!refl!} } + Raw._∘_ Rawℂ = {!!} - postulate IsCategoryℂ : IsCategory Rawℂ + postulate IsCategoryℂ : IsCategory Rawℂ - ℂ : Category ℓ ℓ - raw ℂ = Rawℂ - isCategory ℂ = IsCategoryℂ + ℂ : Category ℓ ℓ + raw ℂ = Rawℂ + isCategory ℂ = IsCategoryℂ diff --git a/src/Cat/Categories/Free.agda b/src/Cat/Categories/Free.agda index 9a0c891..7e80478 100644 --- a/src/Cat/Categories/Free.agda +++ b/src/Cat/Categories/Free.agda @@ -20,10 +20,10 @@ singleton : ∀ {ℓ} {𝓤 : Set ℓ} {ℓr} {R : 𝓤 → 𝓤 → Set ℓr} { singleton f = cons f empty module _ {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') where - module ℂ = Category ℂ - open Category ℂ - private + module ℂ = Category ℂ + open Category ℂ + p-isAssociative : {A B C D : Object} {r : Path Arrow A B} {q : Path Arrow B C} {p : Path Arrow C D} → p ++ (q ++ r) ≡ (p ++ q) ++ r p-isAssociative {r = r} {q} {empty} = refl diff --git a/src/Cat/Category/Functor.agda b/src/Cat/Category/Functor.agda index 898a331..08400ea 100644 --- a/src/Cat/Category/Functor.agda +++ b/src/Cat/Category/Functor.agda @@ -18,6 +18,10 @@ module _ {ℓc ℓc' ℓd ℓd'} ℓ = ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd' 𝓤 = Set ℓ + Omap = Object ℂ → Object 𝔻 + Fmap : Omap → Set _ + Fmap omap = ∀ {A B} + → ℂ [ A , B ] → 𝔻 [ omap A , omap B ] record RawFunctor : 𝓤 where field func* : Object ℂ → Object 𝔻 @@ -30,6 +34,30 @@ module _ {ℓc ℓc' ℓd ℓd'} IsDistributive = {A B C : Object ℂ} {f : ℂ [ A , B ]} {g : ℂ [ B , C ]} → func→ (ℂ [ g ∘ f ]) ≡ 𝔻 [ func→ g ∘ func→ f ] + -- | Equality principle for raw functors + -- + -- The type of `func→` depend on the value of `func*`. We can wrap this up + -- into an equality principle for this type like is done for e.g. `Σ` using + -- `pathJ`. + module _ {x y : RawFunctor} where + open RawFunctor + private + P : (omap : Omap) → (eq : func* x ≡ omap) → Set _ + P y eq = (fmap' : Fmap y) → (λ i → Fmap (eq i)) + [ func→ x ≡ fmap' ] + module _ + (eq : (λ i → Omap) [ func* x ≡ func* y ]) + (kk : P (func* x) refl) + where + private + p : P (func* y) eq + p = pathJ P kk (func* y) eq + eq→ : (λ i → Fmap (eq i)) [ func→ x ≡ func→ y ] + eq→ = p (func→ y) + RawFunctor≡ : x ≡ y + func* (RawFunctor≡ i) = eq i + func→ (RawFunctor≡ i) = eq→ i + record IsFunctor (F : RawFunctor) : 𝓤 where open RawFunctor F public field @@ -98,6 +126,16 @@ module _ {ℓ ℓ' : Level} {ℂ 𝔻 : Category ℓ ℓ'} where eqIsF : (λ i → IsFunctor ℂ 𝔻 (eqR i)) [ isFunctor F ≡ isFunctor G ] eqIsF = IsFunctorIsProp' (isFunctor F) (isFunctor G) + FunctorEq : {F G : Functor ℂ 𝔻} + → raw F ≡ raw G + → F ≡ G + raw (FunctorEq eq i) = eq i + isFunctor (FunctorEq {F} {G} eq i) + = res i + where + res : (λ i → IsFunctor ℂ 𝔻 (eq i)) [ isFunctor F ≡ isFunctor G ] + res = IsFunctorIsProp' (isFunctor F) (isFunctor G) + module _ {ℓ ℓ' : Level} {A B C : Category ℓ ℓ'} (F : Functor B C) (G : Functor A B) where private F* = func* F diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index e7305d3..8ba97df 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -279,18 +279,18 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where module R = Functor R module R⁰ = Functor R⁰ module R² = Functor R² - ηTrans : Transformation R⁰ R - ηTrans A = pure - ηNatural : Natural R⁰ R ηTrans + η : Transformation R⁰ R + η A = pure + ηNatural : Natural R⁰ R η ηNatural {A} {B} f = begin - ηTrans B ∘ R⁰.func→ f ≡⟨⟩ + η B ∘ R⁰.func→ f ≡⟨⟩ pure ∘ f ≡⟨ sym (isNatural _) ⟩ bind (pure ∘ f) ∘ pure ≡⟨⟩ fmap f ∘ pure ≡⟨⟩ - R.func→ f ∘ ηTrans A ∎ - μTrans : Transformation R² R - μTrans C = join - μNatural : Natural R² R μTrans + R.func→ f ∘ η A ∎ + μ : Transformation R² R + μ C = join + μNatural : Natural R² R μ μNatural f = begin join ∘ R².func→ f ≡⟨⟩ bind 𝟙 ∘ R².func→ f ≡⟨⟩ @@ -320,11 +320,11 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where where ηNatTrans : NaturalTransformation R⁰ R - proj₁ ηNatTrans = ηTrans + proj₁ ηNatTrans = η proj₂ ηNatTrans = ηNatural μNatTrans : NaturalTransformation R² R - proj₁ μNatTrans = μTrans + proj₁ μNatTrans = μ proj₂ μNatTrans = μNatural isNaturalForeign : IsNaturalForeign @@ -405,7 +405,8 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- This is problem 2.3 in [voe]. module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private - open Category ℂ using (Object ; Arrow ; 𝟙 ; _∘_) + module ℂ = Category ℂ + open ℂ using (Object ; Arrow ; 𝟙 ; _∘_ ; _>>>_) open Functor using (func* ; func→) module M = Monoidal ℂ module K = Kleisli ℂ @@ -482,22 +483,79 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where -- I believe all the proofs here should be `refl`. module _ (m : K.Monad) where - open K.RawMonad (K.Monad.raw m) + open K.Monad m + -- open K.RawMonad (K.Monad.raw m) + bindEq : ∀ {X Y} + → K.RawMonad.bind (forthRaw (backRaw m)) {X} {Y} + ≡ K.RawMonad.bind (K.Monad.raw m) + bindEq {X} {Y} = begin + K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩ + (λ f → μ Y ∘ func→ R f) ≡⟨⟩ + (λ f → join ∘ fmap f) ≡⟨⟩ + (λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩ + (λ f → bind f) ≡⟨⟩ + bind ∎ + where + μ = proj₁ μNatTrans + lem : (f : Arrow X (RR Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f + lem f = begin + bind (f >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((f >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (f >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (f >>> φ)) (isNatural _) ⟩ + bind (f >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind f ∎ + + _&_ : ∀ {ℓa ℓb} {A : Set ℓa} {B : Set ℓb} → A → (A → B) → B + x & f = f x + forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m K.RawMonad.RR (forthRawEq _) = RR K.RawMonad.pure (forthRawEq _) = pure -- stuck - K.RawMonad.bind (forthRawEq i) = {!!} + K.RawMonad.bind (forthRawEq i) = bindEq i fortheq : (m : K.Monad) → forth (back m) ≡ m fortheq m = K.Monad≡ (forthRawEq m) module _ (m : M.Monad) where open M.RawMonad (M.Monad.raw m) + rawEq* : Functor.func* (K.Monad.R (forth m)) ≡ Functor.func* R + rawEq* = refl + left = Functor.raw (K.Monad.R (forth m)) + right = Functor.raw R + P : (omap : Omap ℂ ℂ) + → (eq : RawFunctor.func* left ≡ omap) + → (fmap' : Fmap ℂ ℂ omap) + → Set _ + P _ eq fmap' = (λ i → Fmap ℂ ℂ (eq i)) + [ RawFunctor.func→ left ≡ fmap' ] + -- rawEq→ : (λ i → Fmap ℂ ℂ (refl i)) [ Functor.func→ (K.Monad.R (forth m)) ≡ Functor.func→ R ] + rawEq→ : P (RawFunctor.func* right) refl (RawFunctor.func→ right) + -- rawEq→ : (fmap' : Fmap ℂ ℂ {!!}) → RawFunctor.func→ left ≡ fmap' + rawEq→ = begin + (λ {A} {B} → RawFunctor.func→ left) ≡⟨ {!!} ⟩ + (λ {A} {B} → RawFunctor.func→ right) ∎ + -- destfmap = + source = (Functor.raw (K.Monad.R (forth m))) + -- p : (fmap' : Fmap ℂ ℂ (RawFunctor.func* source)) → (λ i → Fmap ℂ ℂ (refl i)) [ func→ source ≡ fmap' ] + -- p = {!!} + rawEq : Functor.raw (K.Monad.R (forth m)) ≡ Functor.raw R + rawEq = RawFunctor≡ ℂ ℂ {x = left} {right} refl λ fmap' → {!rawEq→!} + Req : M.RawMonad.R (backRaw (forth m)) ≡ R + Req = FunctorEq rawEq + + ηeq : M.RawMonad.η (backRaw (forth m)) ≡ η + ηeq = {!!} + postulate ηNatTransEq : {!!} [ M.RawMonad.ηNatTrans (backRaw (forth m)) ≡ ηNatTrans ] + open NaturalTransformation ℂ ℂ backRawEq : backRaw (forth m) ≡ M.Monad.raw m -- stuck - M.RawMonad.R (backRawEq i) = {!!} - M.RawMonad.ηNatTrans (backRawEq i) = {!!} + M.RawMonad.R (backRawEq i) = Req i + M.RawMonad.ηNatTrans (backRawEq i) = let t = NaturalTransformation≡ F.identity R ηeq in {!t i!} M.RawMonad.μNatTrans (backRawEq i) = {!!} backeq : (m : M.Monad) → back (forth m) ≡ m diff --git a/src/Cat/Category/NaturalTransformation.agda b/src/Cat/Category/NaturalTransformation.agda index 8de0f34..f9ac434 100644 --- a/src/Cat/Category/NaturalTransformation.agda +++ b/src/Cat/Category/NaturalTransformation.agda @@ -23,6 +23,7 @@ open import Agda.Primitive open import Data.Product open import Cubical +open import Cubical.NType.Properties open import Cat.Category open import Cat.Category.Functor hiding (identity) @@ -48,17 +49,13 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} NaturalTransformation : Set (ℓc ⊔ ℓc' ⊔ ℓd') NaturalTransformation = Σ Transformation Natural - -- TODO: Since naturality is a mere proposition this principle can be - -- simplified. + -- Think I need propPi and that arrows are sets + postulate propIsNatural : (θ : _) → isProp (Natural θ) + NaturalTransformation≡ : {α β : NaturalTransformation} → (eq₁ : α .proj₁ ≡ β .proj₁) - → (eq₂ : PathP - (λ i → {A B : Object ℂ} (f : ℂ [ A , B ]) - → 𝔻 [ eq₁ i B ∘ F.func→ f ] - ≡ 𝔻 [ G.func→ f ∘ eq₁ i A ]) - (α .proj₂) (β .proj₂)) → α ≡ β - NaturalTransformation≡ eq₁ eq₂ i = eq₁ i , eq₂ i + NaturalTransformation≡ eq = lemSig propIsNatural _ _ eq identityTrans : (F : Functor ℂ 𝔻) → Transformation F F identityTrans F C = 𝟙 𝔻 diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index baf298b..abd76d0 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -16,14 +16,14 @@ open Equality.Data.Product open import Cat.Categories.Cat using (RawCat) module _ {ℓ : Level} {ℂ : Category ℓ ℓ} (unprovable : IsCategory (RawCat ℓ ℓ)) where - open import Cat.Categories.Fun - open import Cat.Categories.Sets - module Cat = Cat.Categories.Cat - open import Cat.Category.Exponential - open Functor - 𝓢 = Sets ℓ - open Fun (opposite ℂ) 𝓢 private + open import Cat.Categories.Fun + open import Cat.Categories.Sets + module Cat = Cat.Categories.Cat + open import Cat.Category.Exponential + open Functor + 𝓢 = Sets ℓ + open Fun (opposite ℂ) 𝓢 Catℓ : Category _ _ Catℓ = record { raw = RawCat ℓ ℓ ; isCategory = unprovable} prshf = presheaf {ℂ = ℂ} From 77006011d393f5cfeca476c0729f56fba32cb911 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 10:35:33 +0100 Subject: [PATCH 24/91] Minimize dependency on category of categories --- src/Cat/Categories/Cat.agda | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 5a0d2dd..40fb754 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -65,7 +65,6 @@ module _ (ℓ ℓ' : Level) where module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where module _ (ℂ 𝔻 : Category ℓ ℓ') where private - Catt = Cat ℓ ℓ' unprovable :Object: = Object ℂ × Object 𝔻 :Arrow: : :Object: → :Object: → Set ℓ' :Arrow: (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ] @@ -105,19 +104,19 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where :product: : Category ℓ ℓ' Category.raw :product: = :rawProduct: - proj₁ : Catt [ :product: , ℂ ] + proj₁ : Functor :product: ℂ proj₁ = record { raw = record { func* = fst ; func→ = fst } ; isFunctor = record { isIdentity = refl ; isDistributive = refl } } - proj₂ : Catt [ :product: , 𝔻 ] + proj₂ : Functor :product: 𝔻 proj₂ = record { raw = record { func* = snd ; func→ = snd } ; isFunctor = record { isIdentity = refl ; isDistributive = refl } } - module _ {X : Object Catt} (x₁ : Catt [ X , ℂ ]) (x₂ : Catt [ X , 𝔻 ]) where + module _ {X : Category ℓ ℓ'} (x₁ : Functor X ℂ) (x₂ : Functor X 𝔻) where x : Functor X :product: x = record { raw = record @@ -133,29 +132,31 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where open module x₁ = Functor x₁ open module x₂ = Functor x₂ - isUniqL : Catt [ proj₁ ∘ x ] ≡ x₁ + isUniqL : F[ proj₁ ∘ x ] ≡ x₁ isUniqL = Functor≡ eq* eq→ where - eq* : (Catt [ proj₁ ∘ x ]) .func* ≡ x₁ .func* + eq* : (F[ proj₁ ∘ x ]) .func* ≡ x₁ .func* eq* = refl eq→ : (λ i → {A : Object X} {B : Object X} → X [ A , B ] → ℂ [ eq* i A , eq* i B ]) - [ (Catt [ proj₁ ∘ x ]) .func→ ≡ x₁ .func→ ] + [ (F[ proj₁ ∘ x ]) .func→ ≡ x₁ .func→ ] eq→ = refl - isUniqR : Catt [ proj₂ ∘ x ] ≡ x₂ + isUniqR : F[ proj₂ ∘ x ] ≡ x₂ isUniqR = Functor≡ refl refl - isUniq : Catt [ proj₁ ∘ x ] ≡ x₁ × Catt [ proj₂ ∘ x ] ≡ x₂ + isUniq : F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂ isUniq = isUniqL , isUniqR - uniq : ∃![ x ] (Catt [ proj₁ ∘ x ] ≡ x₁ × Catt [ proj₂ ∘ x ] ≡ x₂) + uniq : ∃![ x ] (F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂) uniq = x , isUniq + Catℓ = Cat ℓ ℓ' unprovable + instance - isProduct : IsProduct Catt proj₁ proj₂ + isProduct : IsProduct Catℓ proj₁ proj₂ isProduct = uniq - product : Product {ℂ = Catt} ℂ 𝔻 + product : Product {ℂ = Catℓ} ℂ 𝔻 product = record { obj = :product: ; proj₁ = proj₁ From 5902c6121b902f3a53f9fa97afe32c4e6cd63838 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 11:01:36 +0100 Subject: [PATCH 25/91] Further reduce dependency on impossible facts. Provide the data for the product in the category of categories without requiring such a category to actually exist --- src/Cat/Categories/Cat.agda | 193 ++++++++++++++++++------------------ 1 file changed, 98 insertions(+), 95 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 40fb754..146fd96 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -62,112 +62,115 @@ module _ (ℓ ℓ' : Level) where -- The following to some extend depends on the category of categories being a -- category. In some places it may not actually be needed, however. +module CatProducts {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where + private + :Object: = Object ℂ × Object 𝔻 + :Arrow: : :Object: → :Object: → Set ℓ' + :Arrow: (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ] + :𝟙: : {o : :Object:} → :Arrow: o o + :𝟙: = 𝟙 ℂ , 𝟙 𝔻 + _:⊕:_ : + {a b c : :Object:} → + :Arrow: b c → + :Arrow: a b → + :Arrow: a c + _:⊕:_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) → ℂ [ bc∈C ∘ ab∈C ] , 𝔻 [ bc∈D ∘ ab∈D ]} + + :rawProduct: : RawCategory ℓ ℓ' + RawCategory.Object :rawProduct: = :Object: + RawCategory.Arrow :rawProduct: = :Arrow: + RawCategory.𝟙 :rawProduct: = :𝟙: + RawCategory._∘_ :rawProduct: = _:⊕:_ + open RawCategory :rawProduct: + + module ℂ = Category ℂ + module 𝔻 = Category 𝔻 + open import Cubical.Sigma + arrowsAreSets : ArrowsAreSets -- {A B : RawCategory.Object :rawProduct:} → isSet (Arrow A B) + arrowsAreSets = setSig {sA = ℂ.arrowsAreSets} {sB = λ x → 𝔻.arrowsAreSets} + isIdentity : IsIdentity :𝟙: + isIdentity + = Σ≡ (fst ℂ.isIdentity) (fst 𝔻.isIdentity) + , Σ≡ (snd ℂ.isIdentity) (snd 𝔻.isIdentity) + postulate univalent : Univalence.Univalent :rawProduct: isIdentity + instance + :isCategory: : IsCategory :rawProduct: + IsCategory.isAssociative :isCategory: = Σ≡ ℂ.isAssociative 𝔻.isAssociative + IsCategory.isIdentity :isCategory: = isIdentity + IsCategory.arrowsAreSets :isCategory: = arrowsAreSets + IsCategory.univalent :isCategory: = univalent + + obj : Category ℓ ℓ' + Category.raw obj = :rawProduct: + + proj₁ : Functor obj ℂ + proj₁ = record + { raw = record { func* = fst ; func→ = fst } + ; isFunctor = record { isIdentity = refl ; isDistributive = refl } + } + + proj₂ : Functor obj 𝔻 + proj₂ = record + { raw = record { func* = snd ; func→ = snd } + ; isFunctor = record { isIdentity = refl ; isDistributive = refl } + } + + module _ {X : Category ℓ ℓ'} (x₁ : Functor X ℂ) (x₂ : Functor X 𝔻) where + private + x : Functor X obj + x = record + { raw = record + { func* = λ x → x₁.func* x , x₂.func* x + ; func→ = λ x → x₁.func→ x , x₂.func→ x + } + ; isFunctor = record + { isIdentity = Σ≡ x₁.isIdentity x₂.isIdentity + ; isDistributive = Σ≡ x₁.isDistributive x₂.isDistributive + } + } + where + open module x₁ = Functor x₁ + open module x₂ = Functor x₂ + + isUniqL : F[ proj₁ ∘ x ] ≡ x₁ + isUniqL = Functor≡ eq* eq→ + where + eq* : (F[ proj₁ ∘ x ]) .func* ≡ x₁ .func* + eq* = refl + eq→ : (λ i → {A : Object X} {B : Object X} → X [ A , B ] → ℂ [ eq* i A , eq* i B ]) + [ (F[ proj₁ ∘ x ]) .func→ ≡ x₁ .func→ ] + eq→ = refl + + isUniqR : F[ proj₂ ∘ x ] ≡ x₂ + isUniqR = Functor≡ refl refl + + isUniq : F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂ + isUniq = isUniqL , isUniqR + + isProduct : ∃![ x ] (F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂) + isProduct = x , isUniq + module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where + private + Catℓ = Cat ℓ ℓ' unprovable module _ (ℂ 𝔻 : Category ℓ ℓ') where private - :Object: = Object ℂ × Object 𝔻 - :Arrow: : :Object: → :Object: → Set ℓ' - :Arrow: (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ] - :𝟙: : {o : :Object:} → :Arrow: o o - :𝟙: = 𝟙 ℂ , 𝟙 𝔻 - _:⊕:_ : - {a b c : :Object:} → - :Arrow: b c → - :Arrow: a b → - :Arrow: a c - _:⊕:_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) → ℂ [ bc∈C ∘ ab∈C ] , 𝔻 [ bc∈D ∘ ab∈D ]} + module P = CatProducts ℂ 𝔻 - :rawProduct: : RawCategory ℓ ℓ' - RawCategory.Object :rawProduct: = :Object: - RawCategory.Arrow :rawProduct: = :Arrow: - RawCategory.𝟙 :rawProduct: = :𝟙: - RawCategory._∘_ :rawProduct: = _:⊕:_ - open RawCategory :rawProduct: - - module C = Category ℂ - module D = Category 𝔻 - open import Cubical.Sigma - issSet : {A B : RawCategory.Object :rawProduct:} → isSet (Arrow A B) - issSet = setSig {sA = C.arrowsAreSets} {sB = λ x → D.arrowsAreSets} - ident' : IsIdentity :𝟙: - ident' - = Σ≡ (fst C.isIdentity) (fst D.isIdentity) - , Σ≡ (snd C.isIdentity) (snd D.isIdentity) - postulate univalent : Univalence.Univalent :rawProduct: ident' instance - :isCategory: : IsCategory :rawProduct: - IsCategory.isAssociative :isCategory: = Σ≡ C.isAssociative D.isAssociative - IsCategory.isIdentity :isCategory: = ident' - IsCategory.arrowsAreSets :isCategory: = issSet - IsCategory.univalent :isCategory: = univalent - - :product: : Category ℓ ℓ' - Category.raw :product: = :rawProduct: - - proj₁ : Functor :product: ℂ - proj₁ = record - { raw = record { func* = fst ; func→ = fst } - ; isFunctor = record { isIdentity = refl ; isDistributive = refl } - } - - proj₂ : Functor :product: 𝔻 - proj₂ = record - { raw = record { func* = snd ; func→ = snd } - ; isFunctor = record { isIdentity = refl ; isDistributive = refl } - } - - module _ {X : Category ℓ ℓ'} (x₁ : Functor X ℂ) (x₂ : Functor X 𝔻) where - x : Functor X :product: - x = record - { raw = record - { func* = λ x → x₁ .func* x , x₂ .func* x - ; func→ = λ x → func→ x₁ x , func→ x₂ x - } - ; isFunctor = record - { isIdentity = Σ≡ x₁.isIdentity x₂.isIdentity - ; isDistributive = Σ≡ x₁.isDistributive x₂.isDistributive - } - } - where - open module x₁ = Functor x₁ - open module x₂ = Functor x₂ - - isUniqL : F[ proj₁ ∘ x ] ≡ x₁ - isUniqL = Functor≡ eq* eq→ - where - eq* : (F[ proj₁ ∘ x ]) .func* ≡ x₁ .func* - eq* = refl - eq→ : (λ i → {A : Object X} {B : Object X} → X [ A , B ] → ℂ [ eq* i A , eq* i B ]) - [ (F[ proj₁ ∘ x ]) .func→ ≡ x₁ .func→ ] - eq→ = refl - - isUniqR : F[ proj₂ ∘ x ] ≡ x₂ - isUniqR = Functor≡ refl refl - - isUniq : F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂ - isUniq = isUniqL , isUniqR - - uniq : ∃![ x ] (F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂) - uniq = x , isUniq - - Catℓ = Cat ℓ ℓ' unprovable - - instance - isProduct : IsProduct Catℓ proj₁ proj₂ - isProduct = uniq + isProduct : IsProduct Catℓ P.proj₁ P.proj₂ + isProduct = P.isProduct product : Product {ℂ = Catℓ} ℂ 𝔻 product = record - { obj = :product: - ; proj₁ = proj₁ - ; proj₂ = proj₂ + { obj = P.obj + ; proj₁ = P.proj₁ + ; proj₂ = P.proj₂ } -module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where - Catt = Cat ℓ ℓ' unprovable instance - hasProducts : HasProducts Catt - hasProducts = record { product = product unprovable } + hasProducts : HasProducts Catℓ + hasProducts = record { product = product } -- Basically proves that `Cat ℓ ℓ` is cartesian closed. module _ (ℓ : Level) (unprovable : IsCategory (RawCat ℓ ℓ)) where From a4890a42cf8458b34e53eab49ccb94fc01709ce3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 11:13:37 +0100 Subject: [PATCH 26/91] Define Monoidal categories without depending on category of categories --- src/Cat/Categories/Cat.agda | 5 +++-- src/Cat/Category/Monoid.agda | 12 ++++++++---- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 146fd96..c7f1026 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -62,7 +62,7 @@ module _ (ℓ ℓ' : Level) where -- The following to some extend depends on the category of categories being a -- category. In some places it may not actually be needed, however. -module CatProducts {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where +module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where private :Object: = Object ℂ × Object 𝔻 :Arrow: : :Object: → :Object: → Set ℓ' @@ -153,9 +153,10 @@ module CatProducts {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where private Catℓ = Cat ℓ ℓ' unprovable + module _ (ℂ 𝔻 : Category ℓ ℓ') where private - module P = CatProducts ℂ 𝔻 + module P = CatProduct ℂ 𝔻 instance isProduct : IsProduct Catℓ P.proj₁ P.proj₂ diff --git a/src/Cat/Category/Monoid.agda b/src/Cat/Category/Monoid.agda index 3323487..6cce193 100644 --- a/src/Cat/Category/Monoid.agda +++ b/src/Cat/Category/Monoid.agda @@ -12,10 +12,14 @@ module _ (ℓa ℓb : Level) where private ℓ = lsuc (ℓa ⊔ ℓb) - -- Might not need this to be able to form products of categories! - postulate unprovable : IsCategory (Cat.RawCat ℓa ℓb) - - open HasProducts (Cat.hasProducts unprovable) + -- *If* the category of categories existed `_×_` would be equivalent to the + -- one brought into scope by doing: + -- + -- open HasProducts (Cat.hasProducts unprovable) using (_×_) + -- + -- Since it doesn't we'll make the following (definitionally equivalent) ad-hoc definition. + _×_ : ∀ {ℓa ℓb} → Category ℓa ℓb → Category ℓa ℓb → Category ℓa ℓb + ℂ × 𝔻 = Cat.CatProduct.obj ℂ 𝔻 record RawMonoidalCategory : Set ℓ where field From 059c74b687c587d165d277ff45b1de6b4504fab4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 11:15:45 +0100 Subject: [PATCH 27/91] Use already defined category --- src/Cat/Category/Yoneda.agda | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index abd76d0..be6e6b6 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -25,7 +25,7 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} (unprovable : IsCategory (RawCat 𝓢 = Sets ℓ open Fun (opposite ℂ) 𝓢 Catℓ : Category _ _ - Catℓ = record { raw = RawCat ℓ ℓ ; isCategory = unprovable} + Catℓ = Cat.Cat ℓ ℓ unprovable prshf = presheaf {ℂ = ℂ} module ℂ = Category ℂ From 5c3616bca51bc83bfd241674683741537a2dd143 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 11:17:31 +0100 Subject: [PATCH 28/91] Make argument to presheaf explicit --- src/Cat/Categories/Sets.agda | 29 +++++++++++++---------------- src/Cat/Category/Yoneda.agda | 2 +- 2 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index 0ed99a3..11ddc3f 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -80,19 +80,20 @@ module _ {ℓ : Level} where SetsHasProducts : HasProducts 𝓢 SetsHasProducts = record { product = product } -module _ {ℓa ℓb : Level} where - module _ (ℂ : Category ℓa ℓb) where - -- Covariant Presheaf - Representable : Set (ℓa ⊔ lsuc ℓb) - Representable = Functor ℂ (𝓢𝓮𝓽 ℓb) +module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where + -- Covariant Presheaf + Representable : Set (ℓa ⊔ lsuc ℓb) + Representable = Functor ℂ (𝓢𝓮𝓽 ℓb) - -- Contravariant Presheaf - Presheaf : Set (ℓa ⊔ lsuc ℓb) - Presheaf = Functor (opposite ℂ) (𝓢𝓮𝓽 ℓb) + -- Contravariant Presheaf + Presheaf : Set (ℓa ⊔ lsuc ℓb) + Presheaf = Functor (opposite ℂ) (𝓢𝓮𝓽 ℓb) + + open Category ℂ -- The "co-yoneda" embedding. - representable : {ℂ : Category ℓa ℓb} → Category.Object ℂ → Representable ℂ - representable {ℂ = ℂ} A = record + representable : Category.Object ℂ → Representable + representable A = record { raw = record { func* = λ B → ℂ [ A , B ] , arrowsAreSets ; func→ = ℂ [_∘_] @@ -102,12 +103,10 @@ module _ {ℓa ℓb : Level} where ; isDistributive = funExt λ x → sym isAssociative } } - where - open Category ℂ -- Alternate name: `yoneda` - presheaf : {ℂ : Category ℓa ℓb} → Category.Object (opposite ℂ) → Presheaf ℂ - presheaf {ℂ = ℂ} B = record + presheaf : Category.Object (opposite ℂ) → Presheaf + presheaf B = record { raw = record { func* = λ A → ℂ [ A , B ] , arrowsAreSets ; func→ = λ f g → ℂ [ g ∘ f ] @@ -117,5 +116,3 @@ module _ {ℓa ℓb : Level} where ; isDistributive = funExt λ x → isAssociative } } - where - open Category ℂ diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index be6e6b6..df39252 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -26,7 +26,7 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} (unprovable : IsCategory (RawCat open Fun (opposite ℂ) 𝓢 Catℓ : Category _ _ Catℓ = Cat.Cat ℓ ℓ unprovable - prshf = presheaf {ℂ = ℂ} + prshf = presheaf ℂ module ℂ = Category ℂ _⇑_ : (A B : Category.Object Catℓ) → Category.Object Catℓ From 1bf565b87abeb96ebd29fce623633cf10a1a2982 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 13:52:41 +0100 Subject: [PATCH 29/91] Have yoneda without having a category of categories I did break some things in Cat.Categories.Cat but since this is unprovable anyways it's not that big a deal. --- src/Cat/Categories/Cat.agda | 383 ++++++++++++++++-------------- src/Cat/Category/Exponential.agda | 42 ++-- src/Cat/Category/Monoid.agda | 15 +- src/Cat/Category/Product.agda | 28 ++- src/Cat/Category/Yoneda.agda | 16 +- 5 files changed, 259 insertions(+), 225 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index c7f1026..2bed7c2 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -11,7 +11,7 @@ open import Data.Product renaming (proj₁ to fst ; proj₂ to snd) open import Cat.Category open import Cat.Category.Functor open import Cat.Category.Product -open import Cat.Category.Exponential +open import Cat.Category.Exponential hiding (_×_ ; product) open import Cat.Category.NaturalTransformation open import Cat.Equality @@ -174,190 +174,211 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where hasProducts = record { product = product } -- Basically proves that `Cat ℓ ℓ` is cartesian closed. +module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where + open Data.Product + open import Cat.Categories.Fun + + Categoryℓ = Category ℓ ℓ + open Fun ℂ 𝔻 renaming (identity to idN) + private + :func*: : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 + :func*: (F , A) = func* F A + + prodObj : Categoryℓ + prodObj = Fun + + module _ {dom cod : Functor ℂ 𝔻 × Object ℂ} where + private + F : Functor ℂ 𝔻 + F = proj₁ dom + A : Object ℂ + A = proj₂ dom + + G : Functor ℂ 𝔻 + G = proj₁ cod + B : Object ℂ + B = proj₂ cod + + :func→: : (pobj : NaturalTransformation F G × ℂ [ A , B ]) + → 𝔻 [ func* F A , func* G B ] + :func→: ((θ , θNat) , f) = result + where + θA : 𝔻 [ func* F A , func* G A ] + θA = θ A + θB : 𝔻 [ func* F B , func* G B ] + θB = θ B + F→f : 𝔻 [ func* F A , func* F B ] + F→f = func→ F f + G→f : 𝔻 [ func* G A , func* G B ] + G→f = func→ G f + l : 𝔻 [ func* F A , func* G B ] + l = 𝔻 [ θB ∘ F→f ] + r : 𝔻 [ func* F A , func* G B ] + r = 𝔻 [ G→f ∘ θA ] + -- There are two choices at this point, + -- but I suppose the whole point is that + -- by `θNat f` we have `l ≡ r` + -- lem : 𝔻 [ θ B ∘ F .func→ f ] ≡ 𝔻 [ G .func→ f ∘ θ A ] + -- lem = θNat f + result : 𝔻 [ func* F A , func* G B ] + result = l + + open CatProduct renaming (obj to _×p_) using () + + module _ {c : Functor ℂ 𝔻 × Object ℂ} where + private + F : Functor ℂ 𝔻 + F = proj₁ c + C : Object ℂ + C = proj₂ c + + -- NaturalTransformation F G × ℂ .Arrow A B + -- :ident: : :func→: {c} {c} (identityNat F , ℂ .𝟙) ≡ 𝔻 .𝟙 + -- :ident: = trans (proj₂ 𝔻.isIdentity) (F .isIdentity) + -- where + -- open module 𝔻 = IsCategory (𝔻 .isCategory) + -- Unfortunately the equational version has some ambigous arguments. + + :ident: : :func→: {c} {c} (NT.identity F , 𝟙 ℂ {A = proj₂ c}) ≡ 𝟙 𝔻 + :ident: = begin + :func→: {c} {c} (𝟙 (prodObj ×p ℂ) {c}) ≡⟨⟩ + :func→: {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ + 𝔻 [ identityTrans F C ∘ func→ F (𝟙 ℂ)] ≡⟨⟩ + 𝔻 [ 𝟙 𝔻 ∘ func→ F (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ + func→ F (𝟙 ℂ) ≡⟨ F.isIdentity ⟩ + 𝟙 𝔻 ∎ + where + open module 𝔻 = Category 𝔻 + open module F = Functor F + + module _ {F×A G×B H×C : Functor ℂ 𝔻 × Object ℂ} where + F = F×A .proj₁ + A = F×A .proj₂ + G = G×B .proj₁ + B = G×B .proj₂ + H = H×C .proj₁ + C = H×C .proj₂ + -- Not entirely clear what this is at this point: + _P⊕_ = Category._∘_ (prodObj ×p ℂ) {F×A} {G×B} {H×C} + module _ + -- NaturalTransformation F G × ℂ .Arrow A B + {θ×f : NaturalTransformation F G × ℂ [ A , B ]} + {η×g : NaturalTransformation G H × ℂ [ B , C ]} where + private + θ : Transformation F G + θ = proj₁ (proj₁ θ×f) + θNat : Natural F G θ + θNat = proj₂ (proj₁ θ×f) + f : ℂ [ A , B ] + f = proj₂ θ×f + η : Transformation G H + η = proj₁ (proj₁ η×g) + ηNat : Natural G H η + ηNat = proj₂ (proj₁ η×g) + g : ℂ [ B , C ] + g = proj₂ η×g + + ηθNT : NaturalTransformation F H + ηθNT = Category._∘_ Fun {F} {G} {H} (η , ηNat) (θ , θNat) + + ηθ = proj₁ ηθNT + ηθNat = proj₂ ηθNT + + :isDistributive: : + 𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ func→ F ( ℂ [ g ∘ f ] ) ] + ≡ 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ θ B ∘ func→ F f ] ] + :isDistributive: = begin + 𝔻 [ (ηθ C) ∘ func→ F (ℂ [ g ∘ f ]) ] + ≡⟨ ηθNat (ℂ [ g ∘ f ]) ⟩ + 𝔻 [ func→ H (ℂ [ g ∘ f ]) ∘ (ηθ A) ] + ≡⟨ cong (λ φ → 𝔻 [ φ ∘ ηθ A ]) (H.isDistributive) ⟩ + 𝔻 [ 𝔻 [ func→ H g ∘ func→ H f ] ∘ (ηθ A) ] + ≡⟨ sym isAssociative ⟩ + 𝔻 [ func→ H g ∘ 𝔻 [ func→ H f ∘ ηθ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) isAssociative ⟩ + 𝔻 [ func→ H g ∘ 𝔻 [ 𝔻 [ func→ H f ∘ η A ] ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) (cong (λ φ → 𝔻 [ φ ∘ θ A ]) (sym (ηNat f))) ⟩ + 𝔻 [ func→ H g ∘ 𝔻 [ 𝔻 [ η B ∘ func→ G f ] ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) (sym isAssociative) ⟩ + 𝔻 [ func→ H g ∘ 𝔻 [ η B ∘ 𝔻 [ func→ G f ∘ θ A ] ] ] + ≡⟨ isAssociative ⟩ + 𝔻 [ 𝔻 [ func→ H g ∘ η B ] ∘ 𝔻 [ func→ G f ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ φ ∘ 𝔻 [ func→ G f ∘ θ A ] ]) (sym (ηNat g)) ⟩ + 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ func→ G f ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ φ ]) (sym (θNat f)) ⟩ + 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ θ B ∘ func→ F f ] ] ∎ + where + open Category 𝔻 + module H = Functor H + + eval : Functor (CatProduct.obj prodObj ℂ) 𝔻 + -- :eval: : Functor (prodObj ×p ℂ) 𝔻 + eval = record + { raw = record + { func* = :func*: + ; func→ = λ {dom} {cod} → :func→: {dom} {cod} + } + ; isFunctor = record + { isIdentity = λ {o} → :ident: {o} + ; isDistributive = λ {f u n k y} → :isDistributive: {f} {u} {n} {k} {y} + } + } + + module _ (𝔸 : Category ℓ ℓ) (F : Functor (𝔸 ×p ℂ) 𝔻) where + -- open HasProducts (hasProducts {ℓ} {ℓ} unprovable) renaming (_|×|_ to parallelProduct) + + postulate + parallelProduct + : Functor 𝔸 prodObj → Functor ℂ ℂ + → Functor (𝔸 ×p ℂ) (prodObj ×p ℂ) + transpose : Functor 𝔸 prodObj + eq : F[ eval ∘ (parallelProduct transpose (identity {C = ℂ})) ] ≡ F + -- eq : F[ :eval: ∘ {!!} ] ≡ F + -- eq : Catℓ [ :eval: ∘ (HasProducts._|×|_ hasProducts transpose (𝟙 Catℓ {o = ℂ})) ] ≡ F + -- eq' : (Catℓ [ :eval: ∘ + -- (record { product = product } HasProducts.|×| transpose) + -- (𝟙 Catℓ) + -- ]) + -- ≡ F + + -- For some reason after `e8215b2c051062c6301abc9b3f6ec67106259758` + -- `catTranspose` makes Agda hang. catTranspose : ∃![ F~ ] (Catℓ [ + -- :eval: ∘ (parallelProduct F~ (𝟙 Catℓ {o = ℂ}))] ≡ F) catTranspose = + -- transpose , eq + module _ (ℓ : Level) (unprovable : IsCategory (RawCat ℓ ℓ)) where private - open Data.Product - open import Cat.Categories.Fun - Catℓ : Category (lsuc (ℓ ⊔ ℓ)) (ℓ ⊔ ℓ) Catℓ = Cat ℓ ℓ unprovable - module _ (ℂ 𝔻 : Category ℓ ℓ) where - open Fun ℂ 𝔻 renaming (identity to idN) - private - :obj: : Object Catℓ - :obj: = Fun + module _ (ℂ 𝔻 : Category ℓ ℓ) where + open CatExponential ℂ 𝔻 using (prodObj ; eval) + -- Putting in the type annotation causes Agda to loop indefinitely. + -- eval' : Functor (CatProduct.obj prodObj ℂ) 𝔻 + -- Likewise, using it below also results in this. + eval' : _ + eval' = eval + -- private + -- -- module _ (ℂ 𝔻 : Category ℓ ℓ) where + -- postulate :isExponential: : IsExponential Catℓ ℂ 𝔻 prodObj :eval: + -- -- :isExponential: : IsExponential Catℓ ℂ 𝔻 :obj: :eval: + -- -- :isExponential: = {!catTranspose!} + -- -- where + -- -- open HasProducts (hasProducts {ℓ} {ℓ} unprovable) using (_|×|_) + -- -- :isExponential: = λ 𝔸 F → transpose 𝔸 F , eq' 𝔸 F - :func*: : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 - :func*: (F , A) = func* F A - - module _ {dom cod : Functor ℂ 𝔻 × Object ℂ} where - private - F : Functor ℂ 𝔻 - F = proj₁ dom - A : Object ℂ - A = proj₂ dom - - G : Functor ℂ 𝔻 - G = proj₁ cod - B : Object ℂ - B = proj₂ cod - - :func→: : (pobj : NaturalTransformation F G × ℂ [ A , B ]) - → 𝔻 [ func* F A , func* G B ] - :func→: ((θ , θNat) , f) = result - where - θA : 𝔻 [ func* F A , func* G A ] - θA = θ A - θB : 𝔻 [ func* F B , func* G B ] - θB = θ B - F→f : 𝔻 [ func* F A , func* F B ] - F→f = func→ F f - G→f : 𝔻 [ func* G A , func* G B ] - G→f = func→ G f - l : 𝔻 [ func* F A , func* G B ] - l = 𝔻 [ θB ∘ F→f ] - r : 𝔻 [ func* F A , func* G B ] - r = 𝔻 [ G→f ∘ θA ] - -- There are two choices at this point, - -- but I suppose the whole point is that - -- by `θNat f` we have `l ≡ r` - -- lem : 𝔻 [ θ B ∘ F .func→ f ] ≡ 𝔻 [ G .func→ f ∘ θ A ] - -- lem = θNat f - result : 𝔻 [ func* F A , func* G B ] - result = l - - _×p_ = product unprovable - - module _ {c : Functor ℂ 𝔻 × Object ℂ} where - private - F : Functor ℂ 𝔻 - F = proj₁ c - C : Object ℂ - C = proj₂ c - - -- NaturalTransformation F G × ℂ .Arrow A B - -- :ident: : :func→: {c} {c} (identityNat F , ℂ .𝟙) ≡ 𝔻 .𝟙 - -- :ident: = trans (proj₂ 𝔻.isIdentity) (F .isIdentity) - -- where - -- open module 𝔻 = IsCategory (𝔻 .isCategory) - -- Unfortunately the equational version has some ambigous arguments. - - :ident: : :func→: {c} {c} (NT.identity F , 𝟙 ℂ {A = proj₂ c}) ≡ 𝟙 𝔻 - :ident: = begin - :func→: {c} {c} (𝟙 (Product.obj (:obj: ×p ℂ)) {c}) ≡⟨⟩ - :func→: {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ - 𝔻 [ identityTrans F C ∘ func→ F (𝟙 ℂ)] ≡⟨⟩ - 𝔻 [ 𝟙 𝔻 ∘ func→ F (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ - func→ F (𝟙 ℂ) ≡⟨ F.isIdentity ⟩ - 𝟙 𝔻 ∎ - where - open module 𝔻 = Category 𝔻 - open module F = Functor F - - module _ {F×A G×B H×C : Functor ℂ 𝔻 × Object ℂ} where - F = F×A .proj₁ - A = F×A .proj₂ - G = G×B .proj₁ - B = G×B .proj₂ - H = H×C .proj₁ - C = H×C .proj₂ - -- Not entirely clear what this is at this point: - _P⊕_ = Category._∘_ (Product.obj (:obj: ×p ℂ)) {F×A} {G×B} {H×C} - module _ - -- NaturalTransformation F G × ℂ .Arrow A B - {θ×f : NaturalTransformation F G × ℂ [ A , B ]} - {η×g : NaturalTransformation G H × ℂ [ B , C ]} where - private - θ : Transformation F G - θ = proj₁ (proj₁ θ×f) - θNat : Natural F G θ - θNat = proj₂ (proj₁ θ×f) - f : ℂ [ A , B ] - f = proj₂ θ×f - η : Transformation G H - η = proj₁ (proj₁ η×g) - ηNat : Natural G H η - ηNat = proj₂ (proj₁ η×g) - g : ℂ [ B , C ] - g = proj₂ η×g - - ηθNT : NaturalTransformation F H - ηθNT = Category._∘_ Fun {F} {G} {H} (η , ηNat) (θ , θNat) - - ηθ = proj₁ ηθNT - ηθNat = proj₂ ηθNT - - :isDistributive: : - 𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ func→ F ( ℂ [ g ∘ f ] ) ] - ≡ 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ θ B ∘ func→ F f ] ] - :isDistributive: = begin - 𝔻 [ (ηθ C) ∘ func→ F (ℂ [ g ∘ f ]) ] - ≡⟨ ηθNat (ℂ [ g ∘ f ]) ⟩ - 𝔻 [ func→ H (ℂ [ g ∘ f ]) ∘ (ηθ A) ] - ≡⟨ cong (λ φ → 𝔻 [ φ ∘ ηθ A ]) (H.isDistributive) ⟩ - 𝔻 [ 𝔻 [ func→ H g ∘ func→ H f ] ∘ (ηθ A) ] - ≡⟨ sym isAssociative ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ func→ H f ∘ ηθ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) isAssociative ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ 𝔻 [ func→ H f ∘ η A ] ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) (cong (λ φ → 𝔻 [ φ ∘ θ A ]) (sym (ηNat f))) ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ 𝔻 [ η B ∘ func→ G f ] ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) (sym isAssociative) ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ η B ∘ 𝔻 [ func→ G f ∘ θ A ] ] ] - ≡⟨ isAssociative ⟩ - 𝔻 [ 𝔻 [ func→ H g ∘ η B ] ∘ 𝔻 [ func→ G f ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ φ ∘ 𝔻 [ func→ G f ∘ θ A ] ]) (sym (ηNat g)) ⟩ - 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ func→ G f ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ φ ]) (sym (θNat f)) ⟩ - 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ θ B ∘ func→ F f ] ] ∎ - where - open Category 𝔻 - module H = Functor H - - :eval: : Functor ((:obj: ×p ℂ) .Product.obj) 𝔻 - :eval: = record - { raw = record - { func* = :func*: - ; func→ = λ {dom} {cod} → :func→: {dom} {cod} - } - ; isFunctor = record - { isIdentity = λ {o} → :ident: {o} - ; isDistributive = λ {f u n k y} → :isDistributive: {f} {u} {n} {k} {y} - } - } - - module _ (𝔸 : Category ℓ ℓ) (F : Functor ((𝔸 ×p ℂ) .Product.obj) 𝔻) where - open HasProducts (hasProducts {ℓ} {ℓ} unprovable) renaming (_|×|_ to parallelProduct) - - postulate - transpose : Functor 𝔸 :obj: - eq : Catℓ [ :eval: ∘ (parallelProduct transpose (𝟙 Catℓ {A = ℂ})) ] ≡ F - -- eq : Catℓ [ :eval: ∘ (HasProducts._|×|_ hasProducts transpose (𝟙 Catℓ {o = ℂ})) ] ≡ F - -- eq' : (Catℓ [ :eval: ∘ - -- (record { product = product } HasProducts.|×| transpose) - -- (𝟙 Catℓ) - -- ]) - -- ≡ F - - -- For some reason after `e8215b2c051062c6301abc9b3f6ec67106259758` - -- `catTranspose` makes Agda hang. catTranspose : ∃![ F~ ] (Catℓ [ - -- :eval: ∘ (parallelProduct F~ (𝟙 Catℓ {o = ℂ}))] ≡ F) catTranspose = - -- transpose , eq - - postulate :isExponential: : IsExponential Catℓ ℂ 𝔻 :obj: :eval: - -- :isExponential: : IsExponential Catℓ ℂ 𝔻 :obj: :eval: - -- :isExponential: = {!catTranspose!} - -- where - -- open HasProducts (hasProducts {ℓ} {ℓ} unprovable) using (_|×|_) - -- :isExponential: = λ 𝔸 F → transpose 𝔸 F , eq' 𝔸 F - - -- :exponent: : Exponential (Cat ℓ ℓ) A B - :exponent: : Exponential Catℓ ℂ 𝔻 - :exponent: = record - { obj = :obj: - ; eval = :eval: - ; isExponential = :isExponential: - } + -- -- :exponent: : Exponential (Cat ℓ ℓ) A B + exponent : Exponential Catℓ ℂ 𝔻 + exponent = record + { obj = prodObj + ; eval = {!evalll'!} + ; isExponential = {!:isExponential:!} + } + where + open HasProducts (hasProducts unprovable) renaming (_×_ to _×p_) + open import Cat.Categories.Fun + open Fun + -- _×p_ = CatProduct.obj -- prodObj ℂ + -- eval' : Functor CatP.obj 𝔻 hasExponentials : HasExponentials Catℓ - hasExponentials = record { exponent = :exponent: } + hasExponentials = record { exponent = exponent } diff --git a/src/Cat/Category/Exponential.agda b/src/Cat/Category/Exponential.agda index 1e443ce..87769f6 100644 --- a/src/Cat/Category/Exponential.agda +++ b/src/Cat/Category/Exponential.agda @@ -1,40 +1,44 @@ module Cat.Category.Exponential where open import Agda.Primitive -open import Data.Product +open import Data.Product hiding (_×_) open import Cubical open import Cat.Category open import Cat.Category.Product -open Category - module _ {ℓ ℓ'} (ℂ : Category ℓ ℓ') {{hasProducts : HasProducts ℂ}} where - open HasProducts hasProducts - open Product hiding (obj) - private - _×p_ : (A B : Object ℂ) → Object ℂ - _×p_ A B = Product.obj (product A B) + open Category ℂ + open HasProducts hasProducts public - module _ (B C : Object ℂ) where - IsExponential : (Cᴮ : Object ℂ) → ℂ [ Cᴮ ×p B , C ] → Set (ℓ ⊔ ℓ') - IsExponential Cᴮ eval = ∀ (A : Object ℂ) (f : ℂ [ A ×p B , C ]) + module _ (B C : Object) where + record IsExponential' + (Cᴮ : Object) + (eval : ℂ [ Cᴮ × B , C ]) : Set (ℓ ⊔ ℓ') where + field + uniq + : ∀ (A : Object) (f : ℂ [ A × B , C ]) + → ∃![ f~ ] (ℂ [ eval ∘ f~ |×| Category.𝟙 ℂ ] ≡ f) + + IsExponential : (Cᴮ : Object) → ℂ [ Cᴮ × B , C ] → Set (ℓ ⊔ ℓ') + IsExponential Cᴮ eval = ∀ (A : Object) (f : ℂ [ A × B , C ]) → ∃![ f~ ] (ℂ [ eval ∘ f~ |×| Category.𝟙 ℂ ] ≡ f) record Exponential : Set (ℓ ⊔ ℓ') where field -- obj ≡ Cᴮ - obj : Object ℂ - eval : ℂ [ obj ×p B , C ] + obj : Object + eval : ℂ [ obj × B , C ] {{isExponential}} : IsExponential obj eval - -- If I make this an instance-argument then the instance resolution - -- algorithm goes into an infinite loop. Why? - exponentialsHaveProducts : HasProducts ℂ - exponentialsHaveProducts = hasProducts - transpose : (A : Object ℂ) → ℂ [ A ×p B , C ] → ℂ [ A , obj ] + + transpose : (A : Object) → ℂ [ A × B , C ] → ℂ [ A , obj ] transpose A f = proj₁ (isExponential A f) record HasExponentials {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') {{_ : HasProducts ℂ}} : Set (ℓ ⊔ ℓ') where + open Category ℂ open Exponential public field - exponent : (A B : Object ℂ) → Exponential ℂ A B + exponent : (A B : Object) → Exponential ℂ A B + + _⇑_ : (A B : Object) → Object + A ⇑ B = (exponent A B) .obj diff --git a/src/Cat/Category/Monoid.agda b/src/Cat/Category/Monoid.agda index 6cce193..a17468e 100644 --- a/src/Cat/Category/Monoid.agda +++ b/src/Cat/Category/Monoid.agda @@ -27,9 +27,10 @@ module _ (ℓa ℓb : Level) where open Category category public field {{hasProducts}} : HasProducts category - mempty : Object + empty : Object -- aka. tensor product, monoidal product. - mappend : Functor (category × category) category + append : Functor (category × category) category + open HasProducts hasProducts public record MonoidalCategory : Set ℓ where field @@ -40,10 +41,10 @@ module _ {ℓa ℓb : Level} (ℂ : MonoidalCategory ℓa ℓb) where private ℓ = ℓa ⊔ ℓb - module MC = MonoidalCategory ℂ - open HasProducts MC.hasProducts + open MonoidalCategory ℂ public + record Monoid : Set ℓ where field - carrier : MC.Object - mempty : MC.Arrow (carrier × carrier) carrier - mappend : MC.Arrow MC.mempty carrier + carrier : Object + mempty : Arrow empty carrier + mappend : Arrow (carrier × carrier) carrier diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 5eca0e0..aeb4f44 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -31,6 +31,7 @@ record Product {ℓ ℓ' : Level} {ℂ : Category ℓ ℓ'} (A B : Object ℂ) : proj₂ : ℂ [ obj , B ] {{isProduct}} : IsProduct ℂ proj₁ proj₂ + -- | Arrow product _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ]) → ℂ [ X , obj ] _P[_×_] π₁ π₂ = proj₁ (isProduct π₁ π₂) @@ -39,16 +40,21 @@ record HasProducts {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') : Set (ℓ ⊔ field product : ∀ (A B : Object ℂ) → Product {ℂ = ℂ} A B - open Product + open Product hiding (obj) - _×_ : (A B : Object ℂ) → Object ℂ - A × B = Product.obj (product A B) - -- The product mentioned in awodey in Def 6.1 is not the regular product of arrows. - -- It's a "parallel" product - _|×|_ : {A A' B B' : Object ℂ} → ℂ [ A , A' ] → ℂ [ B , B' ] - → ℂ [ A × B , A' × B' ] - _|×|_ {A = A} {A' = A'} {B = B} {B' = B'} a b - = product A' B' - P[ ℂ [ a ∘ (product A B) .proj₁ ] - × ℂ [ b ∘ (product A B) .proj₂ ] + module _ (A B : Object ℂ) where + open Product (product A B) + _×_ : Object ℂ + _×_ = obj + + -- | Parallel product of arrows + -- + -- The product mentioned in awodey in Def 6.1 is not the regular product of + -- arrows. It's a "parallel" product + module _ {A A' B B' : Object ℂ} where + open Product (product A B) hiding (_P[_×_]) renaming (proj₁ to fst ; proj₂ to snd) + _|×|_ : ℂ [ A , A' ] → ℂ [ B , B' ] → ℂ [ A × B , A' × B' ] + a |×| b = product A' B' + P[ ℂ [ a ∘ fst ] + × ℂ [ b ∘ snd ] ] diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index df39252..365f441 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -15,7 +15,7 @@ open Equality.Data.Product -- category of categories (since it doesn't exist). open import Cat.Categories.Cat using (RawCat) -module _ {ℓ : Level} {ℂ : Category ℓ ℓ} (unprovable : IsCategory (RawCat ℓ ℓ)) where +module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where private open import Cat.Categories.Fun open import Cat.Categories.Sets @@ -24,15 +24,17 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} (unprovable : IsCategory (RawCat open Functor 𝓢 = Sets ℓ open Fun (opposite ℂ) 𝓢 - Catℓ : Category _ _ - Catℓ = Cat.Cat ℓ ℓ unprovable prshf = presheaf ℂ module ℂ = Category ℂ - _⇑_ : (A B : Category.Object Catℓ) → Category.Object Catℓ - A ⇑ B = (exponent A B) .obj - where - open HasExponentials (Cat.hasExponentials ℓ unprovable) + -- There is no (small) category of categories. So we won't use _⇑_ from + -- `HasExponential` + -- + -- open HasExponentials (Cat.hasExponentials ℓ unprovable) using (_⇑_) + -- + -- In stead we'll use an ad-hoc definition -- which is definitionally + -- equivalent to that other one. + _⇑_ = Cat.CatExponential.prodObj module _ {A B : ℂ.Object} (f : ℂ [ A , B ]) where :func→: : NaturalTransformation (prshf A) (prshf B) From 7fbca1aeebee93ca07b09720db77408f3c20ba52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 14:04:04 +0100 Subject: [PATCH 30/91] Clean-up yoneda embedding --- src/Cat/Category/Yoneda.agda | 55 ++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 31 deletions(-) diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index 365f441..87d37c0 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -5,23 +5,18 @@ module Cat.Category.Yoneda where open import Agda.Primitive open import Data.Product open import Cubical +open import Cubical.NType.Properties open import Cat.Category open import Cat.Category.Functor open import Cat.Equality -open Equality.Data.Product --- TODO: We want to avoid defining the yoneda embedding going through the --- category of categories (since it doesn't exist). -open import Cat.Categories.Cat using (RawCat) +open import Cat.Categories.Fun +open import Cat.Categories.Sets +open import Cat.Categories.Cat module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where private - open import Cat.Categories.Fun - open import Cat.Categories.Sets - module Cat = Cat.Categories.Cat - open import Cat.Category.Exponential - open Functor 𝓢 = Sets ℓ open Fun (opposite ℂ) 𝓢 prshf = presheaf ℂ @@ -34,33 +29,31 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where -- -- In stead we'll use an ad-hoc definition -- which is definitionally -- equivalent to that other one. - _⇑_ = Cat.CatExponential.prodObj + _⇑_ = CatExponential.prodObj module _ {A B : ℂ.Object} (f : ℂ [ A , B ]) where :func→: : NaturalTransformation (prshf A) (prshf B) :func→: = (λ C x → ℂ [ f ∘ x ]) , λ f₁ → funExt λ _ → ℂ.isAssociative - module _ {c : Category.Object ℂ} where - eqTrans : (λ _ → Transformation (prshf c) (prshf c)) - [ (λ _ x → ℂ [ ℂ.𝟙 ∘ x ]) ≡ identityTrans (prshf c) ] - eqTrans = funExt λ x → funExt λ x → ℂ.isIdentity .proj₂ + rawYoneda : RawFunctor ℂ Fun + RawFunctor.func* rawYoneda = prshf + RawFunctor.func→ rawYoneda = :func→: + open RawFunctor rawYoneda - open import Cubical.NType.Properties - open import Cat.Categories.Fun - :ident: : :func→: (ℂ.𝟙 {c}) ≡ Category.𝟙 Fun {A = prshf c} - :ident: = lemSig (naturalIsProp {F = prshf c} {prshf c}) _ _ eq - where - eq : (λ C x → ℂ [ ℂ.𝟙 ∘ x ]) ≡ identityTrans (prshf c) - eq = funExt λ A → funExt λ B → proj₂ ℂ.isIdentity + isIdentity : IsIdentity + isIdentity {c} = lemSig (naturalIsProp {F = prshf c} {prshf c}) _ _ eq + where + eq : (λ C x → ℂ [ ℂ.𝟙 ∘ x ]) ≡ identityTrans (prshf c) + eq = funExt λ A → funExt λ B → proj₂ ℂ.isIdentity + + isDistributive : IsDistributive + isDistributive = {!!} + + instance + isFunctor : IsFunctor ℂ Fun rawYoneda + IsFunctor.isIdentity isFunctor = isIdentity + IsFunctor.isDistributive isFunctor = isDistributive yoneda : Functor ℂ Fun - yoneda = record - { raw = record - { func* = prshf - ; func→ = :func→: - } - ; isFunctor = record - { isIdentity = :ident: - ; isDistributive = {!!} - } - } + Functor.raw yoneda = rawYoneda + Functor.isFunctor yoneda = isFunctor From ce4dd83969f4ed67baca5c1ce3a576e72409f83b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 14:42:12 +0100 Subject: [PATCH 31/91] Prove that the yoneda embedding is distributive --- src/Cat/Category/Yoneda.agda | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index 87d37c0..88b0bbd 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -32,12 +32,18 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where _⇑_ = CatExponential.prodObj module _ {A B : ℂ.Object} (f : ℂ [ A , B ]) where - :func→: : NaturalTransformation (prshf A) (prshf B) - :func→: = (λ C x → ℂ [ f ∘ x ]) , λ f₁ → funExt λ _ → ℂ.isAssociative + fmap : Transformation (prshf A) (prshf B) + fmap C x = ℂ [ f ∘ x ] + + fmapNatural : Natural (prshf A) (prshf B) fmap + fmapNatural g = funExt λ _ → ℂ.isAssociative + + fmapNT : NaturalTransformation (prshf A) (prshf B) + fmapNT = fmap , fmapNatural rawYoneda : RawFunctor ℂ Fun RawFunctor.func* rawYoneda = prshf - RawFunctor.func→ rawYoneda = :func→: + RawFunctor.func→ rawYoneda = fmapNT open RawFunctor rawYoneda isIdentity : IsIdentity @@ -47,7 +53,22 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where eq = funExt λ A → funExt λ B → proj₂ ℂ.isIdentity isDistributive : IsDistributive - isDistributive = {!!} + isDistributive {A} {B} {C} {f = f} {g} + = lemSig (propIsNatural (prshf A) (prshf C)) _ _ eq + where + T[_∘_]' = T[_∘_] {F = prshf A} {prshf B} {prshf C} + eqq : (X : ℂ.Object) → (x : ℂ [ X , A ]) + → fmap (ℂ [ g ∘ f ]) X x ≡ T[ fmap g ∘ fmap f ]' X x + eqq X x = begin + fmap (ℂ [ g ∘ f ]) X x ≡⟨⟩ + ℂ [ ℂ [ g ∘ f ] ∘ x ] ≡⟨ sym ℂ.isAssociative ⟩ + ℂ [ g ∘ ℂ [ f ∘ x ] ] ≡⟨⟩ + ℂ [ g ∘ fmap f X x ] ≡⟨⟩ + T[ fmap g ∘ fmap f ]' X x ∎ + eq : fmap (ℂ [ g ∘ f ]) ≡ T[ fmap g ∘ fmap f ]' + eq = begin + fmap (ℂ [ g ∘ f ]) ≡⟨ funExt (λ X → funExt λ α → eqq X α) ⟩ + T[ fmap g ∘ fmap f ]' ∎ instance isFunctor : IsFunctor ℂ Fun rawYoneda From bb379fa19692d524bf043619c6b54577df3fbeec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 14:50:53 +0100 Subject: [PATCH 32/91] Implement category of presheaves --- src/Cat/Categories/Fun.agda | 32 +++++++++++++++++++------------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/src/Cat/Categories/Fun.agda b/src/Cat/Categories/Fun.agda index 2af9e55..de43087 100644 --- a/src/Cat/Categories/Fun.agda +++ b/src/Cat/Categories/Fun.agda @@ -62,9 +62,7 @@ module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : C _h⊕g_ = NT[_∘_] {B} {C} {D} :isAssociative: : L ≡ R :isAssociative: = lemSig (naturalIsProp {F = A} {D}) - L R (funExt (λ x → isAssociative)) - where - open Category 𝔻 + L R (funExt (λ x → 𝔻.isAssociative)) private module _ {A B : Functor ℂ 𝔻} {f : NaturalTransformation A B} where @@ -107,14 +105,22 @@ module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : C Category.raw Fun = RawFun module _ {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') where - open import Cat.Categories.Sets - open NaturalTransformation (opposite ℂ) (𝓢𝓮𝓽 ℓ') + private + open import Cat.Categories.Sets + open NaturalTransformation (opposite ℂ) (𝓢𝓮𝓽 ℓ') - -- Restrict the functors to Presheafs. - RawPresh : RawCategory (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ') - RawPresh = record - { Object = Presheaf ℂ - ; Arrow = NaturalTransformation - ; 𝟙 = λ {F} → identity F - ; _∘_ = λ {F G H} → NT[_∘_] {F = F} {G = G} {H = H} - } + -- Restrict the functors to Presheafs. + rawPresh : RawCategory (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ') + rawPresh = record + { Object = Presheaf ℂ + ; Arrow = NaturalTransformation + ; 𝟙 = λ {F} → identity F + ; _∘_ = λ {F G H} → NT[_∘_] {F = F} {G = G} {H = H} + } + instance + isCategory : IsCategory rawPresh + isCategory = Fun.:isCategory: _ _ + + Presh : Category (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ') + Category.raw Presh = rawPresh + Category.isCategory Presh = isCategory From 2b92cee254c831f1ee838ebb5958d8729e5cffe8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 14:53:32 +0100 Subject: [PATCH 33/91] Prettier names in Fun --- src/Cat/Categories/Fun.agda | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Cat/Categories/Fun.agda b/src/Cat/Categories/Fun.agda index de43087..70f75b7 100644 --- a/src/Cat/Categories/Fun.agda +++ b/src/Cat/Categories/Fun.agda @@ -45,9 +45,9 @@ module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : C (s≤s {n = Nat.suc Nat.zero} z≤n) (naturalIsProp θ) - module _ {A B C D : Functor ℂ 𝔻} {θ' : NaturalTransformation A B} - {η' : NaturalTransformation B C} {ζ' : NaturalTransformation C D} where - private + private + module _ {A B C D : Functor ℂ 𝔻} {θ' : NaturalTransformation A B} + {η' : NaturalTransformation B C} {ζ' : NaturalTransformation C D} where θ = proj₁ θ' η = proj₁ η' ζ = proj₁ ζ' @@ -58,11 +58,11 @@ module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : C L = (NT[_∘_] {A} {C} {D} ζ' (NT[_∘_] {A} {B} {C} η' θ')) R : NaturalTransformation A D R = (NT[_∘_] {A} {B} {D} (NT[_∘_] {B} {C} {D} ζ' η') θ') - _g⊕f_ = NT[_∘_] {A} {B} {C} - _h⊕g_ = NT[_∘_] {B} {C} {D} - :isAssociative: : L ≡ R - :isAssociative: = lemSig (naturalIsProp {F = A} {D}) - L R (funExt (λ x → 𝔻.isAssociative)) + _g⊕f_ = NT[_∘_] {A} {B} {C} + _h⊕g_ = NT[_∘_] {B} {C} {D} + isAssociative : L ≡ R + isAssociative = lemSig (naturalIsProp {F = A} {D}) + L R (funExt (λ x → 𝔻.isAssociative)) private module _ {A B : Functor ℂ 𝔻} {f : NaturalTransformation A B} where @@ -93,9 +93,9 @@ module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : C } instance - :isCategory: : IsCategory RawFun - :isCategory: = record - { isAssociative = λ {A B C D} → :isAssociative: {A} {B} {C} {D} + isCategory : IsCategory RawFun + isCategory = record + { isAssociative = λ {A B C D} → isAssociative {A} {B} {C} {D} ; isIdentity = λ {A B} → isIdentity {A} {B} ; arrowsAreSets = λ {F} {G} → naturalTransformationIsSets {F} {G} ; univalent = {!!} @@ -119,7 +119,7 @@ module _ {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') where } instance isCategory : IsCategory rawPresh - isCategory = Fun.:isCategory: _ _ + isCategory = Fun.isCategory _ _ Presh : Category (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ') Category.raw Presh = rawPresh From ddd5f17c05c7624c956e9cfa4645cee4b0242935 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 15:02:36 +0100 Subject: [PATCH 34/91] Move propositionality stuff about natural transformations to that module --- src/Cat/Categories/Fun.agda | 29 +-------------------- src/Cat/Category/NaturalTransformation.agda | 24 +++++++++++++++++ 2 files changed, 25 insertions(+), 28 deletions(-) diff --git a/src/Cat/Categories/Fun.agda b/src/Cat/Categories/Fun.agda index 70f75b7..9c1b380 100644 --- a/src/Cat/Categories/Fun.agda +++ b/src/Cat/Categories/Fun.agda @@ -4,47 +4,20 @@ module Cat.Categories.Fun where open import Agda.Primitive open import Data.Product -open import Data.Nat using (_≤_ ; z≤n ; s≤s) -module Nat = Data.Nat -open import Data.Product open import Cubical -open import Cubical.Sigma open import Cubical.NType.Properties open import Cat.Category open import Cat.Category.Functor hiding (identity) open import Cat.Category.NaturalTransformation -open import Cat.Wishlist - -open import Cat.Equality -import Cat.Category.NaturalTransformation -open Equality.Data.Product module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where open Category using (Object ; 𝟙) module NT = NaturalTransformation ℂ 𝔻 open NT public - private module 𝔻 = Category 𝔻 - - module _ {F G : Functor ℂ 𝔻} where - transformationIsSet : isSet (Transformation F G) - transformationIsSet _ _ p q i j C = 𝔻.arrowsAreSets _ _ (λ l → p l C) (λ l → q l C) i j - - naturalIsProp : (θ : Transformation F G) → isProp (Natural F G θ) - naturalIsProp θ θNat θNat' = lem - where - lem : (λ _ → Natural F G θ) [ (λ f → θNat f) ≡ (λ f → θNat' f) ] - lem = λ i f → 𝔻.arrowsAreSets _ _ (θNat f) (θNat' f) i - - naturalTransformationIsSets : isSet (NaturalTransformation F G) - naturalTransformationIsSets = sigPresSet transformationIsSet - λ θ → ntypeCommulative - (s≤s {n = Nat.suc Nat.zero} z≤n) - (naturalIsProp θ) - private module _ {A B C D : Functor ℂ 𝔻} {θ' : NaturalTransformation A B} {η' : NaturalTransformation B C} {ζ' : NaturalTransformation C D} where @@ -97,7 +70,7 @@ module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : C isCategory = record { isAssociative = λ {A B C D} → isAssociative {A} {B} {C} {D} ; isIdentity = λ {A B} → isIdentity {A} {B} - ; arrowsAreSets = λ {F} {G} → naturalTransformationIsSets {F} {G} + ; arrowsAreSets = λ {F} {G} → naturalTransformationIsSet {F} {G} ; univalent = {!!} } diff --git a/src/Cat/Category/NaturalTransformation.agda b/src/Cat/Category/NaturalTransformation.agda index f9ac434..a7b55a2 100644 --- a/src/Cat/Category/NaturalTransformation.agda +++ b/src/Cat/Category/NaturalTransformation.agda @@ -21,12 +21,16 @@ module Cat.Category.NaturalTransformation where open import Agda.Primitive open import Data.Product +open import Data.Nat using (_≤_ ; z≤n ; s≤s) +module Nat = Data.Nat open import Cubical +open import Cubical.Sigma open import Cubical.NType.Properties open import Cat.Category open import Cat.Category.Functor hiding (identity) +open import Cat.Wishlist module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where @@ -96,3 +100,23 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} 𝔻 [ H.func→ f ∘ T[ θ ∘ η ] A ] ∎ where open Category 𝔻 + + module _ {F G : Functor ℂ 𝔻} where + private + open Category using (Object ; 𝟙) + module 𝔻 = Category 𝔻 + + transformationIsSet : isSet (Transformation F G) + transformationIsSet _ _ p q i j C = 𝔻.arrowsAreSets _ _ (λ l → p l C) (λ l → q l C) i j + + naturalIsProp : (θ : Transformation F G) → isProp (Natural F G θ) + naturalIsProp θ θNat θNat' = lem + where + lem : (λ _ → Natural F G θ) [ (λ f → θNat f) ≡ (λ f → θNat' f) ] + lem = λ i f → 𝔻.arrowsAreSets _ _ (θNat f) (θNat' f) i + + naturalTransformationIsSet : isSet (NaturalTransformation F G) + naturalTransformationIsSet = sigPresSet transformationIsSet + λ θ → ntypeCommulative + (s≤s {n = Nat.suc Nat.zero} z≤n) + (naturalIsProp θ) From b26ea182579e002b9a1d35b606996b42fe567c1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 15:04:16 +0100 Subject: [PATCH 35/91] Cleanup in nattrans --- src/Cat/Category/NaturalTransformation.agda | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Cat/Category/NaturalTransformation.agda b/src/Cat/Category/NaturalTransformation.agda index a7b55a2..12df9ea 100644 --- a/src/Cat/Category/NaturalTransformation.agda +++ b/src/Cat/Category/NaturalTransformation.agda @@ -34,7 +34,11 @@ open import Cat.Wishlist module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where + open Category using (Object ; 𝟙) + private + module ℂ = Category ℂ + module 𝔻 = Category 𝔻 module _ (F G : Functor ℂ 𝔻) where private @@ -74,7 +78,6 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} where module F = Functor F F→ = F.func→ - module 𝔻 = Category 𝔻 identity : (F : Functor ℂ 𝔻) → NaturalTransformation F F identity F = identityTrans F , identityNatural F @@ -91,21 +94,15 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} proj₁ NT[ (θ , _) ∘ (η , _) ] = T[ θ ∘ η ] proj₂ NT[ (θ , θNat) ∘ (η , ηNat) ] {A} {B} f = begin 𝔻 [ T[ θ ∘ η ] B ∘ F.func→ f ] ≡⟨⟩ - 𝔻 [ 𝔻 [ θ B ∘ η B ] ∘ F.func→ f ] ≡⟨ sym isAssociative ⟩ + 𝔻 [ 𝔻 [ θ B ∘ η B ] ∘ F.func→ f ] ≡⟨ sym 𝔻.isAssociative ⟩ 𝔻 [ θ B ∘ 𝔻 [ η B ∘ F.func→ f ] ] ≡⟨ cong (λ φ → 𝔻 [ θ B ∘ φ ]) (ηNat f) ⟩ - 𝔻 [ θ B ∘ 𝔻 [ G.func→ f ∘ η A ] ] ≡⟨ isAssociative ⟩ + 𝔻 [ θ B ∘ 𝔻 [ G.func→ f ∘ η A ] ] ≡⟨ 𝔻.isAssociative ⟩ 𝔻 [ 𝔻 [ θ B ∘ G.func→ f ] ∘ η A ] ≡⟨ cong (λ φ → 𝔻 [ φ ∘ η A ]) (θNat f) ⟩ - 𝔻 [ 𝔻 [ H.func→ f ∘ θ A ] ∘ η A ] ≡⟨ sym isAssociative ⟩ + 𝔻 [ 𝔻 [ H.func→ f ∘ θ A ] ∘ η A ] ≡⟨ sym 𝔻.isAssociative ⟩ 𝔻 [ H.func→ f ∘ 𝔻 [ θ A ∘ η A ] ] ≡⟨⟩ 𝔻 [ H.func→ f ∘ T[ θ ∘ η ] A ] ∎ - where - open Category 𝔻 module _ {F G : Functor ℂ 𝔻} where - private - open Category using (Object ; 𝟙) - module 𝔻 = Category 𝔻 - transformationIsSet : isSet (Transformation F G) transformationIsSet _ _ p q i j C = 𝔻.arrowsAreSets _ _ (λ l → p l C) (λ l → q l C) i j From 7f4a8a65b8b92acfe6725b0118cd39c88a58d35a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 16:10:27 +0100 Subject: [PATCH 36/91] More stuff about opposite being an involution --- src/Cat/Category.agda | 45 ++++++++++++++++++++++++++++++------------- 1 file changed, 32 insertions(+), 13 deletions(-) diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index d66811d..669a811 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -155,7 +155,7 @@ module Univalence {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where -- record IsCategory {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) : Set (lsuc (ℓa ⊔ ℓb)) where open RawCategory ℂ public - open Univalence ℂ public + open Univalence ℂ public field isAssociative : IsAssociative isIdentity : IsIdentity 𝟙 @@ -301,23 +301,42 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- flipped. module Opposite {ℓa ℓb : Level} where module _ (ℂ : Category ℓa ℓb) where - open Category ℂ private + module ℂ = Category ℂ opRaw : RawCategory ℓa ℓb - RawCategory.Object opRaw = Object - RawCategory.Arrow opRaw = Function.flip Arrow - RawCategory.𝟙 opRaw = 𝟙 - RawCategory._∘_ opRaw = Function.flip _∘_ + RawCategory.Object opRaw = ℂ.Object + RawCategory.Arrow opRaw = Function.flip ℂ.Arrow + RawCategory.𝟙 opRaw = ℂ.𝟙 + RawCategory._∘_ opRaw = Function.flip ℂ._∘_ - opIsCategory : IsCategory opRaw - IsCategory.isAssociative opIsCategory = sym isAssociative - IsCategory.isIdentity opIsCategory = swap isIdentity - IsCategory.arrowsAreSets opIsCategory = arrowsAreSets - IsCategory.univalent opIsCategory = {!!} + open RawCategory opRaw + open Univalence opRaw + + isIdentity : IsIdentity 𝟙 + isIdentity = swap ℂ.isIdentity + + module _ {A B : ℂ.Object} where + univalent : isEquiv (A ≡ B) (A ≅ B) + (id-to-iso (swap ℂ.isIdentity) A B) + fst (univalent iso) = flipFiber (fst (ℂ.univalent (flipIso iso))) + where + flipIso : A ≅ B → B ℂ.≅ A + flipIso (f , f~ , iso) = f , f~ , swap iso + flipFiber + : fiber (ℂ.id-to-iso ℂ.isIdentity B A) (flipIso iso) + → fiber ( id-to-iso isIdentity A B) iso + flipFiber (eq , eqIso) = sym eq , {!!} + snd (univalent iso) = {!!} + + isCategory : IsCategory opRaw + IsCategory.isAssociative isCategory = sym ℂ.isAssociative + IsCategory.isIdentity isCategory = isIdentity + IsCategory.arrowsAreSets isCategory = ℂ.arrowsAreSets + IsCategory.univalent isCategory = univalent opposite : Category ℓa ℓb - raw opposite = opRaw - Category.isCategory opposite = opIsCategory + Category.raw opposite = opRaw + Category.isCategory opposite = isCategory -- As demonstrated here a side-effect of having no-eta-equality on constructors -- means that we need to pick things apart to show that things are indeed From 3151fb3e46b8e04c0294f887af6ea43d09fc0867 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 16:35:47 +0100 Subject: [PATCH 37/91] Prove propositionality for naturality --- src/Cat/Category/NaturalTransformation.agda | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Cat/Category/NaturalTransformation.agda b/src/Cat/Category/NaturalTransformation.agda index 12df9ea..525933a 100644 --- a/src/Cat/Category/NaturalTransformation.agda +++ b/src/Cat/Category/NaturalTransformation.agda @@ -58,7 +58,8 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} NaturalTransformation = Σ Transformation Natural -- Think I need propPi and that arrows are sets - postulate propIsNatural : (θ : _) → isProp (Natural θ) + propIsNatural : (θ : _) → isProp (Natural θ) + propIsNatural θ x y i {A} {B} f = 𝔻.arrowsAreSets _ _ (x f) (y f) i NaturalTransformation≡ : {α β : NaturalTransformation} → (eq₁ : α .proj₁ ≡ β .proj₁) From 9ec6ce9eba01ca646eee85144ef35f357cd4afb9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 17:10:41 +0100 Subject: [PATCH 38/91] Use other equality principle --- src/Cat/Categories/Cat.agda | 16 +++++----------- src/Cat/Category/Functor.agda | 19 ++----------------- src/Cat/Category/Monad.agda | 20 ++++++++++++-------- 3 files changed, 19 insertions(+), 36 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 2bed7c2..ce493b6 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -25,14 +25,14 @@ module _ (ℓ ℓ' : Level) where private module _ {𝔸 𝔹 ℂ 𝔻 : Category ℓ ℓ'} {F : Functor 𝔸 𝔹} {G : Functor 𝔹 ℂ} {H : Functor ℂ 𝔻} where assc : F[ H ∘ F[ G ∘ F ] ] ≡ F[ F[ H ∘ G ] ∘ F ] - assc = Functor≡ refl refl + assc = Functor≡ refl module _ {ℂ 𝔻 : Category ℓ ℓ'} {F : Functor ℂ 𝔻} where ident-r : F[ F ∘ identity ] ≡ F - ident-r = Functor≡ refl refl + ident-r = Functor≡ refl ident-l : F[ identity ∘ F ] ≡ F - ident-l = Functor≡ refl refl + ident-l = Functor≡ refl RawCat : RawCategory (lsuc (ℓ ⊔ ℓ')) (ℓ ⊔ ℓ') RawCat = @@ -133,16 +133,10 @@ module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where open module x₂ = Functor x₂ isUniqL : F[ proj₁ ∘ x ] ≡ x₁ - isUniqL = Functor≡ eq* eq→ - where - eq* : (F[ proj₁ ∘ x ]) .func* ≡ x₁ .func* - eq* = refl - eq→ : (λ i → {A : Object X} {B : Object X} → X [ A , B ] → ℂ [ eq* i A , eq* i B ]) - [ (F[ proj₁ ∘ x ]) .func→ ≡ x₁ .func→ ] - eq→ = refl + isUniqL = Functor≡ refl isUniqR : F[ proj₂ ∘ x ] ≡ x₂ - isUniqR = Functor≡ refl refl + isUniqR = Functor≡ refl isUniq : F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂ isUniq = isUniqL , isUniqR diff --git a/src/Cat/Category/Functor.agda b/src/Cat/Category/Functor.agda index 08400ea..e9a28fc 100644 --- a/src/Cat/Category/Functor.agda +++ b/src/Cat/Category/Functor.agda @@ -112,25 +112,10 @@ module _ module _ {ℓ ℓ' : Level} {ℂ 𝔻 : Category ℓ ℓ'} where Functor≡ : {F G : Functor ℂ 𝔻} - → (eq* : func* F ≡ func* G) - → (eq→ : (λ i → ∀ {x y} → ℂ [ x , y ] → 𝔻 [ eq* i x , eq* i y ]) - [ func→ F ≡ func→ G ]) - → F ≡ G - Functor≡ {F} {G} eq* eq→ i = record - { raw = eqR i - ; isFunctor = eqIsF i - } - where - eqR : raw F ≡ raw G - eqR i = record { func* = eq* i ; func→ = eq→ i } - eqIsF : (λ i → IsFunctor ℂ 𝔻 (eqR i)) [ isFunctor F ≡ isFunctor G ] - eqIsF = IsFunctorIsProp' (isFunctor F) (isFunctor G) - - FunctorEq : {F G : Functor ℂ 𝔻} → raw F ≡ raw G → F ≡ G - raw (FunctorEq eq i) = eq i - isFunctor (FunctorEq {F} {G} eq i) + raw (Functor≡ eq i) = eq i + isFunctor (Functor≡ {F} {G} eq i) = res i where res : (λ i → IsFunctor ℂ 𝔻 (eq i)) [ isFunctor F ≡ isFunctor G ] diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 8ba97df..151d27c 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -6,7 +6,7 @@ open import Agda.Primitive open import Data.Product open import Cubical -open import Cubical.NType.Properties using (lemPropF) +open import Cubical.NType.Properties using (lemPropF ; lemSig) open import Cat.Category open import Cat.Category.Functor as F @@ -537,8 +537,12 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where rawEq→ : P (RawFunctor.func* right) refl (RawFunctor.func→ right) -- rawEq→ : (fmap' : Fmap ℂ ℂ {!!}) → RawFunctor.func→ left ≡ fmap' rawEq→ = begin - (λ {A} {B} → RawFunctor.func→ left) ≡⟨ {!!} ⟩ - (λ {A} {B} → RawFunctor.func→ right) ∎ + (λ f → RawFunctor.func→ left f) ≡⟨⟩ + (λ f → KM.fmap f) ≡⟨⟩ + (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ + (λ f → RawFunctor.func→ right f) ∎ + where + module KM = K.Monad (forth m) -- destfmap = source = (Functor.raw (K.Monad.R (forth m))) -- p : (fmap' : Fmap ℂ ℂ (RawFunctor.func* source)) → (λ i → Fmap ℂ ℂ (refl i)) [ func→ source ≡ fmap' ] @@ -546,16 +550,16 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where rawEq : Functor.raw (K.Monad.R (forth m)) ≡ Functor.raw R rawEq = RawFunctor≡ ℂ ℂ {x = left} {right} refl λ fmap' → {!rawEq→!} Req : M.RawMonad.R (backRaw (forth m)) ≡ R - Req = FunctorEq rawEq + Req = Functor≡ rawEq - ηeq : M.RawMonad.η (backRaw (forth m)) ≡ η - ηeq = {!!} - postulate ηNatTransEq : {!!} [ M.RawMonad.ηNatTrans (backRaw (forth m)) ≡ ηNatTrans ] open NaturalTransformation ℂ ℂ + postulate + ηNatTransEq : (λ i → NaturalTransformation F.identity (Req i)) + [ M.RawMonad.ηNatTrans (backRaw (forth m)) ≡ ηNatTrans ] backRawEq : backRaw (forth m) ≡ M.Monad.raw m -- stuck M.RawMonad.R (backRawEq i) = Req i - M.RawMonad.ηNatTrans (backRawEq i) = let t = NaturalTransformation≡ F.identity R ηeq in {!t i!} + M.RawMonad.ηNatTrans (backRawEq i) = {!!} -- ηNatTransEq i M.RawMonad.μNatTrans (backRawEq i) = {!!} backeq : (m : M.Monad) → back (forth m) ≡ m From f8e08288a0219d1e3a345c8c6832bb9917bc2c54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 5 Mar 2018 17:31:13 +0100 Subject: [PATCH 39/91] Cosmetics --- src/Cat/Category/Monad.agda | 35 +++++++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 151d27c..dadcb0e 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -523,6 +523,8 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module _ (m : M.Monad) where open M.RawMonad (M.Monad.raw m) + Romap = Functor.func* R + Rfmap = Functor.func→ R rawEq* : Functor.func* (K.Monad.R (forth m)) ≡ Functor.func* R rawEq* = refl left = Functor.raw (K.Monad.R (forth m)) @@ -533,22 +535,35 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where → Set _ P _ eq fmap' = (λ i → Fmap ℂ ℂ (eq i)) [ RawFunctor.func→ left ≡ fmap' ] - -- rawEq→ : (λ i → Fmap ℂ ℂ (refl i)) [ Functor.func→ (K.Monad.R (forth m)) ≡ Functor.func→ R ] - rawEq→ : P (RawFunctor.func* right) refl (RawFunctor.func→ right) - -- rawEq→ : (fmap' : Fmap ℂ ℂ {!!}) → RawFunctor.func→ left ≡ fmap' + + module KM = K.Monad (forth m) + rawEq→ : (λ i → Fmap ℂ ℂ (refl i)) [ Functor.func→ (K.Monad.R (forth m)) ≡ Functor.func→ R ] + -- aka: + -- + -- rawEq→ : P (RawFunctor.func* right) refl (RawFunctor.func→ right) rawEq→ = begin (λ f → RawFunctor.func→ left f) ≡⟨⟩ (λ f → KM.fmap f) ≡⟨⟩ (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ + (λ f → Rfmap f) ≡⟨⟩ (λ f → RawFunctor.func→ right f) ∎ - where - module KM = K.Monad (forth m) - -- destfmap = - source = (Functor.raw (K.Monad.R (forth m))) - -- p : (fmap' : Fmap ℂ ℂ (RawFunctor.func* source)) → (λ i → Fmap ℂ ℂ (refl i)) [ func→ source ≡ fmap' ] - -- p = {!!} + + -- This goal is more general than the above goal which I also don't know + -- how to close. + p : (fmap' : Fmap ℂ ℂ (RawFunctor.func* left)) + → (λ i → Fmap ℂ ℂ Romap) [ RawFunctor.func→ left ≡ fmap' ] + -- aka: + -- + -- p : P (RawFunctor.func* left) refl + p fmap' = begin + (λ f → RawFunctor.func→ left f) ≡⟨⟩ + (λ f → KM.fmap f) ≡⟨⟩ + (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ + (λ f → fmap' f) ∎ + rawEq : Functor.raw (K.Monad.R (forth m)) ≡ Functor.raw R - rawEq = RawFunctor≡ ℂ ℂ {x = left} {right} refl λ fmap' → {!rawEq→!} + rawEq = RawFunctor≡ ℂ ℂ {x = left} {right} (λ _ → Romap) p + Req : M.RawMonad.R (backRaw (forth m)) ≡ R Req = Functor≡ rawEq From 35419ad86eac83d0d1d0fe350f3b710739b6bd23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 09:30:41 +0100 Subject: [PATCH 40/91] Rename eta and mu --- src/Cat/Category/Monad.agda | 140 ++++++++++++++++++------------------ 1 file changed, 69 insertions(+), 71 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index dadcb0e..80adece 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -25,34 +25,32 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- TODO rename fields here -- R ~ m R : EndoFunctor ℂ - -- η ~ pure - ηNatTrans : NaturalTransformation F.identity R - -- μ ~ join - μNatTrans : NaturalTransformation F[ R ∘ R ] R + pureNT : NaturalTransformation F.identity R + joinNT : NaturalTransformation F[ R ∘ R ] R - η : Transformation F.identity R - η = proj₁ ηNatTrans - ηNat : Natural F.identity R η - ηNat = proj₂ ηNatTrans + pureT : Transformation F.identity R + pureT = proj₁ pureNT + pureN : Natural F.identity R pureT + pureN = proj₂ pureNT - μ : Transformation F[ R ∘ R ] R - μ = proj₁ μNatTrans - μNat : Natural F[ R ∘ R ] R μ - μNat = proj₂ μNatTrans + joinT : Transformation F[ R ∘ R ] R + joinT = proj₁ joinNT + joinN : Natural F[ R ∘ R ] R joinT + joinN = proj₂ joinNT private module R = Functor R IsAssociative : Set _ 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 = {X : Object} - → μ X ∘ η (R.func* X) ≡ 𝟙 - × μ X ∘ R.func→ (η X) ≡ 𝟙 - IsNatural = ∀ {X Y} f → μ Y ∘ R.func→ f ∘ η X ≡ f + → joinT X ∘ pureT (R.func* X) ≡ 𝟙 + × joinT X ∘ R.func→ (pureT X) ≡ 𝟙 + 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)) - → μ Z ∘ R.func→ g ∘ (μ Y ∘ R.func→ f) - ≡ μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) + → joinT Z ∘ R.func→ g ∘ (joinT Y ∘ R.func→ f) + ≡ joinT Z ∘ R.func→ (joinT Z ∘ R.func→ g ∘ f) record IsMonad (raw : RawMonad) : Set ℓ where open RawMonad raw public @@ -66,10 +64,10 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isNatural : IsNatural isNatural {X} {Y} f = begin - μ Y ∘ R.func→ f ∘ η X ≡⟨ sym ℂ.isAssociative ⟩ - μ Y ∘ (R.func→ f ∘ η X) ≡⟨ cong (λ φ → μ Y ∘ φ) (sym (ηNat f)) ⟩ - μ Y ∘ (η (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ - μ Y ∘ η (R.func* Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ + joinT Y ∘ R.func→ f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩ + joinT Y ∘ (R.func→ f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩ + joinT Y ∘ (pureT (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ + joinT Y ∘ pureT (R.func* Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ f ∎ @@ -98,33 +96,33 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where a ∘ b ∘ c ∘ d ∎ where 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 - lem4 : μ (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ μ Y - lem4 = μNat g + lem4 : joinT (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ joinT Y + lem4 = joinN g done = begin - μ Z ∘ R.func→ (μ Z ∘ R.func→ g ∘ f) - ≡⟨ cong (λ φ → μ Z ∘ φ) distrib ⟩ - μ Z ∘ (R.func→ (μ Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) + joinT Z ∘ R.func→ (joinT Z ∘ R.func→ g ∘ f) + ≡⟨ cong (λ φ → joinT Z ∘ φ) distrib ⟩ + joinT Z ∘ (R.func→ (joinT Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) ≡⟨⟩ - μ Z ∘ (R.func→ (μ Z) ∘ R².func→ g ∘ R.func→ f) - ≡⟨ cong (_∘_ (μ 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) + ≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩ -- ●-solver? + joinT Z ∘ (R.func→ (joinT Z) ∘ (R².func→ g ∘ R.func→ f)) ≡⟨ ℂ.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 ⟩ - (μ Z ∘ μ (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) + (joinT Z ∘ joinT (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ ℂ.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 - ((μ 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) ⟩ - (μ Z ∘ (μ (R.func* Z) ∘ R².func→ g)) ∘ R.func→ f - ≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (μ Z)) lem4) ⟩ - (μ Z ∘ (R.func→ g ∘ μ Y)) ∘ R.func→ f ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩ - μ Z ∘ R.func→ g ∘ μ Y ∘ R.func→ f + (joinT Z ∘ (joinT (R.func* Z) ∘ R².func→ g)) ∘ R.func→ f + ≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (joinT Z)) lem4) ⟩ + (joinT Z ∘ (R.func→ g ∘ joinT Y)) ∘ R.func→ f ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩ + joinT Z ∘ R.func→ g ∘ joinT Y ∘ R.func→ f ≡⟨ 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 @@ -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² - η : Transformation R⁰ R - η A = pure - ηNatural : Natural R⁰ R η - ηNatural {A} {B} f = begin - η B ∘ R⁰.func→ f ≡⟨⟩ + pureT : Transformation R⁰ R + pureT A = pure + pureTNatural : Natural R⁰ R pureT + pureTNatural {A} {B} f = begin + pureT B ∘ R⁰.func→ f ≡⟨⟩ pure ∘ f ≡⟨ sym (isNatural _) ⟩ bind (pure ∘ f) ∘ pure ≡⟨⟩ fmap f ∘ pure ≡⟨⟩ - R.func→ f ∘ η A ∎ - μ : Transformation R² R - μ C = join - μNatural : Natural R² R μ - μNatural f = begin + R.func→ f ∘ pureT A ∎ + joinT : Transformation R² R + joinT C = join + joinTNatural : Natural R² R joinT + joinTNatural f = begin join ∘ R².func→ f ≡⟨⟩ bind 𝟙 ∘ R².func→ f ≡⟨⟩ R².func→ f >>> bind 𝟙 ≡⟨⟩ @@ -319,13 +317,13 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where R.func→ f ∘ join ∎ where - ηNatTrans : NaturalTransformation R⁰ R - proj₁ ηNatTrans = η - proj₂ ηNatTrans = ηNatural + pureNT : NaturalTransformation R⁰ R + proj₁ pureNT = pureT + proj₂ pureNT = pureTNatural - μNatTrans : NaturalTransformation R² R - proj₁ μNatTrans = μ - proj₂ μNatTrans = μNatural + joinNT : NaturalTransformation R² R + proj₁ joinNT = joinT + proj₂ joinNT = joinTNatural isNaturalForeign : IsNaturalForeign isNaturalForeign = begin @@ -421,10 +419,10 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where RR = func* R 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} f = μ Y ∘ func→ R f + bind {X} {Y} f = joinT Y ∘ func→ R f forthRaw : K.RawMonad Kraw.RR forthRaw = RR @@ -452,8 +450,8 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where backRaw : M.RawMonad MR.R backRaw = R - MR.ηNatTrans backRaw = ηNatTrans - MR.μNatTrans backRaw = μNatTrans + MR.pureNT backRaw = pureNT + MR.joinNT backRaw = joinNT private open MR backRaw @@ -461,19 +459,19 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where backIsMonad : M.IsMonad backRaw MI.isAssociative backIsMonad {X} = begin - μ X ∘ R.func→ (μ X) ≡⟨⟩ - join ∘ fmap (μ X) ≡⟨⟩ + joinT X ∘ R.func→ (joinT X) ≡⟨⟩ + join ∘ fmap (joinT X) ≡⟨⟩ join ∘ fmap join ≡⟨ isNaturalForeign ⟩ join ∘ join ≡⟨⟩ - μ X ∘ μ (R.func* X) ∎ + joinT X ∘ joinT (R.func* X) ∎ MI.isInverse backIsMonad {X} = inv-l , inv-r where inv-l = begin - μ X ∘ η (R.func* X) ≡⟨⟩ + joinT X ∘ pureT (R.func* X) ≡⟨⟩ join ∘ pure ≡⟨ proj₁ isInverse ⟩ 𝟙 ∎ inv-r = begin - μ X ∘ R.func→ (η X) ≡⟨⟩ + joinT X ∘ R.func→ (pureT X) ≡⟨⟩ join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩ 𝟙 ∎ @@ -490,13 +488,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where ≡ K.RawMonad.bind (K.Monad.raw m) bindEq {X} {Y} = begin K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩ - (λ f → μ Y ∘ func→ R f) ≡⟨⟩ + (λ f → joinT Y ∘ func→ R f) ≡⟨⟩ (λ f → join ∘ fmap f) ≡⟨⟩ (λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩ (λ f → bind f) ≡⟨⟩ bind ∎ where - μ = proj₁ μNatTrans + joinT = proj₁ joinNT lem : (f : Arrow X (RR Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f lem f = begin bind (f >>> pure) >>> bind 𝟙 @@ -569,13 +567,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open NaturalTransformation ℂ ℂ postulate - ηNatTransEq : (λ i → NaturalTransformation F.identity (Req i)) - [ M.RawMonad.ηNatTrans (backRaw (forth m)) ≡ ηNatTrans ] + pureNTEq : (λ i → NaturalTransformation F.identity (Req i)) + [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] backRawEq : backRaw (forth m) ≡ M.Monad.raw m -- stuck M.RawMonad.R (backRawEq i) = Req i - M.RawMonad.ηNatTrans (backRawEq i) = {!!} -- ηNatTransEq i - M.RawMonad.μNatTrans (backRawEq i) = {!!} + M.RawMonad.pureNT (backRawEq i) = {!!} -- pureNTEq i + M.RawMonad.joinNT (backRawEq i) = {!!} backeq : (m : M.Monad) → back (forth m) ≡ m backeq m = M.Monad≡ (backRawEq m) From 7647a452cd984bb8c1511cabd04acfd5ec9752a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 09:39:48 +0100 Subject: [PATCH 41/91] Tidy up proof a bit --- src/Cat/Category/Monad.agda | 43 +++++++++++-------------------------- 1 file changed, 13 insertions(+), 30 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 80adece..701c986 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -72,54 +72,37 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where f ∎ isDistributive : IsDistributive - isDistributive {X} {Y} {Z} g f = sym done + isDistributive {X} {Y} {Z} g f = sym aux where module R² = Functor F[ R ∘ R ] - distrib : ∀ {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} → R.func→ (a ∘ b ∘ c) ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c - distrib {a = a} {b} {c} = begin - R.func→ (a ∘ b ∘ c) ≡⟨ distr ⟩ - R.func→ (a ∘ b) ∘ R.func→ c ≡⟨ cong (_∘ _) distr ⟩ + distrib3 {a = a} {b} {c} = begin + R.func→ (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩ + R.func→ (a ∘ b) ∘ R.func→ c ≡⟨ cong (_∘ _) R.isDistributive ⟩ R.func→ a ∘ R.func→ b ∘ R.func→ c ∎ - where - distr = R.isDistributive - comm : ∀ {A B C D E} - → {a : Arrow D E} {b : Arrow C D} {c : Arrow B C} {d : Arrow A B} - → a ∘ (b ∘ c ∘ d) ≡ a ∘ b ∘ c ∘ d - comm {a = a} {b} {c} {d} = begin - a ∘ (b ∘ c ∘ d) ≡⟨⟩ - a ∘ ((b ∘ c) ∘ d) ≡⟨ cong (_∘_ a) (sym asc) ⟩ - a ∘ (b ∘ (c ∘ d)) ≡⟨ asc ⟩ - (a ∘ b) ∘ (c ∘ d) ≡⟨ asc ⟩ - ((a ∘ b) ∘ c) ∘ d ≡⟨⟩ - a ∘ b ∘ c ∘ d ∎ - where - asc = ℂ.isAssociative - lemmm : joinT Z ∘ R.func→ (joinT Z) ≡ joinT Z ∘ joinT (R.func* Z) - lemmm = isAssociative - lem4 : joinT (R.func* Z) ∘ R².func→ g ≡ R.func→ g ∘ joinT Y - lem4 = joinN g - done = begin + aux = begin joinT Z ∘ R.func→ (joinT Z ∘ R.func→ g ∘ f) - ≡⟨ cong (λ φ → joinT Z ∘ φ) distrib ⟩ + ≡⟨ cong (λ φ → joinT Z ∘ φ) distrib3 ⟩ joinT Z ∘ (R.func→ (joinT Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) ≡⟨⟩ joinT Z ∘ (R.func→ (joinT Z) ∘ R².func→ g ∘ R.func→ f) - ≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩ -- ●-solver? + ≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩ joinT Z ∘ (R.func→ (joinT Z) ∘ (R².func→ g ∘ R.func→ f)) ≡⟨ ℂ.isAssociative ⟩ (joinT Z ∘ R.func→ (joinT Z)) ∘ (R².func→ g ∘ R.func→ f) ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) isAssociative ⟩ (joinT Z ∘ joinT (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) - ≡⟨ ℂ.isAssociative ⟩ -- ●-solver? + ≡⟨ ℂ.isAssociative ⟩ joinT Z ∘ joinT (R.func* Z) ∘ R².func→ g ∘ R.func→ f - ≡⟨⟩ -- ●-solver + lem4 + ≡⟨⟩ ((joinT Z ∘ joinT (R.func* Z)) ∘ R².func→ g) ∘ R.func→ f ≡⟨ cong (_∘ R.func→ f) (sym ℂ.isAssociative) ⟩ (joinT Z ∘ (joinT (R.func* Z) ∘ R².func→ g)) ∘ R.func→ f - ≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (joinT Z)) lem4) ⟩ - (joinT Z ∘ (R.func→ g ∘ joinT Y)) ∘ R.func→ f ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩ + ≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (joinT Z)) (joinN g)) ⟩ + (joinT Z ∘ (R.func→ g ∘ joinT Y)) ∘ R.func→ f + ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩ joinT Z ∘ R.func→ g ∘ joinT Y ∘ R.func→ f ≡⟨ sym (Category.isAssociative ℂ) ⟩ joinT Z ∘ R.func→ g ∘ (joinT Y ∘ R.func→ f) From b6457a0b145a37b6e15365f921fcd65c5002284c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 09:41:29 +0100 Subject: [PATCH 42/91] Add comment --- src/Cat/Category/Monad.agda | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 701c986..674fd95 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -28,6 +28,8 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where pureNT : NaturalTransformation F.identity R joinNT : NaturalTransformation F[ R ∘ R ] R + -- Note that `pureT` and `joinT` differs from their definition in the + -- kleisli formulation only by having an explicit parameter. pureT : Transformation F.identity R pureT = proj₁ pureNT pureN : Natural F.identity R pureT From cfb7925cb5e973b21c1577b2d1d15928f0f846c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 09:45:04 +0100 Subject: [PATCH 43/91] Renaming --- src/Cat/Category/Monad.agda | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 674fd95..e853fc1 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -264,8 +264,8 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where module R² = Functor R² pureT : Transformation R⁰ R pureT A = pure - pureTNatural : Natural R⁰ R pureT - pureTNatural {A} {B} f = begin + pureN : Natural R⁰ R pureT + pureN {A} {B} f = begin pureT B ∘ R⁰.func→ f ≡⟨⟩ pure ∘ f ≡⟨ sym (isNatural _) ⟩ bind (pure ∘ f) ∘ pure ≡⟨⟩ @@ -273,8 +273,8 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where R.func→ f ∘ pureT A ∎ joinT : Transformation R² R joinT C = join - joinTNatural : Natural R² R joinT - joinTNatural f = begin + joinN : Natural R² R joinT + joinN f = begin join ∘ R².func→ f ≡⟨⟩ bind 𝟙 ∘ R².func→ f ≡⟨⟩ R².func→ f >>> bind 𝟙 ≡⟨⟩ @@ -304,11 +304,11 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where pureNT : NaturalTransformation R⁰ R proj₁ pureNT = pureT - proj₂ pureNT = pureTNatural + proj₂ pureNT = pureN joinNT : NaturalTransformation R² R proj₁ joinNT = joinT - proj₂ joinNT = joinTNatural + proj₂ joinNT = joinN isNaturalForeign : IsNaturalForeign isNaturalForeign = begin From c57cd5c991cf5db3a68cd45613d60cbccf2673f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 09:52:01 +0100 Subject: [PATCH 44/91] Define stuff in monoidal record --- src/Cat/Category/Monad.agda | 28 +++++++++++----------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index e853fc1..b0e6625 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -42,6 +42,13 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private module R = Functor R + + Romap = Functor.func* R + Rfmap = Functor.func→ R + + bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] + bind {X} {Y} f = joinT Y ∘ Rfmap f + IsAssociative : Set _ IsAssociative = {X : Object} → joinT X ∘ R.func→ (joinT X) ≡ joinT X ∘ joinT (R.func* X) @@ -396,23 +403,12 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where -- Note similarity with locally defined things in Kleisly.RawMonad!! module _ (m : M.RawMonad) where - private - open M.RawMonad m - module Kraw = K.RawMonad - - RR : Object → Object - RR = func* R - - pure : {X : Object} → ℂ [ X , RR X ] - pure {X} = pureT X - - bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] - bind {X} {Y} f = joinT Y ∘ func→ R f + open M.RawMonad m forthRaw : K.RawMonad - Kraw.RR forthRaw = RR - Kraw.pure forthRaw = pure - Kraw.bind forthRaw = bind + K.RawMonad.RR forthRaw = Romap + K.RawMonad.pure forthRaw = pureT _ + K.RawMonad.bind forthRaw = bind module _ {raw : M.RawMonad} (m : M.IsMonad raw) where private @@ -506,8 +502,6 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module _ (m : M.Monad) where open M.RawMonad (M.Monad.raw m) - Romap = Functor.func* R - Rfmap = Functor.func→ R rawEq* : Functor.func* (K.Monad.R (forth m)) ≡ Functor.func* R rawEq* = refl left = Functor.raw (K.Monad.R (forth m)) From bdd67aee53182672c2194cdea124e41a62ad332d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 09:55:18 +0100 Subject: [PATCH 45/91] Rename RR to Romap --- src/Cat/Category/Monad.agda | 38 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 20 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index b0e6625..c47a851 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -166,23 +166,23 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- are not generally types. record RawMonad : Set ℓ where field - RR : Object → Object + Romap : Object → Object -- Note name-change from [voe] - pure : {X : Object} → ℂ [ X , RR X ] - bind : {X Y : Object} → ℂ [ X , RR Y ] → ℂ [ RR X , RR Y ] + pure : {X : Object} → ℂ [ X , Romap X ] + bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] -- | functor map -- -- This should perhaps be defined in a "Klesli-version" of functors as well? - fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ RR A , RR B ] + fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ Romap A , Romap B ] fmap f = bind (pure ∘ f) -- | Composition of monads aka. the kleisli-arrow. - _>=>_ : {A B C : Object} → ℂ [ A , RR B ] → ℂ [ B , RR C ] → ℂ [ A , RR C ] + _>=>_ : {A B C : Object} → ℂ [ A , Romap B ] → ℂ [ B , Romap C ] → ℂ [ A , Romap C ] f >=> g = f >>> (bind g) -- | Flattening nested monads. - join : {A : Object} → ℂ [ RR (RR A) , RR A ] + join : {A : Object} → ℂ [ Romap (Romap A) , Romap A ] join = bind 𝟙 ------------------ @@ -192,10 +192,10 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- There may be better names than what I've chosen here. IsIdentity = {X : Object} - → bind pure ≡ 𝟙 {RR X} - IsNatural = {X Y : Object} (f : ℂ [ X , RR Y ]) + → bind pure ≡ 𝟙 {Romap X} + IsNatural = {X Y : Object} (f : ℂ [ X , Romap Y ]) → pure >>> (bind f) ≡ f - IsDistributive = {X Y Z : Object} (g : ℂ [ Y , RR Z ]) (f : ℂ [ X , RR Y ]) + IsDistributive = {X Y Z : Object} (g : ℂ [ Y , Romap Z ]) (f : ℂ [ X , Romap Y ]) → (bind f) >>> (bind g) ≡ bind (f >=> g) -- | Functor map fusion. @@ -239,7 +239,7 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- | This formulation gives rise to the following endo-functor. private rawR : RawFunctor ℂ ℂ - RawFunctor.func* rawR = RR + RawFunctor.func* rawR = Romap RawFunctor.func→ rawR = fmap isFunctorR : IsFunctor ℂ ℂ rawR @@ -399,25 +399,23 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open ℂ using (Object ; Arrow ; 𝟙 ; _∘_ ; _>>>_) open Functor using (func* ; func→) module M = Monoidal ℂ - module K = Kleisli ℂ + module K = Kleisli ℂ - -- Note similarity with locally defined things in Kleisly.RawMonad!! module _ (m : M.RawMonad) where open M.RawMonad m forthRaw : K.RawMonad - K.RawMonad.RR forthRaw = Romap + K.RawMonad.Romap forthRaw = Romap K.RawMonad.pure forthRaw = pureT _ K.RawMonad.bind forthRaw = bind module _ {raw : M.RawMonad} (m : M.IsMonad raw) where private module MI = M.IsMonad m - module KI = K.IsMonad forthIsMonad : K.IsMonad (forthRaw raw) - KI.isIdentity forthIsMonad = proj₂ MI.isInverse - KI.isNatural forthIsMonad = MI.isNatural - KI.isDistributive forthIsMonad = MI.isDistributive + K.IsMonad.isIdentity forthIsMonad = proj₂ MI.isInverse + K.IsMonad.isNatural forthIsMonad = MI.isNatural + K.IsMonad.isDistributive forthIsMonad = MI.isDistributive forth : M.Monad → K.Monad Kleisli.Monad.raw (forth m) = forthRaw (M.Monad.raw m) @@ -430,7 +428,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module MI = M.IsMonad backRaw : M.RawMonad - MR.R backRaw = R + MR.R backRaw = R MR.pureNT backRaw = pureNT MR.joinNT backRaw = joinNT @@ -476,7 +474,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where bind ∎ where joinT = proj₁ joinNT - lem : (f : Arrow X (RR Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f + lem : (f : Arrow X (Romap Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f lem f = begin bind (f >>> pure) >>> bind 𝟙 ≡⟨ isDistributive _ _ ⟩ @@ -492,7 +490,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where x & f = f x forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m - K.RawMonad.RR (forthRawEq _) = RR + K.RawMonad.Romap (forthRawEq _) = Romap K.RawMonad.pure (forthRawEq _) = pure -- stuck K.RawMonad.bind (forthRawEq i) = bindEq i From 9173468b03739037c158832e3655fd923a5f66dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 09:56:44 +0100 Subject: [PATCH 46/91] Use omap/fmap --- src/Cat/Category/Monad.agda | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index c47a851..7ad49e8 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -22,9 +22,7 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where open NaturalTransformation ℂ ℂ record RawMonad : Set ℓ where field - -- TODO rename fields here - -- R ~ m - R : EndoFunctor ℂ + R : EndoFunctor ℂ pureNT : NaturalTransformation F.identity R joinNT : NaturalTransformation F[ R ∘ R ] R @@ -40,9 +38,6 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where joinN : Natural F[ R ∘ R ] R joinT joinN = proj₂ joinNT - private - module R = Functor R - Romap = Functor.func* R Rfmap = Functor.func→ R @@ -51,15 +46,15 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where IsAssociative : Set _ IsAssociative = {X : Object} - → joinT X ∘ R.func→ (joinT X) ≡ joinT X ∘ joinT (R.func* X) + → joinT X ∘ Rfmap (joinT X) ≡ joinT X ∘ joinT (Romap X) IsInverse : Set _ IsInverse = {X : Object} - → joinT X ∘ pureT (R.func* X) ≡ 𝟙 - × joinT X ∘ R.func→ (pureT X) ≡ 𝟙 - 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)) - → joinT Z ∘ R.func→ g ∘ (joinT Y ∘ R.func→ f) - ≡ joinT Z ∘ R.func→ (joinT Z ∘ R.func→ g ∘ f) + → joinT X ∘ pureT (Romap X) ≡ 𝟙 + × joinT X ∘ Rfmap (pureT X) ≡ 𝟙 + IsNatural = ∀ {X Y} f → joinT Y ∘ Rfmap f ∘ pureT X ≡ f + IsDistributive = ∀ {X Y Z} (g : Arrow Y (Romap Z)) (f : Arrow X (Romap Y)) + → joinT Z ∘ Rfmap g ∘ (joinT Y ∘ Rfmap f) + ≡ joinT Z ∘ Rfmap (joinT Z ∘ Rfmap g ∘ f) record IsMonad (raw : RawMonad) : Set ℓ where open RawMonad raw public From 4de27aa06c45b9ab3336c66efa0cefec4bda127c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 10:05:35 +0100 Subject: [PATCH 47/91] Naming --- src/Cat/Category/Monad.agda | 51 ++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 26 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 7ad49e8..7387a37 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -114,7 +114,7 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where record Monad : Set ℓ where field - raw : RawMonad + raw : RawMonad isMonad : IsMonad raw open IsMonad isMonad public @@ -131,6 +131,7 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where yX = y {X} e1 = Category.arrowsAreSets ℂ _ _ (proj₁ xX) (proj₁ yX) e2 = Category.arrowsAreSets ℂ _ _ (proj₂ xX) (proj₂ yX) + open IsMonad propIsMonad : (raw : _) → isProp (IsMonad raw) IsMonad.isAssociative (propIsMonad raw a b i) j @@ -141,8 +142,9 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where (isInverse a) (isInverse b) i module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where - eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - eqIsMonad = lemPropF propIsMonad eq + private + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq Monad≡ : m ≡ n Monad.raw (Monad≡ i) = eq i @@ -161,23 +163,22 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- are not generally types. record RawMonad : Set ℓ where field - Romap : Object → Object - -- Note name-change from [voe] - pure : {X : Object} → ℂ [ X , Romap X ] - bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] + omap : Object → Object + pure : {X : Object} → ℂ [ X , omap X ] + bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] -- | functor map -- -- This should perhaps be defined in a "Klesli-version" of functors as well? - fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ Romap A , Romap B ] + fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ] fmap f = bind (pure ∘ f) -- | Composition of monads aka. the kleisli-arrow. - _>=>_ : {A B C : Object} → ℂ [ A , Romap B ] → ℂ [ B , Romap C ] → ℂ [ A , Romap C ] + _>=>_ : {A B C : Object} → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ] f >=> g = f >>> (bind g) -- | Flattening nested monads. - join : {A : Object} → ℂ [ Romap (Romap A) , Romap A ] + join : {A : Object} → ℂ [ omap (omap A) , omap A ] join = bind 𝟙 ------------------ @@ -187,10 +188,10 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- There may be better names than what I've chosen here. IsIdentity = {X : Object} - → bind pure ≡ 𝟙 {Romap X} - IsNatural = {X Y : Object} (f : ℂ [ X , Romap Y ]) + → bind pure ≡ 𝟙 {omap X} + IsNatural = {X Y : Object} (f : ℂ [ X , omap Y ]) → pure >>> (bind f) ≡ f - IsDistributive = {X Y Z : Object} (g : ℂ [ Y , Romap Z ]) (f : ℂ [ X , Romap Y ]) + IsDistributive = {X Y Z : Object} (g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ]) → (bind f) >>> (bind g) ≡ bind (f >=> g) -- | Functor map fusion. @@ -218,23 +219,22 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where fusion : Fusion fusion {g = g} {f} = begin fmap (g ∘ f) ≡⟨⟩ - bind ((f >>> g) >>> pure) ≡⟨ cong bind isAssociative ⟩ + bind ((f >>> g) >>> pure) ≡⟨ cong bind ℂ.isAssociative ⟩ 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 (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ - fmap g ∘ fmap f ∎ + bind ((fmap g ∘ pure) ∘ f) ≡⟨ cong bind (sym ℂ.isAssociative) ⟩ + bind (fmap g ∘ (pure ∘ f)) ≡⟨ sym distrib ⟩ + bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ + fmap g ∘ fmap f ∎ where - open Category ℂ using (isAssociative) - lem : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) - lem = isDistributive (pure ∘ g) (pure ∘ f) + distrib : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) + distrib = isDistributive (pure ∘ g) (pure ∘ f) -- | This formulation gives rise to the following endo-functor. private rawR : RawFunctor ℂ ℂ - RawFunctor.func* rawR = Romap + RawFunctor.func* rawR = omap RawFunctor.func→ rawR = fmap isFunctorR : IsFunctor ℂ ℂ rawR @@ -302,7 +302,6 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where bind 𝟙 >>> R.func→ f ≡⟨⟩ R.func→ f ∘ bind 𝟙 ≡⟨⟩ R.func→ f ∘ join ∎ - where pureNT : NaturalTransformation R⁰ R proj₁ pureNT = pureT @@ -400,7 +399,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open M.RawMonad m forthRaw : K.RawMonad - K.RawMonad.Romap forthRaw = Romap + K.RawMonad.omap forthRaw = Romap K.RawMonad.pure forthRaw = pureT _ K.RawMonad.bind forthRaw = bind @@ -469,7 +468,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where bind ∎ where joinT = proj₁ joinNT - lem : (f : Arrow X (Romap Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f + lem : (f : Arrow X (omap Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f lem f = begin bind (f >>> pure) >>> bind 𝟙 ≡⟨ isDistributive _ _ ⟩ @@ -485,7 +484,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where x & f = f x forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m - K.RawMonad.Romap (forthRawEq _) = Romap + K.RawMonad.omap (forthRawEq _) = omap K.RawMonad.pure (forthRawEq _) = pure -- stuck K.RawMonad.bind (forthRawEq i) = bindEq i From 0cebe1e866a78d5ca60371844b7f638c4ef58ce0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 10:06:45 +0100 Subject: [PATCH 48/91] Make private --- src/Cat/Category/Monad.agda | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 7387a37..aae96ee 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -377,8 +377,9 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where IsMonad.isDistributive (propIsMonad raw x y i) = propIsDistributive raw (isDistributive x) (isDistributive y) i module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where - eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - eqIsMonad = lemPropF propIsMonad eq + private + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq Monad≡ : m ≡ n Monad.raw (Monad≡ i) = eq i From 485703c85ec5a96fefee2ea6ed0b1134cd63a3ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 10:16:42 +0100 Subject: [PATCH 49/91] Tidy up --- src/Cat/Category/Monad.agda | 99 +++++++++++++++++-------------------- 1 file changed, 46 insertions(+), 53 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index aae96ee..11022b4 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -7,6 +7,7 @@ open import Data.Product open import Cubical open import Cubical.NType.Properties using (lemPropF ; lemSig) +open import Cubical.GradLemma using (gradLemma) open import Cat.Category open import Cat.Category.Functor as F @@ -357,25 +358,27 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isMonad : IsMonad raw open IsMonad isMonad public - module _ (raw : RawMonad) where - open RawMonad raw - propIsIdentity : isProp IsIdentity - propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i - propIsNatural : isProp IsNatural - propIsNatural x y i = λ f - → ℂ.arrowsAreSets _ _ (x f) (y f) i - propIsDistributive : isProp IsDistributive - propIsDistributive x y i = λ g f - → ℂ.arrowsAreSets _ _ (x g f) (y g f) i + private + module _ (raw : RawMonad) where + open RawMonad raw + propIsIdentity : isProp IsIdentity + propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i + propIsNatural : isProp IsNatural + propIsNatural x y i = λ f + → ℂ.arrowsAreSets _ _ (x f) (y f) i + propIsDistributive : isProp IsDistributive + propIsDistributive x y i = λ g f + → ℂ.arrowsAreSets _ _ (x g f) (y g f) i + + open IsMonad + propIsMonad : (raw : _) → isProp (IsMonad raw) + IsMonad.isIdentity (propIsMonad raw x y i) + = propIsIdentity raw (isIdentity x) (isIdentity y) i + IsMonad.isNatural (propIsMonad raw x y i) + = propIsNatural raw (isNatural x) (isNatural y) i + IsMonad.isDistributive (propIsMonad raw x y i) + = propIsDistributive raw (isDistributive x) (isDistributive y) i - open IsMonad - propIsMonad : (raw : _) → isProp (IsMonad raw) - IsMonad.isIdentity (propIsMonad raw x y i) - = propIsIdentity raw (isIdentity x) (isIdentity y) i - IsMonad.isNatural (propIsMonad raw x y i) - = propIsNatural raw (isNatural x) (isNatural y) i - IsMonad.isDistributive (propIsMonad raw x y i) - = propIsDistributive raw (isDistributive x) (isDistributive y) i module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where private eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] @@ -400,7 +403,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open M.RawMonad m forthRaw : K.RawMonad - K.RawMonad.omap forthRaw = Romap + K.RawMonad.omap forthRaw = Romap K.RawMonad.pure forthRaw = pureT _ K.RawMonad.bind forthRaw = bind @@ -413,63 +416,58 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where K.IsMonad.isDistributive forthIsMonad = MI.isDistributive forth : M.Monad → K.Monad - Kleisli.Monad.raw (forth m) = forthRaw (M.Monad.raw m) + Kleisli.Monad.raw (forth m) = forthRaw (M.Monad.raw m) Kleisli.Monad.isMonad (forth m) = forthIsMonad (M.Monad.isMonad m) module _ (m : K.Monad) where - private - open K.Monad m - module MR = M.RawMonad - module MI = M.IsMonad + open K.Monad m backRaw : M.RawMonad - MR.R backRaw = R - MR.pureNT backRaw = pureNT - MR.joinNT backRaw = joinNT + M.RawMonad.R backRaw = R + M.RawMonad.pureNT backRaw = pureNT + M.RawMonad.joinNT backRaw = joinNT private - open MR backRaw - module R = Functor (MR.R backRaw) + open M.RawMonad backRaw + module R = Functor (M.RawMonad.R backRaw) backIsMonad : M.IsMonad backRaw - MI.isAssociative backIsMonad {X} = begin + M.IsMonad.isAssociative backIsMonad {X} = begin joinT X ∘ R.func→ (joinT X) ≡⟨⟩ - join ∘ fmap (joinT X) ≡⟨⟩ - join ∘ fmap join ≡⟨ isNaturalForeign ⟩ - join ∘ join ≡⟨⟩ + join ∘ fmap (joinT X) ≡⟨⟩ + join ∘ fmap join ≡⟨ isNaturalForeign ⟩ + join ∘ join ≡⟨⟩ joinT X ∘ joinT (R.func* X) ∎ - MI.isInverse backIsMonad {X} = inv-l , inv-r + M.IsMonad.isInverse backIsMonad {X} = inv-l , inv-r where inv-l = begin joinT X ∘ pureT (R.func* X) ≡⟨⟩ - join ∘ pure ≡⟨ proj₁ isInverse ⟩ - 𝟙 ∎ + join ∘ pure ≡⟨ proj₁ isInverse ⟩ + 𝟙 ∎ inv-r = begin joinT X ∘ R.func→ (pureT X) ≡⟨⟩ - join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩ - 𝟙 ∎ + join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩ + 𝟙 ∎ back : K.Monad → M.Monad Monoidal.Monad.raw (back m) = backRaw m Monoidal.Monad.isMonad (back m) = backIsMonad m - -- I believe all the proofs here should be `refl`. module _ (m : K.Monad) where open K.Monad m - -- open K.RawMonad (K.Monad.raw m) bindEq : ∀ {X Y} → K.RawMonad.bind (forthRaw (backRaw m)) {X} {Y} ≡ K.RawMonad.bind (K.Monad.raw m) bindEq {X} {Y} = begin K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩ - (λ f → joinT Y ∘ func→ R f) ≡⟨⟩ - (λ f → join ∘ fmap f) ≡⟨⟩ - (λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩ - (λ f → bind f) ≡⟨⟩ - bind ∎ + (λ f → join ∘ fmap f) ≡⟨⟩ + (λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩ + (λ f → bind f) ≡⟨⟩ + bind ∎ where - joinT = proj₁ joinNT - lem : (f : Arrow X (omap Y)) → bind (f >>> pure) >>> bind 𝟙 ≡ bind f + lem : (f : Arrow X (omap Y)) + → bind (f >>> pure) >>> bind 𝟙 + ≡ bind f lem f = begin bind (f >>> pure) >>> bind 𝟙 ≡⟨ isDistributive _ _ ⟩ @@ -481,13 +479,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ bind f ∎ - _&_ : ∀ {ℓa ℓb} {A : Set ℓa} {B : Set ℓb} → A → (A → B) → B - x & f = f x - forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m K.RawMonad.omap (forthRawEq _) = omap K.RawMonad.pure (forthRawEq _) = pure - -- stuck K.RawMonad.bind (forthRawEq i) = bindEq i fortheq : (m : K.Monad) → forth (back m) ≡ m @@ -543,14 +537,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] backRawEq : backRaw (forth m) ≡ M.Monad.raw m -- stuck - M.RawMonad.R (backRawEq i) = Req i + M.RawMonad.R (backRawEq i) = Req i M.RawMonad.pureNT (backRawEq i) = {!!} -- pureNTEq i M.RawMonad.joinNT (backRawEq i) = {!!} backeq : (m : M.Monad) → back (forth m) ≡ m backeq m = M.Monad≡ (backRawEq m) - open import Cubical.GradLemma eqv : isEquiv M.Monad K.Monad forth eqv = gradLemma forth back fortheq backeq From 4d528a7077280f9e0fdfb7747013259d288d69e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 11:25:29 +0100 Subject: [PATCH 50/91] Clean-up --- src/Cat/Category/Monad.agda | 68 +++++++++++++++++++------------------ 1 file changed, 35 insertions(+), 33 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 11022b4..d900350 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -488,45 +488,47 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where fortheq m = K.Monad≡ (forthRawEq m) module _ (m : M.Monad) where - open M.RawMonad (M.Monad.raw m) - rawEq* : Functor.func* (K.Monad.R (forth m)) ≡ Functor.func* R - rawEq* = refl - left = Functor.raw (K.Monad.R (forth m)) - right = Functor.raw R - P : (omap : Omap ℂ ℂ) - → (eq : RawFunctor.func* left ≡ omap) - → (fmap' : Fmap ℂ ℂ omap) - → Set _ - P _ eq fmap' = (λ i → Fmap ℂ ℂ (eq i)) - [ RawFunctor.func→ left ≡ fmap' ] - + open M.RawMonad (M.Monad.raw m) using (R ; Romap ; Rfmap ; pureNT ; joinNT) module KM = K.Monad (forth m) - rawEq→ : (λ i → Fmap ℂ ℂ (refl i)) [ Functor.func→ (K.Monad.R (forth m)) ≡ Functor.func→ R ] - -- aka: + omapEq : KM.omap ≡ Romap + omapEq = refl + + D : (omap : Omap ℂ ℂ) → Romap ≡ omap → Set _ + D omap eq = (fmap' : Fmap ℂ ℂ omap) + → (λ i → Fmap ℂ ℂ (eq i)) + [ (λ f → KM.fmap f) ≡ fmap' ] + + -- The "base-case" for path induction on the family `D`. + d : D Romap λ _ → Romap + d = res + where + -- aka: + res + : (fmap : Fmap ℂ ℂ Romap) + → (λ _ → Fmap ℂ ℂ Romap) [ KM.fmap ≡ fmap ] + res fmap = begin + (λ f → KM.fmap f) ≡⟨⟩ + (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ + (λ f → fmap f) ∎ + + -- This is sort of equivalent to `d` though the the order of + -- quantification is different. `KM.fmap` is defined in terms of `Rfmap` + -- (via `forth`) whereas in `d` above `fmap` is universally quantified. -- - -- rawEq→ : P (RawFunctor.func* right) refl (RawFunctor.func→ right) - rawEq→ = begin - (λ f → RawFunctor.func→ left f) ≡⟨⟩ + -- I'm not sure `d` is provable. I believe `d'` should be, but I can also + -- not prove it. + d' : (λ i → Fmap ℂ ℂ Romap) [ KM.fmap ≡ Rfmap ] + d' = begin (λ f → KM.fmap f) ≡⟨⟩ (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ - (λ f → Rfmap f) ≡⟨⟩ - (λ f → RawFunctor.func→ right f) ∎ + (λ f → Rfmap f) ∎ - -- This goal is more general than the above goal which I also don't know - -- how to close. - p : (fmap' : Fmap ℂ ℂ (RawFunctor.func* left)) - → (λ i → Fmap ℂ ℂ Romap) [ RawFunctor.func→ left ≡ fmap' ] - -- aka: - -- - -- p : P (RawFunctor.func* left) refl - p fmap' = begin - (λ f → RawFunctor.func→ left f) ≡⟨⟩ - (λ f → KM.fmap f) ≡⟨⟩ - (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ - (λ f → fmap' f) ∎ + fmapEq : (λ i → Fmap ℂ ℂ (omapEq i)) [ KM.fmap ≡ Rfmap ] + fmapEq = pathJ D d Romap refl Rfmap - rawEq : Functor.raw (K.Monad.R (forth m)) ≡ Functor.raw R - rawEq = RawFunctor≡ ℂ ℂ {x = left} {right} (λ _ → Romap) p + rawEq : Functor.raw KM.R ≡ Functor.raw R + RawFunctor.func* (rawEq i) = omapEq i + RawFunctor.func→ (rawEq i) = fmapEq i Req : M.RawMonad.R (backRaw (forth m)) ≡ R Req = Functor≡ rawEq From 5ae68df5826045a40ec4e8d63bb81a8ab39f4e7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 15:52:22 +0100 Subject: [PATCH 51/91] Prove that fmap is mapped correctly --- src/Cat/Category.agda | 2 +- src/Cat/Category/Monad.agda | 120 +++++++++++++++++----------------- src/Cat/Category/Product.agda | 2 + 3 files changed, 62 insertions(+), 62 deletions(-) diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index 669a811..62a7221 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -76,7 +76,7 @@ record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where 𝟙 : {A : Object} → Arrow A A _∘_ : {A B C : Object} → Arrow B C → Arrow A B → Arrow A C - infixl 10 _∘_ + infixl 10 _∘_ _>>>_ -- | Operations on data diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index d900350..c7e6ee8 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -454,30 +454,31 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Monoidal.Monad.isMonad (back m) = backIsMonad m module _ (m : K.Monad) where - open K.Monad m - bindEq : ∀ {X Y} - → K.RawMonad.bind (forthRaw (backRaw m)) {X} {Y} - ≡ K.RawMonad.bind (K.Monad.raw m) - bindEq {X} {Y} = begin - K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩ - (λ f → join ∘ fmap f) ≡⟨⟩ - (λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩ - (λ f → bind f) ≡⟨⟩ - bind ∎ - where - lem : (f : Arrow X (omap Y)) - → bind (f >>> pure) >>> bind 𝟙 - ≡ bind f - lem f = begin - bind (f >>> pure) >>> bind 𝟙 - ≡⟨ isDistributive _ _ ⟩ - bind ((f >>> pure) >>> bind 𝟙) - ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (f >>> (pure >>> bind 𝟙)) - ≡⟨ cong (λ φ → bind (f >>> φ)) (isNatural _) ⟩ - bind (f >>> 𝟙) - ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ - bind f ∎ + private + open K.Monad m + bindEq : ∀ {X Y} + → K.RawMonad.bind (forthRaw (backRaw m)) {X} {Y} + ≡ K.RawMonad.bind (K.Monad.raw m) + bindEq {X} {Y} = begin + K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩ + (λ f → join ∘ fmap f) ≡⟨⟩ + (λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩ + (λ f → bind f) ≡⟨⟩ + bind ∎ + where + lem : (f : Arrow X (omap Y)) + → bind (f >>> pure) >>> bind 𝟙 + ≡ bind f + lem f = begin + bind (f >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((f >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (f >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (f >>> φ)) (isNatural _) ⟩ + bind (f >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind f ∎ forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m K.RawMonad.omap (forthRawEq _) = omap @@ -488,47 +489,44 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where fortheq m = K.Monad≡ (forthRawEq m) module _ (m : M.Monad) where - open M.RawMonad (M.Monad.raw m) using (R ; Romap ; Rfmap ; pureNT ; joinNT) - module KM = K.Monad (forth m) - omapEq : KM.omap ≡ Romap - omapEq = refl + private + open M.Monad m + module KM = K.Monad (forth m) + module R = Functor R + omapEq : KM.omap ≡ Romap + omapEq = refl - D : (omap : Omap ℂ ℂ) → Romap ≡ omap → Set _ - D omap eq = (fmap' : Fmap ℂ ℂ omap) - → (λ i → Fmap ℂ ℂ (eq i)) - [ (λ f → KM.fmap f) ≡ fmap' ] + bindEq : ∀ {X Y} {f : Arrow X (Romap Y)} → KM.bind f ≡ bind f + bindEq {X} {Y} {f} = begin + KM.bind f ≡⟨⟩ + joinT Y ∘ Rfmap f ≡⟨⟩ + bind f ∎ - -- The "base-case" for path induction on the family `D`. - d : D Romap λ _ → Romap - d = res - where - -- aka: - res - : (fmap : Fmap ℂ ℂ Romap) - → (λ _ → Fmap ℂ ℂ Romap) [ KM.fmap ≡ fmap ] - res fmap = begin - (λ f → KM.fmap f) ≡⟨⟩ - (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ - (λ f → fmap f) ∎ + joinEq : ∀ {X} → KM.join ≡ joinT X + joinEq {X} = begin + KM.join ≡⟨⟩ + KM.bind 𝟙 ≡⟨⟩ + bind 𝟙 ≡⟨⟩ + joinT X ∘ Rfmap 𝟙 ≡⟨ cong (λ φ → _ ∘ φ) R.isIdentity ⟩ + joinT X ∘ 𝟙 ≡⟨ proj₁ ℂ.isIdentity ⟩ + joinT X ∎ - -- This is sort of equivalent to `d` though the the order of - -- quantification is different. `KM.fmap` is defined in terms of `Rfmap` - -- (via `forth`) whereas in `d` above `fmap` is universally quantified. - -- - -- I'm not sure `d` is provable. I believe `d'` should be, but I can also - -- not prove it. - d' : (λ i → Fmap ℂ ℂ Romap) [ KM.fmap ≡ Rfmap ] - d' = begin - (λ f → KM.fmap f) ≡⟨⟩ - (λ f → KM.bind (f >>> KM.pure)) ≡⟨ {!!} ⟩ - (λ f → Rfmap f) ∎ + fmapEq : ∀ {A B} → KM.fmap {A} {B} ≡ Rfmap + fmapEq {A} {B} = funExt (λ f → begin + KM.fmap f ≡⟨⟩ + KM.bind (f >>> KM.pure) ≡⟨⟩ + bind (f >>> pureT _) ≡⟨⟩ + Rfmap (f >>> pureT B) >>> joinT B ≡⟨⟩ + Rfmap (f >>> pureT B) >>> joinT B ≡⟨ cong (λ φ → φ >>> joinT B) R.isDistributive ⟩ + Rfmap f >>> Rfmap (pureT B) >>> joinT B ≡⟨ ℂ.isAssociative ⟩ + joinT B ∘ Rfmap (pureT B) ∘ Rfmap f ≡⟨ cong (λ φ → φ ∘ Rfmap f) (proj₂ isInverse) ⟩ + 𝟙 ∘ Rfmap f ≡⟨ proj₂ ℂ.isIdentity ⟩ + Rfmap f ∎ + ) - fmapEq : (λ i → Fmap ℂ ℂ (omapEq i)) [ KM.fmap ≡ Rfmap ] - fmapEq = pathJ D d Romap refl Rfmap - - rawEq : Functor.raw KM.R ≡ Functor.raw R - RawFunctor.func* (rawEq i) = omapEq i - RawFunctor.func→ (rawEq i) = fmapEq i + rawEq : Functor.raw KM.R ≡ Functor.raw R + RawFunctor.func* (rawEq i) = omapEq i + RawFunctor.func→ (rawEq i) = fmapEq i Req : M.RawMonad.R (backRaw (forth m)) ≡ R Req = Functor≡ rawEq diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index aeb4f44..490f415 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -23,6 +23,8 @@ module _ {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') {A B obj : Object ℂ} whe -- open IsProduct +-- TODO `isProp (Product ...)` +-- TODO `isProp (HasProducts ...)` record Product {ℓ ℓ' : Level} {ℂ : Category ℓ ℓ'} (A B : Object ℂ) : Set (ℓ ⊔ ℓ') where no-eta-equality field From 110e3510c5f37b06ceec1088370d470d1ed05a4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 15:55:03 +0100 Subject: [PATCH 52/91] Use postulates --- src/Cat/Category/Monad.agda | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index c7e6ee8..f1b65d1 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -535,11 +535,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where postulate pureNTEq : (λ i → NaturalTransformation F.identity (Req i)) [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] + joinNTEq : (λ i → NaturalTransformation F[ Req i ∘ Req i ] (Req i)) + [ M.RawMonad.joinNT (backRaw (forth m)) ≡ joinNT ] backRawEq : backRaw (forth m) ≡ M.Monad.raw m -- stuck M.RawMonad.R (backRawEq i) = Req i - M.RawMonad.pureNT (backRawEq i) = {!!} -- pureNTEq i - M.RawMonad.joinNT (backRawEq i) = {!!} + M.RawMonad.pureNT (backRawEq i) = pureNTEq i -- pureNTEq i + M.RawMonad.joinNT (backRawEq i) = joinNTEq i backeq : (m : M.Monad) → back (forth m) ≡ m backeq m = M.Monad≡ (backRawEq m) From 085e6eb3d76016a92ea7f8fad90f0a368bf2a00a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 6 Mar 2018 23:18:23 +0100 Subject: [PATCH 53/91] Stuff about voe-2-3 --- src/Cat/Category/Monad.agda | 129 +++++++++++++++++++++++++++++++++++- 1 file changed, 128 insertions(+), 1 deletion(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index f1b65d1..34a4135 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -390,6 +390,7 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- | The monoidal- and kleisli presentation of monads are equivalent. -- +-- This is *not* problem 2.3 in [voe]. -- This is problem 2.3 in [voe]. module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private @@ -540,7 +541,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where backRawEq : backRaw (forth m) ≡ M.Monad.raw m -- stuck M.RawMonad.R (backRawEq i) = Req i - M.RawMonad.pureNT (backRawEq i) = pureNTEq i -- pureNTEq i + M.RawMonad.pureNT (backRawEq i) = pureNTEq i M.RawMonad.joinNT (backRawEq i) = joinNTEq i backeq : (m : M.Monad) → back (forth m) ≡ m @@ -551,3 +552,129 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Monoidal≃Kleisli : M.Monad ≃ K.Monad Monoidal≃Kleisli = forth , eqv + +module voe-2-3 {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where + private + ℓ = ℓa ⊔ ℓb + module ℂ = Category ℂ + open ℂ using (Object ; Arrow ; _∘_) + open NaturalTransformation ℂ ℂ + module M = Monoidal ℂ + module K = Kleisli ℂ + + module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where + record voe-2-3-1 : Set ℓ where + open M + + field + fmap : Fmap ℂ ℂ omap + join : {A : Object} → ℂ [ omap (omap A) , omap A ] + + Rraw : RawFunctor ℂ ℂ + Rraw = record + { func* = omap + ; func→ = fmap + } + + field + RisFunctor : IsFunctor ℂ ℂ Rraw + + R : EndoFunctor ℂ + R = record + { raw = Rraw + ; isFunctor = RisFunctor + } + + pureT : (X : Object) → Arrow X (omap X) + pureT X = pure {X} + + field + pureN : Natural F.identity R pureT + + pureNT : NaturalTransformation F.identity R + pureNT = pureT , pureN + + joinT : (A : Object) → ℂ [ omap (omap A) , omap A ] + joinT A = join {A} + + field + joinN : Natural F[ R ∘ R ] R joinT + + joinNT : NaturalTransformation F[ R ∘ R ] R + joinNT = joinT , joinN + + rawMnd : RawMonad + rawMnd = record + { R = R + ; pureNT = pureNT + ; joinNT = joinNT + } + + field + isMnd : IsMonad rawMnd + + mnd : Monad + mnd = record + { raw = rawMnd + ; isMonad = isMnd + } + + record voe-2-3-2 : Set ℓ where + open K + + field + bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] + + rawMnd : RawMonad + rawMnd = record + { omap = omap + ; pure = pure + ; bind = bind + } + + field + isMnd : IsMonad rawMnd + + mnd : Monad + mnd = record + { raw = rawMnd + ; isMonad = isMnd + } + +module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where + private + ℓ = ℓa ⊔ ℓb + module ℂ = Category ℂ + open ℂ using (Object ; Arrow ; _∘_) + open NaturalTransformation ℂ ℂ + module M = Monoidal ℂ + module K = Kleisli ℂ + open voe-2-3 {ℂ = ℂ} + + forth + : {omap : Omap ℂ ℂ} {pure : {X : Object} → Arrow X (omap X)} + → voe-2-3-1 omap pure → M.Monad + forth = voe-2-3-1.mnd + + back : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + back m = record + { fmap = Functor.func→ R + ; RisFunctor = Functor.isFunctor R + ; pureN = pureN + ; join = λ {X} → joinT X + ; joinN = joinN + ; isMnd = M.Monad.isMonad m + } + where + raw = M.Monad.raw m + R = M.RawMonad.R raw + pureT = M.RawMonad.pureT raw + pureN = M.RawMonad.pureN raw + joinT = M.RawMonad.joinT raw + joinN = M.RawMonad.joinN raw + + -- Unfortunately the two above definitions don't really give rise to a + -- bijection - at least not directly. Q: What to put in the indices for + -- `voe-2-3-1`? + equiv-2-3-1 : voe-2-3-1 {!!} {!!} ≃ M.Monad + equiv-2-3-1 = {!!} From 125123846e4d7a3eeb03807a0effbc129f4c9be7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 11:29:58 +0100 Subject: [PATCH 54/91] Lay out a strategy for showing the equivalence --- src/Cat/Category/Monad.agda | 158 +++++++++++++++++++++++++++++------- 1 file changed, 130 insertions(+), 28 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 34a4135..c5a5f88 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -4,6 +4,7 @@ module Cat.Category.Monad where open import Agda.Primitive open import Data.Product +open import Function renaming (_∘_ to _∘f_) using (_$_) open import Cubical open import Cubical.NType.Properties using (lemPropF ; lemSig) @@ -553,7 +554,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Monoidal≃Kleisli : M.Monad ≃ K.Monad Monoidal≃Kleisli = forth , eqv -module voe-2-3 {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where +module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private ℓ = ℓa ⊔ ℓb module ℂ = Category ℂ @@ -562,7 +563,7 @@ module voe-2-3 {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module M = Monoidal ℂ module K = Kleisli ℂ - module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where + module voe-2-3 (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where record voe-2-3-1 : Set ℓ where open M @@ -613,8 +614,8 @@ module voe-2-3 {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where field isMnd : IsMonad rawMnd - mnd : Monad - mnd = record + toMonad : Monad + toMonad = record { raw = rawMnd ; isMonad = isMnd } @@ -635,8 +636,8 @@ module voe-2-3 {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where field isMnd : IsMonad rawMnd - mnd : Monad - mnd = record + toMonad : Monad + toMonad = record { raw = rawMnd ; isMonad = isMnd } @@ -654,27 +655,128 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where forth : {omap : Omap ℂ ℂ} {pure : {X : Object} → Arrow X (omap X)} → voe-2-3-1 omap pure → M.Monad - forth = voe-2-3-1.mnd + forth {omap} {pure} m = voe-2-3-1.toMonad omap pure m - back : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) - back m = record - { fmap = Functor.func→ R - ; RisFunctor = Functor.isFunctor R - ; pureN = pureN - ; join = λ {X} → joinT X - ; joinN = joinN - ; isMnd = M.Monad.isMonad m - } - where - raw = M.Monad.raw m - R = M.RawMonad.R raw - pureT = M.RawMonad.pureT raw - pureN = M.RawMonad.pureN raw - joinT = M.RawMonad.joinT raw - joinN = M.RawMonad.joinN raw + voe-2-3-1-fromMonad : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + voe-2-3-1-fromMonad m = record + { fmap = Functor.func→ R + ; RisFunctor = Functor.isFunctor R + ; pureN = pureN + ; join = λ {X} → joinT X + ; joinN = joinN + ; isMnd = M.Monad.isMonad m + } + where + raw = M.Monad.raw m + R = M.RawMonad.R raw + pureT = M.RawMonad.pureT raw + pureN = M.RawMonad.pureN raw + joinT = M.RawMonad.joinT raw + joinN = M.RawMonad.joinN raw - -- Unfortunately the two above definitions don't really give rise to a - -- bijection - at least not directly. Q: What to put in the indices for - -- `voe-2-3-1`? - equiv-2-3-1 : voe-2-3-1 {!!} {!!} ≃ M.Monad - equiv-2-3-1 = {!!} + voe-2-3-2-fromMonad : (m : K.Monad) → voe-2-3-2 (K.Monad.omap m) (K.Monad.pure m) + voe-2-3-2-fromMonad m = record + { bind = K.Monad.bind m + ; isMnd = K.Monad.isMonad m + } + + -- Unfortunately the two above definitions don't really give rise to a + -- bijection - at least not directly. Q: What to put in the indices for + -- `voe-2-3-1`? + equiv-2-3-1 : voe-2-3-1 {!!} {!!} ≃ M.Monad + equiv-2-3-1 = {!!} + +module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where + private + ℓ = ℓa ⊔ ℓb + module ℂ = Category ℂ + open ℂ using (Object ; Arrow ; _∘_) + open NaturalTransformation ℂ ℂ + module M = Monoidal ℂ + module K = Kleisli ℂ + + module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where + open voe-2-3 {ℂ = ℂ} omap pure + -- Idea: + -- We want to prove + -- + -- voe-2-3-1 ≃ voe-2-3-2 + -- + -- By using the equivalence we have already constructed. + -- + -- We can construct `forth` by composing `forth0`, `forth1` and `forth2`: + -- + -- forth0 : voe-2-3-1 → M.Monad + -- + -- Where the we will naturally pick `omap` and `pure` as the corresponding + -- fields in M.Monad + -- + -- `forth1` will be the equivalence we have already constructed. + -- + -- forth1 : M.Monad ≃ K.Monad + -- + -- `forth2` is the straight-forward isomporphism: + -- + -- forth1 : K.Monad → voe-2-3-2 + -- + -- NB! This may not be so straightforward since the index of `voe-2-3-2` is + -- given before `K.Monad`. + private + Monoidal→Kleisli : M.Monad → K.Monad + Monoidal→Kleisli = proj₁ Monoidal≃Kleisli + + Kleisli→Monoidal : K.Monad → M.Monad + Kleisli→Monoidal = reverse Monoidal≃Kleisli + + forth : voe-2-3-1 → voe-2-3-2 + forth = voe-2-3-2-fromMonad ∘f Monoidal→Kleisli ∘f voe-2-3-1.toMonad + + back : voe-2-3-2 → voe-2-3-1 + back = voe-2-3-1-fromMonad ∘f Kleisli→Monoidal ∘f voe-2-3-2.toMonad + + forthEq : ∀ m → (forth ∘f back) m ≡ m + forthEq m = begin + (forth ∘f back) m ≡⟨⟩ + -- In full gory detail: + ( voe-2-3-2-fromMonad + ∘f Monoidal→Kleisli + ∘f voe-2-3-1.toMonad + ∘f voe-2-3-1-fromMonad + ∘f Kleisli→Monoidal + ∘f voe-2-3-2.toMonad + ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses + ( voe-2-3-2-fromMonad + ∘f Monoidal→Kleisli + ∘f Kleisli→Monoidal + ∘f voe-2-3-2.toMonad + ) m ≡⟨ {!!} ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses + ( voe-2-3-2-fromMonad + ∘f voe-2-3-2.toMonad + ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses + m ∎ + + backEq : ∀ m → (back ∘f forth) m ≡ m + backEq m = begin + (back ∘f forth) m ≡⟨⟩ + ( voe-2-3-1-fromMonad + ∘f Kleisli→Monoidal + ∘f voe-2-3-2.toMonad + ∘f voe-2-3-2-fromMonad + ∘f Monoidal→Kleisli + ∘f voe-2-3-1.toMonad + ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses + ( voe-2-3-1-fromMonad + ∘f Kleisli→Monoidal + ∘f Monoidal→Kleisli + ∘f voe-2-3-1.toMonad + ) m ≡⟨ {!!} ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses + ( voe-2-3-1-fromMonad + ∘f voe-2-3-1.toMonad + ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses + m ∎ + + voe-isEquiv : isEquiv voe-2-3-1 voe-2-3-2 forth + voe-isEquiv = gradLemma forth back forthEq backEq + + equiv-2-3 : voe-2-3-1 ≃ voe-2-3-2 + equiv-2-3 = forth , voe-isEquiv From aa64e010846cc99f4a3dc5075cd09dc27428f887 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 11:33:08 +0100 Subject: [PATCH 55/91] Remove some cruft --- src/Cat/Category/Monad.agda | 21 +++------------------ 1 file changed, 3 insertions(+), 18 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index c5a5f88..f2b6ee0 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -554,7 +554,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Monoidal≃Kleisli : M.Monad ≃ K.Monad Monoidal≃Kleisli = forth , eqv -module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where +module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private ℓ = ℓa ⊔ ℓb module ℂ = Category ℂ @@ -644,18 +644,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private - ℓ = ℓa ⊔ ℓb - module ℂ = Category ℂ - open ℂ using (Object ; Arrow ; _∘_) - open NaturalTransformation ℂ ℂ module M = Monoidal ℂ module K = Kleisli ℂ - open voe-2-3 {ℂ = ℂ} - - forth - : {omap : Omap ℂ ℂ} {pure : {X : Object} → Arrow X (omap X)} - → voe-2-3-1 omap pure → M.Monad - forth {omap} {pure} m = voe-2-3-1.toMonad omap pure m + open voe-2-3 ℂ voe-2-3-1-fromMonad : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) voe-2-3-1-fromMonad m = record @@ -680,12 +671,6 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where ; isMnd = K.Monad.isMonad m } - -- Unfortunately the two above definitions don't really give rise to a - -- bijection - at least not directly. Q: What to put in the indices for - -- `voe-2-3-1`? - equiv-2-3-1 : voe-2-3-1 {!!} {!!} ≃ M.Monad - equiv-2-3-1 = {!!} - module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private ℓ = ℓa ⊔ ℓb @@ -696,7 +681,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where module K = Kleisli ℂ module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where - open voe-2-3 {ℂ = ℂ} omap pure + open voe-2-3 ℂ omap pure -- Idea: -- We want to prove -- From 00e6e1aa6603b8cbc625694570d2a79b45408018 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 11:45:11 +0100 Subject: [PATCH 56/91] State problem with approach --- src/Cat/Category/Monad.agda | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index f2b6ee0..7ffe664 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -719,6 +719,19 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where back : voe-2-3-2 → voe-2-3-1 back = voe-2-3-1-fromMonad ∘f Kleisli→Monoidal ∘f voe-2-3-2.toMonad + Voe-2-3-1-inverse = (toMonad ∘f fromMonad) ≡ Function.id + where + toMonad : voe-2-3-1 → M.Monad + toMonad = voe-2-3-1.toMonad + t : (m : M.Monad) → voe-2-3.voe-2-3-1 ℂ (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + t = voe-2-3-1-fromMonad + -- Problem: `t` does not fit the type of `fromMonad`! + fromMonad : M.Monad → voe-2-3-1 + fromMonad = {!t!} + + voe-2-3-1-inverse : Voe-2-3-1-inverse + voe-2-3-1-inverse = {!!} + forthEq : ∀ m → (forth ∘f back) m ≡ m forthEq m = begin (forth ∘f back) m ≡⟨⟩ From bf605e09fe32631742bf42bbe0b6a7619f4c7027 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 15:10:36 +0100 Subject: [PATCH 57/91] Update commit refs --- libs/agda-stdlib | 2 +- libs/cubical | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/agda-stdlib b/libs/agda-stdlib index b9c8e02..87d28d7 160000 --- a/libs/agda-stdlib +++ b/libs/agda-stdlib @@ -1 +1 @@ -Subproject commit b9c8e02597751a1b15045cbc5108c221999bd540 +Subproject commit 87d28d7d753f73abd20665d7bbb88f9d72ed88aa diff --git a/libs/cubical b/libs/cubical index 0d3f02e..159c519 160000 --- a/libs/cubical +++ b/libs/cubical @@ -1 +1 @@ -Subproject commit 0d3f02e68297e940227137beac45fc1bce6e2bea +Subproject commit 159c519936afcfb72afe5c1528637dd0f0a7303a From 93d075a6d31d3a7434a4e4294d05f6f55c150fa2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 15:23:07 +0100 Subject: [PATCH 58/91] Attempt at proving `pureNTEq` --- src/Cat/Category/Functor.agda | 1 + src/Cat/Category/Monad.agda | 58 ++++++++++++++++++++++++++++++++--- 2 files changed, 54 insertions(+), 5 deletions(-) diff --git a/src/Cat/Category/Functor.agda b/src/Cat/Category/Functor.agda index e9a28fc..d627539 100644 --- a/src/Cat/Category/Functor.agda +++ b/src/Cat/Category/Functor.agda @@ -61,6 +61,7 @@ module _ {ℓc ℓc' ℓd ℓd'} record IsFunctor (F : RawFunctor) : 𝓤 where open RawFunctor F public field + -- TODO Really ought to be preserves identity or something like this. isIdentity : IsIdentity isDistributive : IsDistributive diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 7ffe664..279e457 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -534,13 +534,61 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Req = Functor≡ rawEq open NaturalTransformation ℂ ℂ - postulate - pureNTEq : (λ i → NaturalTransformation F.identity (Req i)) + + pureTEq : M.RawMonad.pureT (backRaw (forth m)) ≡ pureT + pureTEq = funExt (λ X → refl) + + -- TODO: Make equaility principle for natural transformations that allows + -- us to only focus on the data-part but for heterogeneous paths! + -- + -- It should be something like (but not exactly because this is ill-typed!) + -- + -- P : I → Set -- A family that varies over natural transformations. + -- θ : P i0 + -- η : P i1 + NaturalTransformation~≡ : ∀ {F G} {P : I → Set _} {θ η : NaturalTransformation F G} → proj₁ θ ≡ proj₁ η → _ [ θ ≡ η ] + NaturalTransformation~≡ = {!!} + + pureNTEq : (λ i → NaturalTransformation F.identity (Req i)) + [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] + pureNTEq = res + where + Base = Transformation F.identity R + base : Base + base = M.RawMonad.pureT (backRaw (forth m)) + target : Base + target = pureT + -- No matter what the proof of naturality is (whether it'd be at `base` + -- or at `target` propositionality of naturality means that we can prove + -- two natural transformations equal just by focusing on the data-part. + d : {nat : Natural F.identity R base} + → (λ i → NaturalTransformation F.identity R) + [ (base , nat) + ≡ (target , nat) + ] + d = NaturalTransformation≡ F.identity R pureTEq + -- I think that `d` should be the "base-case" somehow in my + -- path-induction but I don't know how to define a suitable type-family. + D : (y : Base) → ({!!} ≡ y) → Set _ + D y eq = {!!} + res + : (λ i → NaturalTransformation F.identity (Req i)) [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] - joinNTEq : (λ i → NaturalTransformation F[ Req i ∘ Req i ] (Req i)) - [ M.RawMonad.joinNT (backRaw (forth m)) ≡ joinNT ] + res = pathJ D d base pureTEq {!!} + + joinTEq : M.RawMonad.joinT (backRaw (forth m)) ≡ joinT + joinTEq = funExt (λ X → begin + M.RawMonad.joinT (backRaw (forth m)) X ≡⟨⟩ + KM.join ≡⟨⟩ + joinT X ∘ Rfmap 𝟙 ≡⟨ cong (λ φ → joinT X ∘ φ) R.isIdentity ⟩ + joinT X ∘ 𝟙 ≡⟨ proj₁ ℂ.isIdentity ⟩ + joinT X ∎) + + joinNTEq : (λ i → NaturalTransformation F[ Req i ∘ Req i ] (Req i)) + [ M.RawMonad.joinNT (backRaw (forth m)) ≡ joinNT ] + joinNTEq = NaturalTransformation~≡ joinTEq + backRawEq : backRaw (forth m) ≡ M.Monad.raw m - -- stuck M.RawMonad.R (backRawEq i) = Req i M.RawMonad.pureNT (backRawEq i) = pureNTEq i M.RawMonad.joinNT (backRawEq i) = joinNTEq i From 3749124d09fb93b44d20e45c73fb1c4a7590060d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 15:38:37 +0100 Subject: [PATCH 59/91] Switch to experimental branch of stdlib --- libs/agda-stdlib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/agda-stdlib b/libs/agda-stdlib index 87d28d7..fbd8ba7 160000 --- a/libs/agda-stdlib +++ b/libs/agda-stdlib @@ -1 +1 @@ -Subproject commit 87d28d7d753f73abd20665d7bbb88f9d72ed88aa +Subproject commit fbd8ba7ea84c4b643fd08797b4031b18a59f561d From 50f51db4fc7eaad0e88542d66051c1545c3b4636 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 15:40:52 +0100 Subject: [PATCH 60/91] Update readme --- README.md | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 34467b0..8088a60 100644 --- a/README.md +++ b/README.md @@ -14,10 +14,12 @@ Dependencies ------------ To succesfully compile the following is needed: -* Agda version >= [`707ce6042b6a3bdb26521f3fe8dfe5d8a8470a43`](https://github.com/agda/agda/commit/707ce6042b6a3bdb26521f3fe8dfe5d8a8470a43) -* [Agda Standard Library](https://github.com/agda/agda-stdlib) +* The Agda release candidate 2.5.4[^1] +* The experimental branch of [Agda Standard Library](https://github.com/agda/agda-stdlib) * [Cubical](https://github.com/Saizan/cubical-demo/) +[^1]: At least version >= [`707ce6042b6a3bdb26521f3fe8dfe5d8a8470a43`](https://github.com/agda/agda/commit/707ce6042b6a3bdb26521f3fe8dfe5d8a8470a43) + It's important to have the right version of these - but which one is the right is in constant flux. It's most likely the newest one. From 19103e1678b7a3c6f0b1b5ebcdcb7049f9d7c018 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 16:24:43 +0100 Subject: [PATCH 61/91] Update cubical --- libs/cubical | 2 +- src/Cat/Category/Monad.agda | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/cubical b/libs/cubical index 159c519..2fa05f7 160000 --- a/libs/cubical +++ b/libs/cubical @@ -1 +1 @@ -Subproject commit 159c519936afcfb72afe5c1528637dd0f0a7303a +Subproject commit 2fa05f70edfc59f205be9af2227996bdd6084948 diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 279e457..9c343a2 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -759,7 +759,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Monoidal→Kleisli = proj₁ Monoidal≃Kleisli Kleisli→Monoidal : K.Monad → M.Monad - Kleisli→Monoidal = reverse Monoidal≃Kleisli + Kleisli→Monoidal = inverse Monoidal≃Kleisli forth : voe-2-3-1 → voe-2-3-2 forth = voe-2-3-2-fromMonad ∘f Monoidal→Kleisli ∘f voe-2-3-1.toMonad From 459718da2368cd5974891e7f3113f1bcc8d5af7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 7 Mar 2018 17:30:09 +0100 Subject: [PATCH 62/91] Finish proof of equivalence of klesili/monoidal categories!! --- libs/cubical | 2 +- src/Cat/Category/Monad.agda | 40 +++---------------------------------- 2 files changed, 4 insertions(+), 38 deletions(-) diff --git a/libs/cubical b/libs/cubical index 2fa05f7..a487c76 160000 --- a/libs/cubical +++ b/libs/cubical @@ -1 +1 @@ -Subproject commit 2fa05f70edfc59f205be9af2227996bdd6084948 +Subproject commit a487c76a5f3ecf2752dabc9e5c3a8866fda28a19 diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 9c343a2..c4c47c5 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -7,7 +7,7 @@ open import Data.Product open import Function renaming (_∘_ to _∘f_) using (_$_) open import Cubical -open import Cubical.NType.Properties using (lemPropF ; lemSig) +open import Cubical.NType.Properties using (lemPropF ; lemSig ; lemSigP) open import Cubical.GradLemma using (gradLemma) open import Cat.Category @@ -538,43 +538,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where pureTEq : M.RawMonad.pureT (backRaw (forth m)) ≡ pureT pureTEq = funExt (λ X → refl) - -- TODO: Make equaility principle for natural transformations that allows - -- us to only focus on the data-part but for heterogeneous paths! - -- - -- It should be something like (but not exactly because this is ill-typed!) - -- - -- P : I → Set -- A family that varies over natural transformations. - -- θ : P i0 - -- η : P i1 - NaturalTransformation~≡ : ∀ {F G} {P : I → Set _} {θ η : NaturalTransformation F G} → proj₁ θ ≡ proj₁ η → _ [ θ ≡ η ] - NaturalTransformation~≡ = {!!} - pureNTEq : (λ i → NaturalTransformation F.identity (Req i)) [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] - pureNTEq = res - where - Base = Transformation F.identity R - base : Base - base = M.RawMonad.pureT (backRaw (forth m)) - target : Base - target = pureT - -- No matter what the proof of naturality is (whether it'd be at `base` - -- or at `target` propositionality of naturality means that we can prove - -- two natural transformations equal just by focusing on the data-part. - d : {nat : Natural F.identity R base} - → (λ i → NaturalTransformation F.identity R) - [ (base , nat) - ≡ (target , nat) - ] - d = NaturalTransformation≡ F.identity R pureTEq - -- I think that `d` should be the "base-case" somehow in my - -- path-induction but I don't know how to define a suitable type-family. - D : (y : Base) → ({!!} ≡ y) → Set _ - D y eq = {!!} - res - : (λ i → NaturalTransformation F.identity (Req i)) - [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] - res = pathJ D d base pureTEq {!!} + pureNTEq = lemSigP (λ i → propIsNatural F.identity (Req i)) _ _ pureTEq joinTEq : M.RawMonad.joinT (backRaw (forth m)) ≡ joinT joinTEq = funExt (λ X → begin @@ -586,7 +552,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where joinNTEq : (λ i → NaturalTransformation F[ Req i ∘ Req i ] (Req i)) [ M.RawMonad.joinNT (backRaw (forth m)) ≡ joinNT ] - joinNTEq = NaturalTransformation~≡ joinTEq + joinNTEq = lemSigP (λ i → propIsNatural F[ Req i ∘ Req i ] (Req i)) _ _ joinTEq backRawEq : backRaw (forth m) ≡ M.Monad.raw m M.RawMonad.R (backRawEq i) = Req i From 36cbe711fb88bc15f14aad5a31d28ee33ca61b3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 00:09:49 +0100 Subject: [PATCH 63/91] Sort of half of the proof of an inverse --- src/Cat/Category/Monad.agda | 59 ++++++++++++++++++++++++++++++++----- 1 file changed, 51 insertions(+), 8 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index c4c47c5..28d4f4b 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -735,16 +735,59 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Voe-2-3-1-inverse = (toMonad ∘f fromMonad) ≡ Function.id where - toMonad : voe-2-3-1 → M.Monad - toMonad = voe-2-3-1.toMonad - t : (m : M.Monad) → voe-2-3.voe-2-3-1 ℂ (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) - t = voe-2-3-1-fromMonad - -- Problem: `t` does not fit the type of `fromMonad`! - fromMonad : M.Monad → voe-2-3-1 - fromMonad = {!t!} + fromMonad : (m : M.Monad) → voe-2-3.voe-2-3-1 ℂ (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + fromMonad = voe-2-3-1-fromMonad + toMonad : ∀ {omap} {pure : {X : Object} → Arrow X (omap X)} → voe-2-3.voe-2-3-1 ℂ omap pure → M.Monad + toMonad = voe-2-3.voe-2-3-1.toMonad + -- voe-2-3-1-inverse : (voe-2-3.voe-2-3-1.toMonad ∘f voe-2-3-1-fromMonad) ≡ Function.id voe-2-3-1-inverse : Voe-2-3-1-inverse - voe-2-3-1-inverse = {!!} + voe-2-3-1-inverse = refl + + Voe-2-3-2-inverse = (toMonad ∘f fromMonad) ≡ Function.id + where + fromMonad : (m : K.Monad) → voe-2-3.voe-2-3-2 ℂ (K.Monad.omap m) (K.Monad.pure m) + fromMonad = voe-2-3-2-fromMonad + toMonad : ∀ {omap} {pure : {X : Object} → Arrow X (omap X)} → voe-2-3.voe-2-3-2 ℂ omap pure → K.Monad + toMonad = voe-2-3.voe-2-3-2.toMonad + + voe-2-3-2-inverse : Voe-2-3-2-inverse + voe-2-3-2-inverse = refl + + forthEq' : ∀ m → _ ≡ _ + forthEq' m = begin + (forth ∘f back) m ≡⟨⟩ + -- In full gory detail: + ( voe-2-3-2-fromMonad + ∘f Monoidal→Kleisli + ∘f voe-2-3.voe-2-3-1.toMonad + ∘f voe-2-3-1-fromMonad + ∘f Kleisli→Monoidal + ∘f voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + ( voe-2-3-2-fromMonad + ∘f Monoidal→Kleisli + ∘f Kleisli→Monoidal + ∘f voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨ u ⟩ + -- Monoidal→Kleisli and Kleisli→Monoidal are inverses + -- I should be able to prove this using congruence and `lem` below. + ( voe-2-3-2-fromMonad + ∘f voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨⟩ + ( voe-2-3-2-fromMonad + ∘f voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + m ∎ + where + lem : Monoidal→Kleisli ∘f Kleisli→Monoidal ≡ Function.id + lem = verso-recto Monoidal≃Kleisli + t : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} + → a ∘f (Monoidal→Kleisli ∘f Kleisli→Monoidal) ∘f b ≡ a ∘f b + t {a = a} {b} = cong (λ φ → a ∘f φ ∘f b) lem + u : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} + → {m : _} → (a ∘f (Monoidal→Kleisli ∘f Kleisli→Monoidal) ∘f b) m ≡ (a ∘f b) m + u {m = m} = cong (λ φ → φ m) t forthEq : ∀ m → (forth ∘f back) m ≡ m forthEq m = begin From c8fef1d2b52a0dceda4d7c3f52534df5d281b2cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 00:22:55 +0100 Subject: [PATCH 64/91] Use different name for function composition --- src/Cat/Category/Monad.agda | 88 ++++++++++++++++++------------------- 1 file changed, 44 insertions(+), 44 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 28d4f4b..5fefe1e 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -4,7 +4,6 @@ module Cat.Category.Monad where open import Agda.Primitive open import Data.Product -open import Function renaming (_∘_ to _∘f_) using (_$_) open import Cubical open import Cubical.NType.Properties using (lemPropF ; lemSig ; lemSigP) @@ -689,10 +688,11 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private ℓ = ℓa ⊔ ℓb module ℂ = Category ℂ - open ℂ using (Object ; Arrow ; _∘_) + open ℂ using (Object ; Arrow) open NaturalTransformation ℂ ℂ module M = Monoidal ℂ module K = Kleisli ℂ + open import Function using (_∘_ ; _$_) module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where open voe-2-3 ℂ omap pure @@ -728,23 +728,23 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Kleisli→Monoidal = inverse Monoidal≃Kleisli forth : voe-2-3-1 → voe-2-3-2 - forth = voe-2-3-2-fromMonad ∘f Monoidal→Kleisli ∘f voe-2-3-1.toMonad + forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ voe-2-3-1.toMonad back : voe-2-3-2 → voe-2-3-1 - back = voe-2-3-1-fromMonad ∘f Kleisli→Monoidal ∘f voe-2-3-2.toMonad + back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ voe-2-3-2.toMonad - Voe-2-3-1-inverse = (toMonad ∘f fromMonad) ≡ Function.id + Voe-2-3-1-inverse = (toMonad ∘ fromMonad) ≡ Function.id where fromMonad : (m : M.Monad) → voe-2-3.voe-2-3-1 ℂ (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) fromMonad = voe-2-3-1-fromMonad toMonad : ∀ {omap} {pure : {X : Object} → Arrow X (omap X)} → voe-2-3.voe-2-3-1 ℂ omap pure → M.Monad toMonad = voe-2-3.voe-2-3-1.toMonad - -- voe-2-3-1-inverse : (voe-2-3.voe-2-3-1.toMonad ∘f voe-2-3-1-fromMonad) ≡ Function.id + -- voe-2-3-1-inverse : (voe-2-3.voe-2-3-1.toMonad ∘ voe-2-3-1-fromMonad) ≡ Function.id voe-2-3-1-inverse : Voe-2-3-1-inverse voe-2-3-1-inverse = refl - Voe-2-3-2-inverse = (toMonad ∘f fromMonad) ≡ Function.id + Voe-2-3-2-inverse = (toMonad ∘ fromMonad) ≡ Function.id where fromMonad : (m : K.Monad) → voe-2-3.voe-2-3-2 ℂ (K.Monad.omap m) (K.Monad.pure m) fromMonad = voe-2-3-2-fromMonad @@ -756,77 +756,77 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where forthEq' : ∀ m → _ ≡ _ forthEq' m = begin - (forth ∘f back) m ≡⟨⟩ + (forth ∘ back) m ≡⟨⟩ -- In full gory detail: ( voe-2-3-2-fromMonad - ∘f Monoidal→Kleisli - ∘f voe-2-3.voe-2-3-1.toMonad - ∘f voe-2-3-1-fromMonad - ∘f Kleisli→Monoidal - ∘f voe-2-3.voe-2-3-2.toMonad + ∘ Monoidal→Kleisli + ∘ voe-2-3.voe-2-3-1.toMonad + ∘ voe-2-3-1-fromMonad + ∘ Kleisli→Monoidal + ∘ voe-2-3.voe-2-3-2.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses ( voe-2-3-2-fromMonad - ∘f Monoidal→Kleisli - ∘f Kleisli→Monoidal - ∘f voe-2-3.voe-2-3-2.toMonad + ∘ Monoidal→Kleisli + ∘ Kleisli→Monoidal + ∘ voe-2-3.voe-2-3-2.toMonad ) m ≡⟨ u ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses -- I should be able to prove this using congruence and `lem` below. ( voe-2-3-2-fromMonad - ∘f voe-2-3.voe-2-3-2.toMonad + ∘ voe-2-3.voe-2-3-2.toMonad ) m ≡⟨⟩ ( voe-2-3-2-fromMonad - ∘f voe-2-3.voe-2-3-2.toMonad + ∘ voe-2-3.voe-2-3-2.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ where - lem : Monoidal→Kleisli ∘f Kleisli→Monoidal ≡ Function.id + lem : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ Function.id lem = verso-recto Monoidal≃Kleisli t : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} - → a ∘f (Monoidal→Kleisli ∘f Kleisli→Monoidal) ∘f b ≡ a ∘f b - t {a = a} {b} = cong (λ φ → a ∘f φ ∘f b) lem + → a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b ≡ a ∘ b + t {a = a} {b} = cong (λ φ → a ∘ φ ∘ b) lem u : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} - → {m : _} → (a ∘f (Monoidal→Kleisli ∘f Kleisli→Monoidal) ∘f b) m ≡ (a ∘f b) m + → {m : _} → (a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b) m ≡ (a ∘ b) m u {m = m} = cong (λ φ → φ m) t - forthEq : ∀ m → (forth ∘f back) m ≡ m + forthEq : ∀ m → (forth ∘ back) m ≡ m forthEq m = begin - (forth ∘f back) m ≡⟨⟩ + (forth ∘ back) m ≡⟨⟩ -- In full gory detail: ( voe-2-3-2-fromMonad - ∘f Monoidal→Kleisli - ∘f voe-2-3-1.toMonad - ∘f voe-2-3-1-fromMonad - ∘f Kleisli→Monoidal - ∘f voe-2-3-2.toMonad + ∘ Monoidal→Kleisli + ∘ voe-2-3-1.toMonad + ∘ voe-2-3-1-fromMonad + ∘ Kleisli→Monoidal + ∘ voe-2-3-2.toMonad ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses ( voe-2-3-2-fromMonad - ∘f Monoidal→Kleisli - ∘f Kleisli→Monoidal - ∘f voe-2-3-2.toMonad + ∘ Monoidal→Kleisli + ∘ Kleisli→Monoidal + ∘ voe-2-3-2.toMonad ) m ≡⟨ {!!} ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses ( voe-2-3-2-fromMonad - ∘f voe-2-3-2.toMonad + ∘ voe-2-3-2.toMonad ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses m ∎ - backEq : ∀ m → (back ∘f forth) m ≡ m + backEq : ∀ m → (back ∘ forth) m ≡ m backEq m = begin - (back ∘f forth) m ≡⟨⟩ + (back ∘ forth) m ≡⟨⟩ ( voe-2-3-1-fromMonad - ∘f Kleisli→Monoidal - ∘f voe-2-3-2.toMonad - ∘f voe-2-3-2-fromMonad - ∘f Monoidal→Kleisli - ∘f voe-2-3-1.toMonad + ∘ Kleisli→Monoidal + ∘ voe-2-3-2.toMonad + ∘ voe-2-3-2-fromMonad + ∘ Monoidal→Kleisli + ∘ voe-2-3-1.toMonad ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses ( voe-2-3-1-fromMonad - ∘f Kleisli→Monoidal - ∘f Monoidal→Kleisli - ∘f voe-2-3-1.toMonad + ∘ Kleisli→Monoidal + ∘ Monoidal→Kleisli + ∘ voe-2-3-1.toMonad ) m ≡⟨ {!!} ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses ( voe-2-3-1-fromMonad - ∘f voe-2-3-1.toMonad + ∘ voe-2-3-1.toMonad ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses m ∎ From e43bee6d9fc63564a81c4bd94bd003b9f8fa5a29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 00:36:38 +0100 Subject: [PATCH 65/91] Feels really close --- src/Cat/Category/Monad.agda | 120 +++++++++--------------------------- 1 file changed, 28 insertions(+), 92 deletions(-) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 5fefe1e..c0c42bf 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -695,31 +695,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where open import Function using (_∘_ ; _$_) module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where - open voe-2-3 ℂ omap pure - -- Idea: - -- We want to prove - -- - -- voe-2-3-1 ≃ voe-2-3-2 - -- - -- By using the equivalence we have already constructed. - -- - -- We can construct `forth` by composing `forth0`, `forth1` and `forth2`: - -- - -- forth0 : voe-2-3-1 → M.Monad - -- - -- Where the we will naturally pick `omap` and `pure` as the corresponding - -- fields in M.Monad - -- - -- `forth1` will be the equivalence we have already constructed. - -- - -- forth1 : M.Monad ≃ K.Monad - -- - -- `forth2` is the straight-forward isomporphism: - -- - -- forth1 : K.Monad → voe-2-3-2 - -- - -- NB! This may not be so straightforward since the index of `voe-2-3-2` is - -- given before `K.Monad`. + open voe-2-3 ℂ private Monoidal→Kleisli : M.Monad → K.Monad Monoidal→Kleisli = proj₁ Monoidal≃Kleisli @@ -727,57 +703,36 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Kleisli→Monoidal : K.Monad → M.Monad Kleisli→Monoidal = inverse Monoidal≃Kleisli - forth : voe-2-3-1 → voe-2-3-2 - forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ voe-2-3-1.toMonad + forth : voe-2-3-1 omap pure → voe-2-3-2 omap pure + forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ voe-2-3.voe-2-3-1.toMonad - back : voe-2-3-2 → voe-2-3-1 - back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ voe-2-3-2.toMonad + back : voe-2-3-2 omap pure → voe-2-3-1 omap pure + back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ voe-2-3.voe-2-3-2.toMonad - Voe-2-3-1-inverse = (toMonad ∘ fromMonad) ≡ Function.id - where - fromMonad : (m : M.Monad) → voe-2-3.voe-2-3-1 ℂ (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) - fromMonad = voe-2-3-1-fromMonad - toMonad : ∀ {omap} {pure : {X : Object} → Arrow X (omap X)} → voe-2-3.voe-2-3-1 ℂ omap pure → M.Monad - toMonad = voe-2-3.voe-2-3-1.toMonad - - -- voe-2-3-1-inverse : (voe-2-3.voe-2-3-1.toMonad ∘ voe-2-3-1-fromMonad) ≡ Function.id - voe-2-3-1-inverse : Voe-2-3-1-inverse - voe-2-3-1-inverse = refl - - Voe-2-3-2-inverse = (toMonad ∘ fromMonad) ≡ Function.id - where - fromMonad : (m : K.Monad) → voe-2-3.voe-2-3-2 ℂ (K.Monad.omap m) (K.Monad.pure m) - fromMonad = voe-2-3-2-fromMonad - toMonad : ∀ {omap} {pure : {X : Object} → Arrow X (omap X)} → voe-2-3.voe-2-3-2 ℂ omap pure → K.Monad - toMonad = voe-2-3.voe-2-3-2.toMonad - - voe-2-3-2-inverse : Voe-2-3-2-inverse - voe-2-3-2-inverse = refl - - forthEq' : ∀ m → _ ≡ _ - forthEq' m = begin + forthEq : ∀ m → _ ≡ _ + forthEq m = begin (forth ∘ back) m ≡⟨⟩ -- In full gory detail: - ( voe-2-3-2-fromMonad + ( voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ voe-2-3.voe-2-3-1.toMonad ∘ voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses ( voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ Kleisli→Monoidal ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨ u ⟩ + ) m ≡⟨ u ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses -- I should be able to prove this using congruence and `lem` below. + ( voe-2-3-2-fromMonad + ∘ voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨⟩ ( voe-2-3-2-fromMonad ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨⟩ - ( voe-2-3-2-fromMonad - ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ where lem : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ Function.id @@ -789,49 +744,30 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where → {m : _} → (a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b) m ≡ (a ∘ b) m u {m = m} = cong (λ φ → φ m) t - forthEq : ∀ m → (forth ∘ back) m ≡ m - forthEq m = begin - (forth ∘ back) m ≡⟨⟩ - -- In full gory detail: - ( voe-2-3-2-fromMonad - ∘ Monoidal→Kleisli - ∘ voe-2-3-1.toMonad - ∘ voe-2-3-1-fromMonad - ∘ Kleisli→Monoidal - ∘ voe-2-3-2.toMonad - ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses - ( voe-2-3-2-fromMonad - ∘ Monoidal→Kleisli - ∘ Kleisli→Monoidal - ∘ voe-2-3-2.toMonad - ) m ≡⟨ {!!} ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses - ( voe-2-3-2-fromMonad - ∘ voe-2-3-2.toMonad - ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses - m ∎ - backEq : ∀ m → (back ∘ forth) m ≡ m backEq m = begin (back ∘ forth) m ≡⟨⟩ - ( voe-2-3-1-fromMonad + ( voe-2-3-1-fromMonad ∘ Kleisli→Monoidal - ∘ voe-2-3-2.toMonad + ∘ voe-2-3.voe-2-3-2.toMonad ∘ voe-2-3-2-fromMonad ∘ Monoidal→Kleisli - ∘ voe-2-3-1.toMonad - ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses - ( voe-2-3-1-fromMonad + ∘ voe-2-3.voe-2-3-1.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + ( voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ Monoidal→Kleisli - ∘ voe-2-3-1.toMonad - ) m ≡⟨ {!!} ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses - ( voe-2-3-1-fromMonad - ∘ voe-2-3-1.toMonad - ) m ≡⟨ {!!} ⟩ -- fromMonad and toMonad are inverses + ∘ voe-2-3.voe-2-3-1.toMonad + ) m ≡⟨ cong (λ φ → φ m) t ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses + ( voe-2-3-1-fromMonad + ∘ voe-2-3.voe-2-3-1.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ + where + t = cong (λ φ → voe-2-3-1-fromMonad ∘ φ ∘ voe-2-3.voe-2-3-1.toMonad) (recto-verso Monoidal≃Kleisli) - voe-isEquiv : isEquiv voe-2-3-1 voe-2-3-2 forth + voe-isEquiv : isEquiv (voe-2-3-1 omap pure) (voe-2-3-2 omap pure) forth voe-isEquiv = gradLemma forth back forthEq backEq - equiv-2-3 : voe-2-3-1 ≃ voe-2-3-2 + equiv-2-3 : voe-2-3-1 omap pure ≃ voe-2-3-2 omap pure equiv-2-3 = forth , voe-isEquiv From fa9a470875e6579aeca9fed0fa55ec96fec8181b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 00:54:42 +0100 Subject: [PATCH 66/91] Update backlog --- BACKLOG.md | 19 ++++++++++++++++++- src/Cat/Categories/Rel.agda | 1 - 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/BACKLOG.md b/BACKLOG.md index bfbb32b..64ea62f 100644 --- a/BACKLOG.md +++ b/BACKLOG.md @@ -4,6 +4,16 @@ Backlog Prove univalence for various categories Prove postulates in `Cat.Wishlist` +`propHasLevel` should be in `cubical` +`ntypeCommulative` might be there as well. + +Define and use Monad≡ + +Prove that the opposite category is a category. + +Prove univalence for the category of + * sets + * functors and natural transformations * Functor ✓ * Applicative Functor ✗ @@ -11,4 +21,11 @@ Prove postulates in `Cat.Wishlist` * Monoidal functor ✗ * Tensorial strength ✗ * Category ✓ - * Monoidal category ✗ \ No newline at end of file + * Monoidal category ✗ +* Monad + * Monoidal monad ✓ + * Kleisli monad ✓ + * Problem 2.3 in voe + * 1st contruction ~ monoidal ✓ + * 2nd contruction ~ klesli ✓ + * 1st ≃ 2nd ✗ diff --git a/src/Cat/Categories/Rel.agda b/src/Cat/Categories/Rel.agda index de3d1f2..1dbed3d 100644 --- a/src/Cat/Categories/Rel.agda +++ b/src/Cat/Categories/Rel.agda @@ -56,7 +56,6 @@ module _ {A B : Set} {S : Subset (A × B)} (ab : A × B) where backwards (a' , (a=a' , a'b∈S)) = subst (sym a=a') a'b∈S fwd-bwd : (x : (a , b) ∈ S) → (backwards ∘ forwards) x ≡ x - -- isbijective x = pathJ (λ y x₁ → (backwards ∘ forwards) x ≡ x) {!!} {!!} {!!} fwd-bwd x = pathJprop (λ y _ → y) x bwd-fwd : (x : Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S) From b61749bb911a99b28070dae97a1b97582664e77a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 01:09:40 +0100 Subject: [PATCH 67/91] Fixup some todo-notes --- BACKLOG.md | 4 ++++ src/Cat/Categories/Cat.agda | 5 ++--- src/Cat/Category.agda | 20 +++++++++++++------- src/Cat/Category/Functor.agda | 2 +- src/Cat/Category/Monad.agda | 2 +- 5 files changed, 21 insertions(+), 12 deletions(-) diff --git a/BACKLOG.md b/BACKLOG.md index 64ea62f..3eec938 100644 --- a/BACKLOG.md +++ b/BACKLOG.md @@ -15,6 +15,10 @@ Prove univalence for the category of * sets * functors and natural transformations +Prove: + * `isProp (Product ...)` + * `isProp (HasProducts ...)` + * Functor ✓ * Applicative Functor ✗ * Lax monoidal functor ✗ diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index ce493b6..5e442b3 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -46,9 +46,8 @@ module _ (ℓ ℓ' : Level) where open RawCategory RawCat isAssociative : IsAssociative isAssociative {f = F} {G} {H} = assc {F = F} {G = G} {H = H} - -- TODO: Rename `ident'` to `ident` after changing how names are exposed in Functor. - ident' : IsIdentity identity - ident' = ident-r , ident-l + ident : IsIdentity identity + ident = ident-r , ident-l -- NB! `ArrowsAreSets RawCat` is *not* provable. The type of functors, -- however, form a groupoid! Therefore there is no (1-)category of -- categories. There does, however, exist a 2-category of 1-categories. diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index 62a7221..e547a81 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -24,9 +24,6 @@ -- ------ -- -- Propositionality for all laws about the category. --- --- TODO: An equality principle for categories that focuses on the pure data-part. --- {-# OPTIONS --allow-unsolved-metas --cubical #-} module Cat.Category where @@ -91,7 +88,7 @@ record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where -- | Laws about the data - -- TODO: It seems counter-intuitive that the normal-form is on the + -- FIXME It seems counter-intuitive that the normal-form is on the -- right-hand-side. IsAssociative : Set (ℓa ⊔ ℓb) IsAssociative = ∀ {A B C D} {f : Arrow A B} {g : Arrow B C} {h : Arrow C D} @@ -286,6 +283,17 @@ record Category (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where open IsCategory isCategory public +Category≡ : {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} → Category.raw ℂ ≡ Category.raw 𝔻 → ℂ ≡ 𝔻 +Category≡ {ℂ = ℂ} {𝔻} eq i = record + { raw = eq i + ; isCategory = isCategoryEq i + } + where + open Category + module ℂ = Category ℂ + isCategoryEq : (λ i → IsCategory (eq i)) [ isCategory ℂ ≡ isCategory 𝔻 ] + isCategoryEq = {!!} + -- | Syntax for arrows- and composition in a given category. module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where open Category ℂ @@ -353,9 +361,7 @@ module Opposite {ℓa ℓb : Level} where RawCategory.𝟙 (rawInv _) = 𝟙 RawCategory._∘_ (rawInv _) = _∘_ - -- TODO: Define and use Monad≡ oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ - Category.raw (oppositeIsInvolution i) = rawInv i - Category.isCategory (oppositeIsInvolution x) = {!!} + oppositeIsInvolution = Category≡ rawInv open Opposite public diff --git a/src/Cat/Category/Functor.agda b/src/Cat/Category/Functor.agda index d627539..6724dee 100644 --- a/src/Cat/Category/Functor.agda +++ b/src/Cat/Category/Functor.agda @@ -61,7 +61,7 @@ module _ {ℓc ℓc' ℓd ℓd'} record IsFunctor (F : RawFunctor) : 𝓤 where open RawFunctor F public field - -- TODO Really ought to be preserves identity or something like this. + -- FIXME Really ought to be preserves identity or something like this. isIdentity : IsIdentity isDistributive : IsDistributive diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index c0c42bf..6ce46bb 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -250,7 +250,7 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where fmap g ∘ fmap f ≡⟨⟩ bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ - -- TODO: Naming! + -- FIXME Naming! R : EndoFunctor ℂ Functor.raw R = rawR Functor.isFunctor R = isFunctorR From fae492a1e33f212085a371a790debc944343e02b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:20:29 +0100 Subject: [PATCH 68/91] Restructure products --- src/Cat/Categories/Cat.agda | 17 ++++--- src/Cat/Categories/Sets.agda | 18 +++---- src/Cat/Category/Product.agda | 91 +++++++++++++++++------------------ 3 files changed, 63 insertions(+), 63 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 5e442b3..3ae0c4b 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -151,16 +151,17 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where private module P = CatProduct ℂ 𝔻 - instance - isProduct : IsProduct Catℓ P.proj₁ P.proj₂ - isProduct = P.isProduct + rawProduct : RawProduct {ℂ = Catℓ} ℂ 𝔻 + RawProduct.obj rawProduct = P.obj + RawProduct.proj₁ rawProduct = P.proj₁ + RawProduct.proj₂ rawProduct = P.proj₂ + + isProduct : IsProduct Catℓ rawProduct + IsProduct.isProduct isProduct = P.isProduct product : Product {ℂ = Catℓ} ℂ 𝔻 - product = record - { obj = P.obj - ; proj₁ = P.proj₁ - ; proj₂ = P.proj₂ - } + Product.raw product = rawProduct + Product.isProduct product = isProduct instance hasProducts : HasProducts Catℓ diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index 11ddc3f..970ae96 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -64,17 +64,17 @@ module _ {ℓ : Level} where lem : proj₁ Function.∘′ (f &&& g) ≡ f × proj₂ Function.∘′ (f &&& g) ≡ g proj₁ lem = refl proj₂ lem = refl - instance - isProduct : IsProduct 𝓢 {0A} {0B} {0A×0B} proj₁ proj₂ - isProduct {X = X} f g = (f &&& g) , lem {0X = X} f g + rawProduct : RawProduct {ℂ = 𝓢} 0A 0B + RawProduct.obj rawProduct = 0A×0B + RawProduct.proj₁ rawProduct = Data.Product.proj₁ + RawProduct.proj₂ rawProduct = Data.Product.proj₂ + isProduct : IsProduct 𝓢 rawProduct + IsProduct.isProduct isProduct {X = X} f g + = (f &&& g) , lem {0X = X} f g product : Product {ℂ = 𝓢} 0A 0B - product = record - { obj = 0A×0B - ; proj₁ = Data.Product.proj₁ - ; proj₂ = Data.Product.proj₂ - ; isProduct = λ { {X} → isProduct {X = X}} - } + Product.raw product = rawProduct + Product.isProduct product = isProduct instance SetsHasProducts : HasProducts 𝓢 diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 490f415..80baaab 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -2,61 +2,60 @@ module Cat.Category.Product where open import Agda.Primitive open import Cubical -open import Data.Product as P hiding (_×_) +open import Data.Product as P hiding (_×_ ; proj₁ ; proj₂) -open import Cat.Category +open import Cat.Category hiding (module Propositionality) open Category -module _ {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') {A B obj : Object ℂ} where - IsProduct : (π₁ : ℂ [ obj , A ]) (π₂ : ℂ [ obj , B ]) → Set (ℓ ⊔ ℓ') - IsProduct π₁ π₂ - = ∀ {X : Object ℂ} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) - → ∃![ x ] (ℂ [ π₁ ∘ x ] ≡ x₁ P.× ℂ [ π₂ ∘ x ] ≡ x₂) +module _ {ℓa ℓb : Level} where + record RawProduct {ℂ : Category ℓa ℓb} (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where + no-eta-equality + field + obj : Object ℂ + proj₁ : ℂ [ obj , A ] + proj₂ : ℂ [ obj , B ] --- Tip from Andrea; Consider this style for efficiency: --- record IsProduct {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) --- {A B obj : Object ℂ} (π₁ : Arrow ℂ obj A) (π₂ : Arrow ℂ obj B) : Set (ℓa ⊔ ℓb) where --- field --- issProduct : ∀ {X : Object ℂ} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) --- → ∃![ x ] (ℂ [ π₁ ∘ x ] ≡ x₁ P.× ℂ [ π₂ ∘ x ] ≡ x₂) + record IsProduct (ℂ : Category ℓa ℓb) {A B : Object ℂ} (raw : RawProduct {ℂ = ℂ} A B) : Set (ℓa ⊔ ℓb) where + open RawProduct raw public + field + isProduct : ∀ {X : Object ℂ} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) + → ∃![ x ] (ℂ [ proj₁ ∘ x ] ≡ x₁ P.× ℂ [ proj₂ ∘ x ] ≡ x₂) --- open IsProduct + -- | Arrow product + _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ]) + → ℂ [ X , obj ] + _P[_×_] π₁ π₂ = P.proj₁ (isProduct π₁ π₂) --- TODO `isProp (Product ...)` --- TODO `isProp (HasProducts ...)` -record Product {ℓ ℓ' : Level} {ℂ : Category ℓ ℓ'} (A B : Object ℂ) : Set (ℓ ⊔ ℓ') where - no-eta-equality - field - obj : Object ℂ - proj₁ : ℂ [ obj , A ] - proj₂ : ℂ [ obj , B ] - {{isProduct}} : IsProduct ℂ proj₁ proj₂ + record Product {ℂ : Category ℓa ℓb} (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where + field + raw : RawProduct {ℂ = ℂ} A B + isProduct : IsProduct ℂ {A} {B} raw - -- | Arrow product - _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ]) - → ℂ [ X , obj ] - _P[_×_] π₁ π₂ = proj₁ (isProduct π₁ π₂) + open IsProduct isProduct public -record HasProducts {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') : Set (ℓ ⊔ ℓ') where - field - product : ∀ (A B : Object ℂ) → Product {ℂ = ℂ} A B + record HasProducts (ℂ : Category ℓa ℓb) : Set (ℓa ⊔ ℓb) where + field + product : ∀ (A B : Object ℂ) → Product {ℂ = ℂ} A B - open Product hiding (obj) + module _ (A B : Object ℂ) where + open Product (product A B) + _×_ : Object ℂ + _×_ = obj - module _ (A B : Object ℂ) where - open Product (product A B) - _×_ : Object ℂ - _×_ = obj + -- | Parallel product of arrows + -- + -- The product mentioned in awodey in Def 6.1 is not the regular product of + -- arrows. It's a "parallel" product + module _ {A A' B B' : Object ℂ} where + open Product + open Product (product A B) hiding (_P[_×_]) renaming (proj₁ to fst ; proj₂ to snd) + _|×|_ : ℂ [ A , A' ] → ℂ [ B , B' ] → ℂ [ A × B , A' × B' ] + a |×| b = product A' B' + P[ ℂ [ a ∘ fst ] + × ℂ [ b ∘ snd ] + ] - -- | Parallel product of arrows - -- - -- The product mentioned in awodey in Def 6.1 is not the regular product of - -- arrows. It's a "parallel" product - module _ {A A' B B' : Object ℂ} where - open Product (product A B) hiding (_P[_×_]) renaming (proj₁ to fst ; proj₂ to snd) - _|×|_ : ℂ [ A , A' ] → ℂ [ B , B' ] → ℂ [ A × B , A' × B' ] - a |×| b = product A' B' - P[ ℂ [ a ∘ fst ] - × ℂ [ b ∘ snd ] - ] +module Propositionality where + -- TODO `isProp (Product ...)` + -- TODO `isProp (HasProducts ...)` From faf4c541886a9129e8b8edd466d3d80881d5b507 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:22:21 +0100 Subject: [PATCH 69/91] Make parameters explicit --- src/Cat/Categories/Cat.agda | 4 ++-- src/Cat/Categories/Sets.agda | 6 ++++-- src/Cat/Category/Product.agda | 10 +++++----- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 3ae0c4b..95c0e15 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -151,7 +151,7 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where private module P = CatProduct ℂ 𝔻 - rawProduct : RawProduct {ℂ = Catℓ} ℂ 𝔻 + rawProduct : RawProduct Catℓ ℂ 𝔻 RawProduct.obj rawProduct = P.obj RawProduct.proj₁ rawProduct = P.proj₁ RawProduct.proj₂ rawProduct = P.proj₂ @@ -159,7 +159,7 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where isProduct : IsProduct Catℓ rawProduct IsProduct.isProduct isProduct = P.isProduct - product : Product {ℂ = Catℓ} ℂ 𝔻 + product : Product Catℓ ℂ 𝔻 Product.raw product = rawProduct Product.isProduct product = isProduct diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index 970ae96..adcbfc3 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -64,15 +64,17 @@ module _ {ℓ : Level} where lem : proj₁ Function.∘′ (f &&& g) ≡ f × proj₂ Function.∘′ (f &&& g) ≡ g proj₁ lem = refl proj₂ lem = refl - rawProduct : RawProduct {ℂ = 𝓢} 0A 0B + + rawProduct : RawProduct 𝓢 0A 0B RawProduct.obj rawProduct = 0A×0B RawProduct.proj₁ rawProduct = Data.Product.proj₁ RawProduct.proj₂ rawProduct = Data.Product.proj₂ + isProduct : IsProduct 𝓢 rawProduct IsProduct.isProduct isProduct {X = X} f g = (f &&& g) , lem {0X = X} f g - product : Product {ℂ = 𝓢} 0A 0B + product : Product 𝓢 0A 0B Product.raw product = rawProduct Product.isProduct product = isProduct diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 80baaab..c68afd7 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -9,14 +9,14 @@ open import Cat.Category hiding (module Propositionality) open Category module _ {ℓa ℓb : Level} where - record RawProduct {ℂ : Category ℓa ℓb} (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where + record RawProduct (ℂ : Category ℓa ℓb) (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where no-eta-equality field obj : Object ℂ proj₁ : ℂ [ obj , A ] proj₂ : ℂ [ obj , B ] - record IsProduct (ℂ : Category ℓa ℓb) {A B : Object ℂ} (raw : RawProduct {ℂ = ℂ} A B) : Set (ℓa ⊔ ℓb) where + record IsProduct (ℂ : Category ℓa ℓb) {A B : Object ℂ} (raw : RawProduct ℂ A B) : Set (ℓa ⊔ ℓb) where open RawProduct raw public field isProduct : ∀ {X : Object ℂ} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) @@ -27,16 +27,16 @@ module _ {ℓa ℓb : Level} where → ℂ [ X , obj ] _P[_×_] π₁ π₂ = P.proj₁ (isProduct π₁ π₂) - record Product {ℂ : Category ℓa ℓb} (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where + record Product (ℂ : Category ℓa ℓb) (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where field - raw : RawProduct {ℂ = ℂ} A B + raw : RawProduct ℂ A B isProduct : IsProduct ℂ {A} {B} raw open IsProduct isProduct public record HasProducts (ℂ : Category ℓa ℓb) : Set (ℓa ⊔ ℓb) where field - product : ∀ (A B : Object ℂ) → Product {ℂ = ℂ} A B + product : ∀ (A B : Object ℂ) → Product ℂ A B module _ (A B : Object ℂ) where open Product (product A B) From 181bd1af539b2c2f433750c94b845c1851ec12a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:23:37 +0100 Subject: [PATCH 70/91] Factor out category --- src/Cat/Category/Product.agda | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index c68afd7..6dadf74 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -6,20 +6,21 @@ open import Data.Product as P hiding (_×_ ; proj₁ ; proj₂) open import Cat.Category hiding (module Propositionality) -open Category +module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -module _ {ℓa ℓb : Level} where - record RawProduct (ℂ : Category ℓa ℓb) (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where + open Category ℂ + + record RawProduct (A B : Object) : Set (ℓa ⊔ ℓb) where no-eta-equality field - obj : Object ℂ + obj : Object proj₁ : ℂ [ obj , A ] proj₂ : ℂ [ obj , B ] - record IsProduct (ℂ : Category ℓa ℓb) {A B : Object ℂ} (raw : RawProduct ℂ A B) : Set (ℓa ⊔ ℓb) where + record IsProduct {A B : Object} (raw : RawProduct A B) : Set (ℓa ⊔ ℓb) where open RawProduct raw public field - isProduct : ∀ {X : Object ℂ} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) + isProduct : ∀ {X : Object} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) → ∃![ x ] (ℂ [ proj₁ ∘ x ] ≡ x₁ P.× ℂ [ proj₂ ∘ x ] ≡ x₂) -- | Arrow product @@ -27,27 +28,27 @@ module _ {ℓa ℓb : Level} where → ℂ [ X , obj ] _P[_×_] π₁ π₂ = P.proj₁ (isProduct π₁ π₂) - record Product (ℂ : Category ℓa ℓb) (A B : Object ℂ) : Set (ℓa ⊔ ℓb) where + record Product (A B : Object) : Set (ℓa ⊔ ℓb) where field - raw : RawProduct ℂ A B - isProduct : IsProduct ℂ {A} {B} raw + raw : RawProduct A B + isProduct : IsProduct {A} {B} raw open IsProduct isProduct public - record HasProducts (ℂ : Category ℓa ℓb) : Set (ℓa ⊔ ℓb) where + record HasProducts : Set (ℓa ⊔ ℓb) where field - product : ∀ (A B : Object ℂ) → Product ℂ A B + product : ∀ (A B : Object) → Product A B - module _ (A B : Object ℂ) where + module _ (A B : Object) where open Product (product A B) - _×_ : Object ℂ + _×_ : Object _×_ = obj -- | Parallel product of arrows -- -- The product mentioned in awodey in Def 6.1 is not the regular product of -- arrows. It's a "parallel" product - module _ {A A' B B' : Object ℂ} where + module _ {A A' B B' : Object} where open Product open Product (product A B) hiding (_P[_×_]) renaming (proj₁ to fst ; proj₂ to snd) _|×|_ : ℂ [ A , A' ] → ℂ [ B , B' ] → ℂ [ A × B , A' × B' ] From 4e7b350188a18cd62fe3e3ce47d97b98dc78d237 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:28:05 +0100 Subject: [PATCH 71/91] Factor out objects --- src/Cat/Categories/Cat.agda | 2 +- src/Cat/Categories/Sets.agda | 2 +- src/Cat/Category/Product.agda | 41 ++++++++++++++++++----------------- 3 files changed, 23 insertions(+), 22 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 95c0e15..8c29f7b 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -156,7 +156,7 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where RawProduct.proj₁ rawProduct = P.proj₁ RawProduct.proj₂ rawProduct = P.proj₂ - isProduct : IsProduct Catℓ rawProduct + isProduct : IsProduct Catℓ _ _ rawProduct IsProduct.isProduct isProduct = P.isProduct product : Product Catℓ ℂ 𝔻 diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index adcbfc3..d5d92ec 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -70,7 +70,7 @@ module _ {ℓ : Level} where RawProduct.proj₁ rawProduct = Data.Product.proj₁ RawProduct.proj₂ rawProduct = Data.Product.proj₂ - isProduct : IsProduct 𝓢 rawProduct + isProduct : IsProduct 𝓢 _ _ rawProduct IsProduct.isProduct isProduct {X = X} f g = (f &&& g) , lem {0X = X} f g diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 6dadf74..263f06d 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -10,30 +10,31 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where open Category ℂ - record RawProduct (A B : Object) : Set (ℓa ⊔ ℓb) where - no-eta-equality - field - obj : Object - proj₁ : ℂ [ obj , A ] - proj₂ : ℂ [ obj , B ] + module _ (A B : Object) where + record RawProduct : Set (ℓa ⊔ ℓb) where + no-eta-equality + field + obj : Object + proj₁ : ℂ [ obj , A ] + proj₂ : ℂ [ obj , B ] - record IsProduct {A B : Object} (raw : RawProduct A B) : Set (ℓa ⊔ ℓb) where - open RawProduct raw public - field - isProduct : ∀ {X : Object} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) - → ∃![ x ] (ℂ [ proj₁ ∘ x ] ≡ x₁ P.× ℂ [ proj₂ ∘ x ] ≡ x₂) + record IsProduct (raw : RawProduct) : Set (ℓa ⊔ ℓb) where + open RawProduct raw public + field + isProduct : ∀ {X : Object} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) + → ∃![ x ] (ℂ [ proj₁ ∘ x ] ≡ x₁ P.× ℂ [ proj₂ ∘ x ] ≡ x₂) - -- | Arrow product - _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ]) - → ℂ [ X , obj ] - _P[_×_] π₁ π₂ = P.proj₁ (isProduct π₁ π₂) + -- | Arrow product + _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ]) + → ℂ [ X , obj ] + _P[_×_] π₁ π₂ = P.proj₁ (isProduct π₁ π₂) - record Product (A B : Object) : Set (ℓa ⊔ ℓb) where - field - raw : RawProduct A B - isProduct : IsProduct {A} {B} raw + record Product : Set (ℓa ⊔ ℓb) where + field + raw : RawProduct + isProduct : IsProduct raw - open IsProduct isProduct public + open IsProduct isProduct public record HasProducts : Set (ℓa ⊔ ℓb) where field From 1ef57a19f42fa4d3b774a3ba704294b6e8474a21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:30:35 +0100 Subject: [PATCH 72/91] Cosmetics --- src/Cat/Category/Product.agda | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 263f06d..fae47aa 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -40,10 +40,8 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where field product : ∀ (A B : Object) → Product A B - module _ (A B : Object) where - open Product (product A B) - _×_ : Object - _×_ = obj + _×_ : Object → Object → Object + A × B = Product.obj (product A B) -- | Parallel product of arrows -- @@ -53,9 +51,9 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where open Product open Product (product A B) hiding (_P[_×_]) renaming (proj₁ to fst ; proj₂ to snd) _|×|_ : ℂ [ A , A' ] → ℂ [ B , B' ] → ℂ [ A × B , A' × B' ] - a |×| b = product A' B' - P[ ℂ [ a ∘ fst ] - × ℂ [ b ∘ snd ] + f |×| g = product A' B' + P[ ℂ [ f ∘ fst ] + × ℂ [ g ∘ snd ] ] module Propositionality where From 486238e114f67f956d1d9394b247b0b7a748c099 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:38:46 +0100 Subject: [PATCH 73/91] Add goals for propositionality of products --- src/Cat/Category/Product.agda | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index fae47aa..8150e1b 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -18,11 +18,13 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where proj₁ : ℂ [ obj , A ] proj₂ : ℂ [ obj , B ] + -- FIXME Not sure this is actually a proposition - so this name is + -- misleading. record IsProduct (raw : RawProduct) : Set (ℓa ⊔ ℓb) where open RawProduct raw public field - isProduct : ∀ {X : Object} (x₁ : ℂ [ X , A ]) (x₂ : ℂ [ X , B ]) - → ∃![ x ] (ℂ [ proj₁ ∘ x ] ≡ x₁ P.× ℂ [ proj₂ ∘ x ] ≡ x₂) + isProduct : ∀ {X : Object} (f : ℂ [ X , A ]) (g : ℂ [ X , B ]) + → ∃![ f×g ] (ℂ [ proj₁ ∘ f×g ] ≡ f P.× ℂ [ proj₂ ∘ f×g ] ≡ g) -- | Arrow product _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ]) @@ -56,6 +58,9 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where × ℂ [ g ∘ snd ] ] -module Propositionality where - -- TODO `isProp (Product ...)` - -- TODO `isProp (HasProducts ...)` +module Propositionality {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object ℂ} where + propProduct : isProp (Product ℂ A B) + propProduct = {!!} + + propHasProducts : isProp (HasProducts ℂ) + propHasProducts = {!!} From 63b5f5c68d9ba9f16469739b508a73b425ad9b2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:45:15 +0100 Subject: [PATCH 74/91] Use long name for product object --- src/Cat/Categories/Cat.agda | 6 +++--- src/Cat/Categories/Sets.agda | 6 +++--- src/Cat/Category/Product.agda | 11 ++++++----- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 8c29f7b..121d83d 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -152,9 +152,9 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where module P = CatProduct ℂ 𝔻 rawProduct : RawProduct Catℓ ℂ 𝔻 - RawProduct.obj rawProduct = P.obj - RawProduct.proj₁ rawProduct = P.proj₁ - RawProduct.proj₂ rawProduct = P.proj₂ + RawProduct.object rawProduct = P.obj + RawProduct.proj₁ rawProduct = P.proj₁ + RawProduct.proj₂ rawProduct = P.proj₂ isProduct : IsProduct Catℓ _ _ rawProduct IsProduct.isProduct isProduct = P.isProduct diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index d5d92ec..ac6bd72 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -66,9 +66,9 @@ module _ {ℓ : Level} where proj₂ lem = refl rawProduct : RawProduct 𝓢 0A 0B - RawProduct.obj rawProduct = 0A×0B - RawProduct.proj₁ rawProduct = Data.Product.proj₁ - RawProduct.proj₂ rawProduct = Data.Product.proj₂ + RawProduct.object rawProduct = 0A×0B + RawProduct.proj₁ rawProduct = Data.Product.proj₁ + RawProduct.proj₂ rawProduct = Data.Product.proj₂ isProduct : IsProduct 𝓢 _ _ rawProduct IsProduct.isProduct isProduct {X = X} f g diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 8150e1b..118b72b 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -1,3 +1,4 @@ +{-# OPTIONS --allow-unsolved-metas #-} module Cat.Category.Product where open import Agda.Primitive @@ -14,9 +15,9 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where record RawProduct : Set (ℓa ⊔ ℓb) where no-eta-equality field - obj : Object - proj₁ : ℂ [ obj , A ] - proj₂ : ℂ [ obj , B ] + object : Object + proj₁ : ℂ [ object , A ] + proj₂ : ℂ [ object , B ] -- FIXME Not sure this is actually a proposition - so this name is -- misleading. @@ -28,7 +29,7 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- | Arrow product _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ]) - → ℂ [ X , obj ] + → ℂ [ X , object ] _P[_×_] π₁ π₂ = P.proj₁ (isProduct π₁ π₂) record Product : Set (ℓa ⊔ ℓb) where @@ -43,7 +44,7 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where product : ∀ (A B : Object) → Product A B _×_ : Object → Object → Object - A × B = Product.obj (product A B) + A × B = Product.object (product A B) -- | Parallel product of arrows -- From 2fcc5836465983df68bca52883f7a13e88daed2d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 10:50:18 +0100 Subject: [PATCH 75/91] Add note --- src/Cat/Category/Product.agda | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 118b72b..dff488a 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -60,6 +60,7 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where ] module Propositionality {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object ℂ} where + -- TODO I'm not sure this is actually provable. Check with Thierry. propProduct : isProp (Product ℂ A B) propProduct = {!!} From 5ad506a09f842e75daad93ad03642b6862466633 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 11:03:56 +0100 Subject: [PATCH 76/91] Rename func* and func-> to omap and fmap respectively --- src/Cat/Categories/Cat.agda | 92 ++++++++++---------- src/Cat/Categories/CwF.agda | 18 ++-- src/Cat/Categories/Sets.agda | 8 +- src/Cat/Category/Functor.agda | 46 +++++----- src/Cat/Category/Monad.agda | 93 ++++++++++----------- src/Cat/Category/NaturalTransformation.agda | 22 ++--- src/Cat/Category/Yoneda.agda | 6 +- 7 files changed, 142 insertions(+), 143 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 121d83d..5e9ba24 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -17,7 +17,7 @@ open import Cat.Category.NaturalTransformation open import Cat.Equality open Equality.Data.Product -open Functor using (func→ ; func*) +open Functor using (fmap ; omap) open Category using (Object ; 𝟙) -- The category of categories @@ -104,13 +104,13 @@ module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where proj₁ : Functor obj ℂ proj₁ = record - { raw = record { func* = fst ; func→ = fst } + { raw = record { omap = fst ; fmap = fst } ; isFunctor = record { isIdentity = refl ; isDistributive = refl } } proj₂ : Functor obj 𝔻 proj₂ = record - { raw = record { func* = snd ; func→ = snd } + { raw = record { omap = snd ; fmap = snd } ; isFunctor = record { isIdentity = refl ; isDistributive = refl } } @@ -119,8 +119,8 @@ module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where x : Functor X obj x = record { raw = record - { func* = λ x → x₁.func* x , x₂.func* x - ; func→ = λ x → x₁.func→ x , x₂.func→ x + { omap = λ x → x₁.omap x , x₂.omap x + ; fmap = λ x → x₁.fmap x , x₂.fmap x } ; isFunctor = record { isIdentity = Σ≡ x₁.isIdentity x₂.isIdentity @@ -175,8 +175,8 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where Categoryℓ = Category ℓ ℓ open Fun ℂ 𝔻 renaming (identity to idN) private - :func*: : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 - :func*: (F , A) = func* F A + :omap: : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 + :omap: (F , A) = omap F A prodObj : Categoryℓ prodObj = Fun @@ -193,28 +193,28 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where B : Object ℂ B = proj₂ cod - :func→: : (pobj : NaturalTransformation F G × ℂ [ A , B ]) - → 𝔻 [ func* F A , func* G B ] - :func→: ((θ , θNat) , f) = result + :fmap: : (pobj : NaturalTransformation F G × ℂ [ A , B ]) + → 𝔻 [ omap F A , omap G B ] + :fmap: ((θ , θNat) , f) = result where - θA : 𝔻 [ func* F A , func* G A ] + θA : 𝔻 [ omap F A , omap G A ] θA = θ A - θB : 𝔻 [ func* F B , func* G B ] + θB : 𝔻 [ omap F B , omap G B ] θB = θ B - F→f : 𝔻 [ func* F A , func* F B ] - F→f = func→ F f - G→f : 𝔻 [ func* G A , func* G B ] - G→f = func→ G f - l : 𝔻 [ func* F A , func* G B ] + F→f : 𝔻 [ omap F A , omap F B ] + F→f = fmap F f + G→f : 𝔻 [ omap G A , omap G B ] + G→f = fmap G f + l : 𝔻 [ omap F A , omap G B ] l = 𝔻 [ θB ∘ F→f ] - r : 𝔻 [ func* F A , func* G B ] + r : 𝔻 [ omap F A , omap G B ] r = 𝔻 [ G→f ∘ θA ] -- There are two choices at this point, -- but I suppose the whole point is that -- by `θNat f` we have `l ≡ r` - -- lem : 𝔻 [ θ B ∘ F .func→ f ] ≡ 𝔻 [ G .func→ f ∘ θ A ] + -- lem : 𝔻 [ θ B ∘ F .fmap f ] ≡ 𝔻 [ G .fmap f ∘ θ A ] -- lem = θNat f - result : 𝔻 [ func* F A , func* G B ] + result : 𝔻 [ omap F A , omap G B ] result = l open CatProduct renaming (obj to _×p_) using () @@ -227,19 +227,19 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where C = proj₂ c -- NaturalTransformation F G × ℂ .Arrow A B - -- :ident: : :func→: {c} {c} (identityNat F , ℂ .𝟙) ≡ 𝔻 .𝟙 + -- :ident: : :fmap: {c} {c} (identityNat F , ℂ .𝟙) ≡ 𝔻 .𝟙 -- :ident: = trans (proj₂ 𝔻.isIdentity) (F .isIdentity) -- where -- open module 𝔻 = IsCategory (𝔻 .isCategory) -- Unfortunately the equational version has some ambigous arguments. - :ident: : :func→: {c} {c} (NT.identity F , 𝟙 ℂ {A = proj₂ c}) ≡ 𝟙 𝔻 + :ident: : :fmap: {c} {c} (NT.identity F , 𝟙 ℂ {A = proj₂ c}) ≡ 𝟙 𝔻 :ident: = begin - :func→: {c} {c} (𝟙 (prodObj ×p ℂ) {c}) ≡⟨⟩ - :func→: {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ - 𝔻 [ identityTrans F C ∘ func→ F (𝟙 ℂ)] ≡⟨⟩ - 𝔻 [ 𝟙 𝔻 ∘ func→ F (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ - func→ F (𝟙 ℂ) ≡⟨ F.isIdentity ⟩ + :fmap: {c} {c} (𝟙 (prodObj ×p ℂ) {c}) ≡⟨⟩ + :fmap: {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ + 𝔻 [ identityTrans F C ∘ fmap F (𝟙 ℂ)] ≡⟨⟩ + 𝔻 [ 𝟙 𝔻 ∘ fmap F (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ + fmap F (𝟙 ℂ) ≡⟨ F.isIdentity ⟩ 𝟙 𝔻 ∎ where open module 𝔻 = Category 𝔻 @@ -279,28 +279,28 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where ηθNat = proj₂ ηθNT :isDistributive: : - 𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ func→ F ( ℂ [ g ∘ f ] ) ] - ≡ 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ θ B ∘ func→ F f ] ] + 𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ fmap F ( ℂ [ g ∘ f ] ) ] + ≡ 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ 𝔻 [ θ B ∘ fmap F f ] ] :isDistributive: = begin - 𝔻 [ (ηθ C) ∘ func→ F (ℂ [ g ∘ f ]) ] + 𝔻 [ (ηθ C) ∘ fmap F (ℂ [ g ∘ f ]) ] ≡⟨ ηθNat (ℂ [ g ∘ f ]) ⟩ - 𝔻 [ func→ H (ℂ [ g ∘ f ]) ∘ (ηθ A) ] + 𝔻 [ fmap H (ℂ [ g ∘ f ]) ∘ (ηθ A) ] ≡⟨ cong (λ φ → 𝔻 [ φ ∘ ηθ A ]) (H.isDistributive) ⟩ - 𝔻 [ 𝔻 [ func→ H g ∘ func→ H f ] ∘ (ηθ A) ] + 𝔻 [ 𝔻 [ fmap H g ∘ fmap H f ] ∘ (ηθ A) ] ≡⟨ sym isAssociative ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ func→ H f ∘ ηθ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) isAssociative ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ 𝔻 [ func→ H f ∘ η A ] ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) (cong (λ φ → 𝔻 [ φ ∘ θ A ]) (sym (ηNat f))) ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ 𝔻 [ η B ∘ func→ G f ] ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ func→ H g ∘ φ ]) (sym isAssociative) ⟩ - 𝔻 [ func→ H g ∘ 𝔻 [ η B ∘ 𝔻 [ func→ G f ∘ θ A ] ] ] + 𝔻 [ fmap H g ∘ 𝔻 [ fmap H f ∘ ηθ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ fmap H g ∘ φ ]) isAssociative ⟩ + 𝔻 [ fmap H g ∘ 𝔻 [ 𝔻 [ fmap H f ∘ η A ] ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ fmap H g ∘ φ ]) (cong (λ φ → 𝔻 [ φ ∘ θ A ]) (sym (ηNat f))) ⟩ + 𝔻 [ fmap H g ∘ 𝔻 [ 𝔻 [ η B ∘ fmap G f ] ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ fmap H g ∘ φ ]) (sym isAssociative) ⟩ + 𝔻 [ fmap H g ∘ 𝔻 [ η B ∘ 𝔻 [ fmap G f ∘ θ A ] ] ] ≡⟨ isAssociative ⟩ - 𝔻 [ 𝔻 [ func→ H g ∘ η B ] ∘ 𝔻 [ func→ G f ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ φ ∘ 𝔻 [ func→ G f ∘ θ A ] ]) (sym (ηNat g)) ⟩ - 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ func→ G f ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ φ ]) (sym (θNat f)) ⟩ - 𝔻 [ 𝔻 [ η C ∘ func→ G g ] ∘ 𝔻 [ θ B ∘ func→ F f ] ] ∎ + 𝔻 [ 𝔻 [ fmap H g ∘ η B ] ∘ 𝔻 [ fmap G f ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ φ ∘ 𝔻 [ fmap G f ∘ θ A ] ]) (sym (ηNat g)) ⟩ + 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ 𝔻 [ fmap G f ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ φ ]) (sym (θNat f)) ⟩ + 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ 𝔻 [ θ B ∘ fmap F f ] ] ∎ where open Category 𝔻 module H = Functor H @@ -309,8 +309,8 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where -- :eval: : Functor (prodObj ×p ℂ) 𝔻 eval = record { raw = record - { func* = :func*: - ; func→ = λ {dom} {cod} → :func→: {dom} {cod} + { omap = :omap: + ; fmap = λ {dom} {cod} → :fmap: {dom} {cod} } ; isFunctor = record { isIdentity = λ {o} → :ident: {o} diff --git a/src/Cat/Categories/CwF.agda b/src/Cat/Categories/CwF.agda index 4b9ce32..ea369ef 100644 --- a/src/Cat/Categories/CwF.agda +++ b/src/Cat/Categories/CwF.agda @@ -28,20 +28,20 @@ module _ {ℓa ℓb : Level} where private module T = Functor T Type : (Γ : Object ℂ) → Set ℓa - Type Γ = proj₁ (proj₁ (T.func* Γ)) + Type Γ = proj₁ (proj₁ (T.omap Γ)) module _ {Γ : Object ℂ} {A : Type Γ} where -- module _ {A B : Object ℂ} {γ : ℂ [ A , B ]} where - -- k : Σ (proj₁ (func* T B) → proj₁ (func* T A)) + -- k : Σ (proj₁ (omap T B) → proj₁ (omap T A)) -- (λ f → - -- {x : proj₁ (func* T B)} → - -- proj₂ (func* T B) x → proj₂ (func* T A) (f x)) - -- k = T.func→ γ - -- k₁ : proj₁ (func* T B) → proj₁ (func* T A) + -- {x : proj₁ (omap T B)} → + -- proj₂ (omap T B) x → proj₂ (omap T A) (f x)) + -- k = T.fmap γ + -- k₁ : proj₁ (omap T B) → proj₁ (omap T A) -- k₁ = proj₁ k - -- k₂ : ({x : proj₁ (func* T B)} → - -- proj₂ (func* T B) x → proj₂ (func* T A) (k₁ x)) + -- k₂ : ({x : proj₁ (omap T B)} → + -- proj₂ (omap T B) x → proj₂ (omap T A) (k₁ x)) -- k₂ = proj₂ k record ContextComprehension : Set (ℓa ⊔ ℓb) where @@ -51,7 +51,7 @@ module _ {ℓa ℓb : Level} where -- proj2 : ???? -- if γ : ℂ [ A , B ] - -- then T .func→ γ (written T[γ]) interpret substitutions in types and terms respectively. + -- then T .fmap γ (written T[γ]) interpret substitutions in types and terms respectively. -- field -- ump : {Δ : ℂ .Object} → (γ : ℂ [ Δ , Γ ]) -- → (a : {!!}) → {!!} diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index ac6bd72..6f9ade2 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -97,8 +97,8 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where representable : Category.Object ℂ → Representable representable A = record { raw = record - { func* = λ B → ℂ [ A , B ] , arrowsAreSets - ; func→ = ℂ [_∘_] + { omap = λ B → ℂ [ A , B ] , arrowsAreSets + ; fmap = ℂ [_∘_] } ; isFunctor = record { isIdentity = funExt λ _ → proj₂ isIdentity @@ -110,8 +110,8 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where presheaf : Category.Object (opposite ℂ) → Presheaf presheaf B = record { raw = record - { func* = λ A → ℂ [ A , B ] , arrowsAreSets - ; func→ = λ f g → ℂ [ g ∘ f ] + { omap = λ A → ℂ [ A , B ] , arrowsAreSets + ; fmap = λ f g → ℂ [ g ∘ f ] } ; isFunctor = record { isIdentity = funExt λ x → proj₁ isIdentity diff --git a/src/Cat/Category/Functor.agda b/src/Cat/Category/Functor.agda index 6724dee..fc23c2e 100644 --- a/src/Cat/Category/Functor.agda +++ b/src/Cat/Category/Functor.agda @@ -24,39 +24,39 @@ module _ {ℓc ℓc' ℓd ℓd'} → ℂ [ A , B ] → 𝔻 [ omap A , omap B ] record RawFunctor : 𝓤 where field - func* : Object ℂ → Object 𝔻 - func→ : ∀ {A B} → ℂ [ A , B ] → 𝔻 [ func* A , func* B ] + omap : Object ℂ → Object 𝔻 + fmap : ∀ {A B} → ℂ [ A , B ] → 𝔻 [ omap A , omap B ] IsIdentity : Set _ - IsIdentity = {A : Object ℂ} → func→ (𝟙 ℂ {A}) ≡ 𝟙 𝔻 {func* A} + IsIdentity = {A : Object ℂ} → fmap (𝟙 ℂ {A}) ≡ 𝟙 𝔻 {omap A} IsDistributive : Set _ IsDistributive = {A B C : Object ℂ} {f : ℂ [ A , B ]} {g : ℂ [ B , C ]} - → func→ (ℂ [ g ∘ f ]) ≡ 𝔻 [ func→ g ∘ func→ f ] + → fmap (ℂ [ g ∘ f ]) ≡ 𝔻 [ fmap g ∘ fmap f ] -- | Equality principle for raw functors -- - -- The type of `func→` depend on the value of `func*`. We can wrap this up + -- The type of `fmap` depend on the value of `omap`. We can wrap this up -- into an equality principle for this type like is done for e.g. `Σ` using -- `pathJ`. module _ {x y : RawFunctor} where open RawFunctor private - P : (omap : Omap) → (eq : func* x ≡ omap) → Set _ + P : (omap' : Omap) → (eq : omap x ≡ omap') → Set _ P y eq = (fmap' : Fmap y) → (λ i → Fmap (eq i)) - [ func→ x ≡ fmap' ] + [ fmap x ≡ fmap' ] module _ - (eq : (λ i → Omap) [ func* x ≡ func* y ]) - (kk : P (func* x) refl) + (eq : (λ i → Omap) [ omap x ≡ omap y ]) + (kk : P (omap x) refl) where private - p : P (func* y) eq - p = pathJ P kk (func* y) eq - eq→ : (λ i → Fmap (eq i)) [ func→ x ≡ func→ y ] - eq→ = p (func→ y) + p : P (omap y) eq + p = pathJ P kk (omap y) eq + eq→ : (λ i → Fmap (eq i)) [ fmap x ≡ fmap y ] + eq→ = p (fmap y) RawFunctor≡ : x ≡ y - func* (RawFunctor≡ i) = eq i - func→ (RawFunctor≡ i) = eq→ i + omap (RawFunctor≡ i) = eq i + fmap (RawFunctor≡ i) = eq→ i record IsFunctor (F : RawFunctor) : 𝓤 where open RawFunctor F public @@ -124,10 +124,10 @@ module _ {ℓ ℓ' : Level} {ℂ 𝔻 : Category ℓ ℓ'} where module _ {ℓ ℓ' : Level} {A B C : Category ℓ ℓ'} (F : Functor B C) (G : Functor A B) where private - F* = func* F - F→ = func→ F - G* = func* G - G→ = func→ G + F* = omap F + F→ = fmap F + G* = omap G + G→ = fmap G module _ {a0 a1 a2 : Object A} {α0 : A [ a0 , a1 ]} {α1 : A [ a1 , a2 ]} where dist : (F→ ∘ G→) (A [ α1 ∘ α0 ]) ≡ C [ (F→ ∘ G→) α1 ∘ (F→ ∘ G→) α0 ] @@ -138,8 +138,8 @@ module _ {ℓ ℓ' : Level} {A B C : Category ℓ ℓ'} (F : Functor B C) (G : F C [ (F→ ∘ G→) α1 ∘ (F→ ∘ G→) α0 ] ∎ _∘fr_ : RawFunctor A C - RawFunctor.func* _∘fr_ = F* ∘ G* - RawFunctor.func→ _∘fr_ = F→ ∘ G→ + RawFunctor.omap _∘fr_ = F* ∘ G* + RawFunctor.fmap _∘fr_ = F→ ∘ G→ instance isFunctor' : IsFunctor A C _∘fr_ isFunctor' = record @@ -158,8 +158,8 @@ module _ {ℓ ℓ' : Level} {A B C : Category ℓ ℓ'} (F : Functor B C) (G : F identity : ∀ {ℓ ℓ'} → {C : Category ℓ ℓ'} → Functor C C identity = record { raw = record - { func* = λ x → x - ; func→ = λ x → x + { omap = λ x → x + ; fmap = λ x → x } ; isFunctor = record { isIdentity = refl diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 6ce46bb..f020383 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -39,8 +39,8 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where joinN : Natural F[ R ∘ R ] R joinT joinN = proj₂ joinNT - Romap = Functor.func* R - Rfmap = Functor.func→ R + Romap = Functor.omap R + Rfmap = Functor.fmap R bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] bind {X} {Y} f = joinT Y ∘ Rfmap f @@ -69,10 +69,10 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where isNatural : IsNatural isNatural {X} {Y} f = begin - joinT Y ∘ R.func→ f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩ - joinT Y ∘ (R.func→ f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩ - joinT Y ∘ (pureT (R.func* Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ - joinT Y ∘ pureT (R.func* Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ + joinT Y ∘ R.fmap f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩ + joinT Y ∘ (R.fmap f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩ + joinT Y ∘ (pureT (R.omap Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ + joinT Y ∘ pureT (R.omap Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ f ∎ @@ -81,36 +81,36 @@ module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where where module R² = Functor F[ R ∘ R ] distrib3 : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} - → R.func→ (a ∘ b ∘ c) - ≡ R.func→ a ∘ R.func→ b ∘ R.func→ c + → R.fmap (a ∘ b ∘ c) + ≡ R.fmap a ∘ R.fmap b ∘ R.fmap c distrib3 {a = a} {b} {c} = begin - R.func→ (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩ - R.func→ (a ∘ b) ∘ R.func→ c ≡⟨ cong (_∘ _) R.isDistributive ⟩ - R.func→ a ∘ R.func→ b ∘ R.func→ c ∎ + R.fmap (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩ + R.fmap (a ∘ b) ∘ R.fmap c ≡⟨ cong (_∘ _) R.isDistributive ⟩ + R.fmap a ∘ R.fmap b ∘ R.fmap c ∎ aux = begin - joinT Z ∘ R.func→ (joinT Z ∘ R.func→ g ∘ f) + joinT Z ∘ R.fmap (joinT Z ∘ R.fmap g ∘ f) ≡⟨ cong (λ φ → joinT Z ∘ φ) distrib3 ⟩ - joinT Z ∘ (R.func→ (joinT Z) ∘ R.func→ (R.func→ g) ∘ R.func→ f) + joinT Z ∘ (R.fmap (joinT Z) ∘ R.fmap (R.fmap g) ∘ R.fmap f) ≡⟨⟩ - joinT Z ∘ (R.func→ (joinT Z) ∘ R².func→ g ∘ R.func→ f) + joinT Z ∘ (R.fmap (joinT Z) ∘ R².fmap g ∘ R.fmap f) ≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩ - joinT Z ∘ (R.func→ (joinT Z) ∘ (R².func→ g ∘ R.func→ f)) + joinT Z ∘ (R.fmap (joinT Z) ∘ (R².fmap g ∘ R.fmap f)) ≡⟨ ℂ.isAssociative ⟩ - (joinT Z ∘ R.func→ (joinT Z)) ∘ (R².func→ g ∘ R.func→ f) - ≡⟨ cong (λ φ → φ ∘ (R².func→ g ∘ R.func→ f)) isAssociative ⟩ - (joinT Z ∘ joinT (R.func* Z)) ∘ (R².func→ g ∘ R.func→ f) + (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.func* Z) ∘ R².func→ g ∘ R.func→ f + joinT Z ∘ joinT (R.omap Z) ∘ R².fmap g ∘ R.fmap f ≡⟨⟩ - ((joinT Z ∘ joinT (R.func* Z)) ∘ R².func→ g) ∘ R.func→ f - ≡⟨ cong (_∘ R.func→ f) (sym ℂ.isAssociative) ⟩ - (joinT Z ∘ (joinT (R.func* Z) ∘ R².func→ g)) ∘ R.func→ f - ≡⟨ cong (λ φ → φ ∘ R.func→ f) (cong (_∘_ (joinT Z)) (joinN g)) ⟩ - (joinT Z ∘ (R.func→ g ∘ joinT Y)) ∘ R.func→ f - ≡⟨ cong (_∘ R.func→ f) ℂ.isAssociative ⟩ - joinT Z ∘ R.func→ g ∘ joinT Y ∘ R.func→ 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.func→ g ∘ (joinT Y ∘ R.func→ f) + joinT Z ∘ R.fmap g ∘ (joinT Y ∘ R.fmap f) ∎ record Monad : Set ℓ where @@ -235,8 +235,8 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where -- | This formulation gives rise to the following endo-functor. private rawR : RawFunctor ℂ ℂ - RawFunctor.func* rawR = omap - RawFunctor.func→ rawR = fmap + RawFunctor.omap rawR = omap + RawFunctor.fmap rawR = fmap isFunctorR : IsFunctor ℂ ℂ rawR IsFunctor.isIdentity isFunctorR = begin @@ -269,18 +269,18 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where pureT A = pure pureN : Natural R⁰ R pureT pureN {A} {B} f = begin - pureT B ∘ R⁰.func→ f ≡⟨⟩ + pureT B ∘ R⁰.fmap f ≡⟨⟩ pure ∘ f ≡⟨ sym (isNatural _) ⟩ bind (pure ∘ f) ∘ pure ≡⟨⟩ fmap f ∘ pure ≡⟨⟩ - R.func→ f ∘ pureT A ∎ + R.fmap f ∘ pureT A ∎ joinT : Transformation R² R joinT C = join joinN : Natural R² R joinT joinN f = begin - join ∘ R².func→ f ≡⟨⟩ - bind 𝟙 ∘ R².func→ f ≡⟨⟩ - R².func→ f >>> bind 𝟙 ≡⟨⟩ + join ∘ R².fmap f ≡⟨⟩ + bind 𝟙 ∘ R².fmap f ≡⟨⟩ + R².fmap f >>> bind 𝟙 ≡⟨⟩ fmap (fmap f) >>> bind 𝟙 ≡⟨⟩ fmap (bind (f >>> pure)) >>> bind 𝟙 ≡⟨⟩ bind (bind (f >>> pure) >>> pure) >>> bind 𝟙 @@ -300,9 +300,9 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where ≡⟨ sym (isDistributive _ _) ⟩ bind 𝟙 >>> bind (f >>> pure) ≡⟨⟩ bind 𝟙 >>> fmap f ≡⟨⟩ - bind 𝟙 >>> R.func→ f ≡⟨⟩ - R.func→ f ∘ bind 𝟙 ≡⟨⟩ - R.func→ f ∘ join ∎ + bind 𝟙 >>> R.fmap f ≡⟨⟩ + R.fmap f ∘ bind 𝟙 ≡⟨⟩ + R.fmap f ∘ join ∎ pureNT : NaturalTransformation R⁰ R proj₁ pureNT = pureT @@ -396,7 +396,6 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private module ℂ = Category ℂ open ℂ using (Object ; Arrow ; 𝟙 ; _∘_ ; _>>>_) - open Functor using (func* ; func→) module M = Monoidal ℂ module K = Kleisli ℂ @@ -434,19 +433,19 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where backIsMonad : M.IsMonad backRaw M.IsMonad.isAssociative backIsMonad {X} = begin - joinT X ∘ R.func→ (joinT X) ≡⟨⟩ + joinT X ∘ R.fmap (joinT X) ≡⟨⟩ join ∘ fmap (joinT X) ≡⟨⟩ join ∘ fmap join ≡⟨ isNaturalForeign ⟩ join ∘ join ≡⟨⟩ - joinT X ∘ joinT (R.func* X) ∎ + joinT X ∘ joinT (R.omap X) ∎ M.IsMonad.isInverse backIsMonad {X} = inv-l , inv-r where inv-l = begin - joinT X ∘ pureT (R.func* X) ≡⟨⟩ + joinT X ∘ pureT (R.omap X) ≡⟨⟩ join ∘ pure ≡⟨ proj₁ isInverse ⟩ 𝟙 ∎ inv-r = begin - joinT X ∘ R.func→ (pureT X) ≡⟨⟩ + joinT X ∘ R.fmap (pureT X) ≡⟨⟩ join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩ 𝟙 ∎ @@ -526,8 +525,8 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where ) rawEq : Functor.raw KM.R ≡ Functor.raw R - RawFunctor.func* (rawEq i) = omapEq i - RawFunctor.func→ (rawEq i) = fmapEq i + RawFunctor.omap (rawEq i) = omapEq i + RawFunctor.fmap (rawEq i) = fmapEq i Req : M.RawMonad.R (backRaw (forth m)) ≡ R Req = Functor≡ rawEq @@ -586,8 +585,8 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where Rraw : RawFunctor ℂ ℂ Rraw = record - { func* = omap - ; func→ = fmap + { omap = omap + ; fmap = fmap } field @@ -663,7 +662,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where voe-2-3-1-fromMonad : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) voe-2-3-1-fromMonad m = record - { fmap = Functor.func→ R + { fmap = Functor.fmap R ; RisFunctor = Functor.isFunctor R ; pureN = pureN ; join = λ {X} → joinT X diff --git a/src/Cat/Category/NaturalTransformation.agda b/src/Cat/Category/NaturalTransformation.agda index 525933a..dea2e50 100644 --- a/src/Cat/Category/NaturalTransformation.agda +++ b/src/Cat/Category/NaturalTransformation.agda @@ -46,13 +46,13 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} module G = Functor G -- What do you call a non-natural tranformation? Transformation : Set (ℓc ⊔ ℓd') - Transformation = (C : Object ℂ) → 𝔻 [ F.func* C , G.func* C ] + Transformation = (C : Object ℂ) → 𝔻 [ F.omap C , G.omap C ] Natural : Transformation → Set (ℓc ⊔ (ℓc' ⊔ ℓd')) Natural θ = {A B : Object ℂ} → (f : ℂ [ A , B ]) - → 𝔻 [ θ B ∘ F.func→ f ] ≡ 𝔻 [ G.func→ f ∘ θ A ] + → 𝔻 [ θ B ∘ F.fmap f ] ≡ 𝔻 [ G.fmap f ∘ θ A ] NaturalTransformation : Set (ℓc ⊔ ℓc' ⊔ ℓd') NaturalTransformation = Σ Transformation Natural @@ -78,7 +78,7 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} 𝔻 [ F→ f ∘ identityTrans F A ] ∎ where module F = Functor F - F→ = F.func→ + F→ = F.fmap identity : (F : Functor ℂ 𝔻) → NaturalTransformation F F identity F = identityTrans F , identityNatural F @@ -94,14 +94,14 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level} NT[_∘_] : NaturalTransformation G H → NaturalTransformation F G → NaturalTransformation F H proj₁ NT[ (θ , _) ∘ (η , _) ] = T[ θ ∘ η ] proj₂ NT[ (θ , θNat) ∘ (η , ηNat) ] {A} {B} f = begin - 𝔻 [ T[ θ ∘ η ] B ∘ F.func→ f ] ≡⟨⟩ - 𝔻 [ 𝔻 [ θ B ∘ η B ] ∘ F.func→ f ] ≡⟨ sym 𝔻.isAssociative ⟩ - 𝔻 [ θ B ∘ 𝔻 [ η B ∘ F.func→ f ] ] ≡⟨ cong (λ φ → 𝔻 [ θ B ∘ φ ]) (ηNat f) ⟩ - 𝔻 [ θ B ∘ 𝔻 [ G.func→ f ∘ η A ] ] ≡⟨ 𝔻.isAssociative ⟩ - 𝔻 [ 𝔻 [ θ B ∘ G.func→ f ] ∘ η A ] ≡⟨ cong (λ φ → 𝔻 [ φ ∘ η A ]) (θNat f) ⟩ - 𝔻 [ 𝔻 [ H.func→ f ∘ θ A ] ∘ η A ] ≡⟨ sym 𝔻.isAssociative ⟩ - 𝔻 [ H.func→ f ∘ 𝔻 [ θ A ∘ η A ] ] ≡⟨⟩ - 𝔻 [ H.func→ f ∘ T[ θ ∘ η ] A ] ∎ + 𝔻 [ T[ θ ∘ η ] B ∘ F.fmap f ] ≡⟨⟩ + 𝔻 [ 𝔻 [ θ B ∘ η B ] ∘ F.fmap f ] ≡⟨ sym 𝔻.isAssociative ⟩ + 𝔻 [ θ B ∘ 𝔻 [ η B ∘ F.fmap f ] ] ≡⟨ cong (λ φ → 𝔻 [ θ B ∘ φ ]) (ηNat f) ⟩ + 𝔻 [ θ B ∘ 𝔻 [ G.fmap f ∘ η A ] ] ≡⟨ 𝔻.isAssociative ⟩ + 𝔻 [ 𝔻 [ θ B ∘ G.fmap f ] ∘ η A ] ≡⟨ cong (λ φ → 𝔻 [ φ ∘ η A ]) (θNat f) ⟩ + 𝔻 [ 𝔻 [ H.fmap f ∘ θ A ] ∘ η A ] ≡⟨ sym 𝔻.isAssociative ⟩ + 𝔻 [ H.fmap f ∘ 𝔻 [ θ A ∘ η A ] ] ≡⟨⟩ + 𝔻 [ H.fmap f ∘ T[ θ ∘ η ] A ] ∎ module _ {F G : Functor ℂ 𝔻} where transformationIsSet : isSet (Transformation F G) diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index 88b0bbd..0e19c04 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -42,9 +42,9 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where fmapNT = fmap , fmapNatural rawYoneda : RawFunctor ℂ Fun - RawFunctor.func* rawYoneda = prshf - RawFunctor.func→ rawYoneda = fmapNT - open RawFunctor rawYoneda + RawFunctor.omap rawYoneda = prshf + RawFunctor.fmap rawYoneda = fmapNT + open RawFunctor rawYoneda hiding (fmap) isIdentity : IsIdentity isIdentity {c} = lemSig (naturalIsProp {F = prshf c} {prshf c}) _ _ eq From 48672b01bd5376878d7831cd33451c9d4b17a057 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 11:20:51 +0100 Subject: [PATCH 77/91] Use dotted expression in Cat --- src/Cat/Categories/Cat.agda | 108 +++++++++++++++++++----------------- 1 file changed, 58 insertions(+), 50 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 5e9ba24..e1c6d75 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -17,7 +17,6 @@ open import Cat.Category.NaturalTransformation open import Cat.Equality open Equality.Data.Product -open Functor using (fmap ; omap) open Category using (Object ; 𝟙) -- The category of categories @@ -169,14 +168,19 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where -- Basically proves that `Cat ℓ ℓ` is cartesian closed. module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where - open Data.Product - open import Cat.Categories.Fun + private + open Data.Product + open import Cat.Categories.Fun + module ℂ = Category ℂ + module 𝔻 = Category 𝔻 Categoryℓ = Category ℓ ℓ open Fun ℂ 𝔻 renaming (identity to idN) private :omap: : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 - :omap: (F , A) = omap F A + :omap: (F , A) = F.omap A + where + module F = Functor F prodObj : Categoryℓ prodObj = Fun @@ -193,28 +197,31 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where B : Object ℂ B = proj₂ cod + module F = Functor F + module G = Functor G + :fmap: : (pobj : NaturalTransformation F G × ℂ [ A , B ]) - → 𝔻 [ omap F A , omap G B ] + → 𝔻 [ F.omap A , G.omap B ] :fmap: ((θ , θNat) , f) = result where - θA : 𝔻 [ omap F A , omap G A ] + θA : 𝔻 [ F.omap A , G.omap A ] θA = θ A - θB : 𝔻 [ omap F B , omap G B ] + θB : 𝔻 [ F.omap B , G.omap B ] θB = θ B - F→f : 𝔻 [ omap F A , omap F B ] - F→f = fmap F f - G→f : 𝔻 [ omap G A , omap G B ] - G→f = fmap G f - l : 𝔻 [ omap F A , omap G B ] - l = 𝔻 [ θB ∘ F→f ] - r : 𝔻 [ omap F A , omap G B ] - r = 𝔻 [ G→f ∘ θA ] + F→f : 𝔻 [ F.omap A , F.omap B ] + F→f = F.fmap f + G→f : 𝔻 [ G.omap A , G.omap B ] + G→f = G.fmap f + l : 𝔻 [ F.omap A , G.omap B ] + l = 𝔻 [ θB ∘ F.fmap f ] + r : 𝔻 [ F.omap A , G.omap B ] + r = 𝔻 [ G.fmap f ∘ θA ] -- There are two choices at this point, -- but I suppose the whole point is that -- by `θNat f` we have `l ≡ r` -- lem : 𝔻 [ θ B ∘ F .fmap f ] ≡ 𝔻 [ G .fmap f ∘ θ A ] -- lem = θNat f - result : 𝔻 [ omap F A , omap G B ] + result : 𝔻 [ F.omap A , G.omap B ] result = l open CatProduct renaming (obj to _×p_) using () @@ -237,23 +244,27 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where :ident: = begin :fmap: {c} {c} (𝟙 (prodObj ×p ℂ) {c}) ≡⟨⟩ :fmap: {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ - 𝔻 [ identityTrans F C ∘ fmap F (𝟙 ℂ)] ≡⟨⟩ - 𝔻 [ 𝟙 𝔻 ∘ fmap F (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ - fmap F (𝟙 ℂ) ≡⟨ F.isIdentity ⟩ + 𝔻 [ identityTrans F C ∘ F.fmap (𝟙 ℂ)] ≡⟨⟩ + 𝔻 [ 𝟙 𝔻 ∘ F.fmap (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ + F.fmap (𝟙 ℂ) ≡⟨ F.isIdentity ⟩ 𝟙 𝔻 ∎ where - open module 𝔻 = Category 𝔻 open module F = Functor F module _ {F×A G×B H×C : Functor ℂ 𝔻 × Object ℂ} where - F = F×A .proj₁ - A = F×A .proj₂ - G = G×B .proj₁ - B = G×B .proj₂ - H = H×C .proj₁ - C = H×C .proj₂ - -- Not entirely clear what this is at this point: - _P⊕_ = Category._∘_ (prodObj ×p ℂ) {F×A} {G×B} {H×C} + private + F = F×A .proj₁ + A = F×A .proj₂ + G = G×B .proj₁ + B = G×B .proj₂ + H = H×C .proj₁ + C = H×C .proj₂ + module F = Functor F + module G = Functor G + module H = Functor H + -- Not entirely clear what this is at this point: + _P⊕_ = Category._∘_ (prodObj ×p ℂ) {F×A} {G×B} {H×C} + module _ -- NaturalTransformation F G × ℂ .Arrow A B {θ×f : NaturalTransformation F G × ℂ [ A , B ]} @@ -279,31 +290,28 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where ηθNat = proj₂ ηθNT :isDistributive: : - 𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ fmap F ( ℂ [ g ∘ f ] ) ] - ≡ 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ 𝔻 [ θ B ∘ fmap F f ] ] + 𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ F.fmap ( ℂ [ g ∘ f ] ) ] + ≡ 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ θ B ∘ F.fmap f ] ] :isDistributive: = begin - 𝔻 [ (ηθ C) ∘ fmap F (ℂ [ g ∘ f ]) ] + 𝔻 [ (ηθ C) ∘ F.fmap (ℂ [ g ∘ f ]) ] ≡⟨ ηθNat (ℂ [ g ∘ f ]) ⟩ - 𝔻 [ fmap H (ℂ [ g ∘ f ]) ∘ (ηθ A) ] + 𝔻 [ H.fmap (ℂ [ g ∘ f ]) ∘ (ηθ A) ] ≡⟨ cong (λ φ → 𝔻 [ φ ∘ ηθ A ]) (H.isDistributive) ⟩ - 𝔻 [ 𝔻 [ fmap H g ∘ fmap H f ] ∘ (ηθ A) ] - ≡⟨ sym isAssociative ⟩ - 𝔻 [ fmap H g ∘ 𝔻 [ fmap H f ∘ ηθ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ fmap H g ∘ φ ]) isAssociative ⟩ - 𝔻 [ fmap H g ∘ 𝔻 [ 𝔻 [ fmap H f ∘ η A ] ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ fmap H g ∘ φ ]) (cong (λ φ → 𝔻 [ φ ∘ θ A ]) (sym (ηNat f))) ⟩ - 𝔻 [ fmap H g ∘ 𝔻 [ 𝔻 [ η B ∘ fmap G f ] ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ fmap H g ∘ φ ]) (sym isAssociative) ⟩ - 𝔻 [ fmap H g ∘ 𝔻 [ η B ∘ 𝔻 [ fmap G f ∘ θ A ] ] ] - ≡⟨ isAssociative ⟩ - 𝔻 [ 𝔻 [ fmap H g ∘ η B ] ∘ 𝔻 [ fmap G f ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ φ ∘ 𝔻 [ fmap G f ∘ θ A ] ]) (sym (ηNat g)) ⟩ - 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ 𝔻 [ fmap G f ∘ θ A ] ] - ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ φ ]) (sym (θNat f)) ⟩ - 𝔻 [ 𝔻 [ η C ∘ fmap G g ] ∘ 𝔻 [ θ B ∘ fmap F f ] ] ∎ - where - open Category 𝔻 - module H = Functor H + 𝔻 [ 𝔻 [ H.fmap g ∘ H.fmap f ] ∘ (ηθ A) ] + ≡⟨ sym 𝔻.isAssociative ⟩ + 𝔻 [ H.fmap g ∘ 𝔻 [ H.fmap f ∘ ηθ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ H.fmap g ∘ φ ]) 𝔻.isAssociative ⟩ + 𝔻 [ H.fmap g ∘ 𝔻 [ 𝔻 [ H.fmap f ∘ η A ] ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ H.fmap g ∘ φ ]) (cong (λ φ → 𝔻 [ φ ∘ θ A ]) (sym (ηNat f))) ⟩ + 𝔻 [ H.fmap g ∘ 𝔻 [ 𝔻 [ η B ∘ G.fmap f ] ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ H.fmap g ∘ φ ]) (sym 𝔻.isAssociative) ⟩ + 𝔻 [ H.fmap g ∘ 𝔻 [ η B ∘ 𝔻 [ G.fmap f ∘ θ A ] ] ] + ≡⟨ 𝔻.isAssociative ⟩ + 𝔻 [ 𝔻 [ H.fmap g ∘ η B ] ∘ 𝔻 [ G.fmap f ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ φ ∘ 𝔻 [ G.fmap f ∘ θ A ] ]) (sym (ηNat g)) ⟩ + 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ G.fmap f ∘ θ A ] ] + ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ φ ]) (sym (θNat f)) ⟩ + 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ θ B ∘ F.fmap f ] ] ∎ eval : Functor (CatProduct.obj prodObj ℂ) 𝔻 -- :eval: : Functor (prodObj ×p ℂ) 𝔻 From d01514cbdbdd3204bd3a61e7367e647e0a49f08f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 11:29:16 +0100 Subject: [PATCH 78/91] Do not use ugly ':'-syntax to disambiguate fields --- src/Cat/Categories/Cat.agda | 91 +++++++++++++++++-------------------- 1 file changed, 41 insertions(+), 50 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index e1c6d75..71901ca 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -5,7 +5,6 @@ module Cat.Categories.Cat where open import Agda.Primitive open import Cubical -open import Function open import Data.Product renaming (proj₁ to fst ; proj₂ to snd) open import Cat.Category @@ -62,44 +61,44 @@ module _ (ℓ ℓ' : Level) where -- category. In some places it may not actually be needed, however. module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where private - :Object: = Object ℂ × Object 𝔻 - :Arrow: : :Object: → :Object: → Set ℓ' - :Arrow: (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ] - :𝟙: : {o : :Object:} → :Arrow: o o - :𝟙: = 𝟙 ℂ , 𝟙 𝔻 - _:⊕:_ : - {a b c : :Object:} → - :Arrow: b c → - :Arrow: a b → - :Arrow: a c - _:⊕:_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) → ℂ [ bc∈C ∘ ab∈C ] , 𝔻 [ bc∈D ∘ ab∈D ]} + Obj = Object ℂ × Object 𝔻 + Arr : Obj → Obj → Set ℓ' + Arr (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ] + 𝟙' : {o : Obj} → Arr o o + 𝟙' = 𝟙 ℂ , 𝟙 𝔻 + _∘_ : + {a b c : Obj} → + Arr b c → + Arr a b → + Arr a c + _∘_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) → ℂ [ bc∈C ∘ ab∈C ] , 𝔻 [ bc∈D ∘ ab∈D ]} - :rawProduct: : RawCategory ℓ ℓ' - RawCategory.Object :rawProduct: = :Object: - RawCategory.Arrow :rawProduct: = :Arrow: - RawCategory.𝟙 :rawProduct: = :𝟙: - RawCategory._∘_ :rawProduct: = _:⊕:_ - open RawCategory :rawProduct: + rawProduct : RawCategory ℓ ℓ' + RawCategory.Object rawProduct = Obj + RawCategory.Arrow rawProduct = Arr + RawCategory.𝟙 rawProduct = 𝟙' + RawCategory._∘_ rawProduct = _∘_ + open RawCategory rawProduct module ℂ = Category ℂ module 𝔻 = Category 𝔻 open import Cubical.Sigma - arrowsAreSets : ArrowsAreSets -- {A B : RawCategory.Object :rawProduct:} → isSet (Arrow A B) + arrowsAreSets : ArrowsAreSets arrowsAreSets = setSig {sA = ℂ.arrowsAreSets} {sB = λ x → 𝔻.arrowsAreSets} - isIdentity : IsIdentity :𝟙: + isIdentity : IsIdentity 𝟙' isIdentity = Σ≡ (fst ℂ.isIdentity) (fst 𝔻.isIdentity) , Σ≡ (snd ℂ.isIdentity) (snd 𝔻.isIdentity) - postulate univalent : Univalence.Univalent :rawProduct: isIdentity + postulate univalent : Univalence.Univalent rawProduct isIdentity instance - :isCategory: : IsCategory :rawProduct: - IsCategory.isAssociative :isCategory: = Σ≡ ℂ.isAssociative 𝔻.isAssociative - IsCategory.isIdentity :isCategory: = isIdentity - IsCategory.arrowsAreSets :isCategory: = arrowsAreSets - IsCategory.univalent :isCategory: = univalent + isCategory : IsCategory rawProduct + IsCategory.isAssociative isCategory = Σ≡ ℂ.isAssociative 𝔻.isAssociative + IsCategory.isIdentity isCategory = isIdentity + IsCategory.arrowsAreSets isCategory = arrowsAreSets + IsCategory.univalent isCategory = univalent obj : Category ℓ ℓ' - Category.raw obj = :rawProduct: + Category.raw obj = rawProduct proj₁ : Functor obj ℂ proj₁ = record @@ -177,8 +176,8 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where Categoryℓ = Category ℓ ℓ open Fun ℂ 𝔻 renaming (identity to idN) private - :omap: : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 - :omap: (F , A) = F.omap A + omap : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 + omap (F , A) = F.omap A where module F = Functor F @@ -200,9 +199,9 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where module F = Functor F module G = Functor G - :fmap: : (pobj : NaturalTransformation F G × ℂ [ A , B ]) + fmap : (pobj : NaturalTransformation F G × ℂ [ A , B ]) → 𝔻 [ F.omap A , G.omap B ] - :fmap: ((θ , θNat) , f) = result + fmap ((θ , θNat) , f) = result where θA : 𝔻 [ F.omap A , G.omap A ] θA = θ A @@ -233,23 +232,16 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where C : Object ℂ C = proj₂ c - -- NaturalTransformation F G × ℂ .Arrow A B - -- :ident: : :fmap: {c} {c} (identityNat F , ℂ .𝟙) ≡ 𝔻 .𝟙 - -- :ident: = trans (proj₂ 𝔻.isIdentity) (F .isIdentity) - -- where - -- open module 𝔻 = IsCategory (𝔻 .isCategory) - -- Unfortunately the equational version has some ambigous arguments. - - :ident: : :fmap: {c} {c} (NT.identity F , 𝟙 ℂ {A = proj₂ c}) ≡ 𝟙 𝔻 - :ident: = begin - :fmap: {c} {c} (𝟙 (prodObj ×p ℂ) {c}) ≡⟨⟩ - :fmap: {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ + ident : fmap {c} {c} (NT.identity F , 𝟙 ℂ {A = proj₂ c}) ≡ 𝟙 𝔻 + ident = begin + fmap {c} {c} (𝟙 (prodObj ×p ℂ) {c}) ≡⟨⟩ + fmap {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ 𝔻 [ identityTrans F C ∘ F.fmap (𝟙 ℂ)] ≡⟨⟩ 𝔻 [ 𝟙 𝔻 ∘ F.fmap (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ F.fmap (𝟙 ℂ) ≡⟨ F.isIdentity ⟩ 𝟙 𝔻 ∎ where - open module F = Functor F + module F = Functor F module _ {F×A G×B H×C : Functor ℂ 𝔻 × Object ℂ} where private @@ -289,10 +281,10 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where ηθ = proj₁ ηθNT ηθNat = proj₂ ηθNT - :isDistributive: : + isDistributive : 𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ F.fmap ( ℂ [ g ∘ f ] ) ] ≡ 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ θ B ∘ F.fmap f ] ] - :isDistributive: = begin + isDistributive = begin 𝔻 [ (ηθ C) ∘ F.fmap (ℂ [ g ∘ f ]) ] ≡⟨ ηθNat (ℂ [ g ∘ f ]) ⟩ 𝔻 [ H.fmap (ℂ [ g ∘ f ]) ∘ (ηθ A) ] @@ -314,15 +306,14 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ θ B ∘ F.fmap f ] ] ∎ eval : Functor (CatProduct.obj prodObj ℂ) 𝔻 - -- :eval: : Functor (prodObj ×p ℂ) 𝔻 eval = record { raw = record - { omap = :omap: - ; fmap = λ {dom} {cod} → :fmap: {dom} {cod} + { omap = omap + ; fmap = λ {dom} {cod} → fmap {dom} {cod} } ; isFunctor = record - { isIdentity = λ {o} → :ident: {o} - ; isDistributive = λ {f u n k y} → :isDistributive: {f} {u} {n} {k} {y} + { isIdentity = λ {o} → ident {o} + ; isDistributive = λ {f u n k y} → isDistributive {f} {u} {n} {k} {y} } } From 52297d90737143f7c6a43ec608f766e2a4e328d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 11:54:13 +0100 Subject: [PATCH 79/91] Clean-up in the category of categories --- src/Cat/Categories/Cat.agda | 145 +++++++++++++++++------------------- 1 file changed, 69 insertions(+), 76 deletions(-) diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index 71901ca..8c7bcbb 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -4,9 +4,11 @@ module Cat.Categories.Cat where open import Agda.Primitive -open import Cubical open import Data.Product renaming (proj₁ to fst ; proj₂ to snd) +open import Cubical +open import Cubical.Sigma + open import Cat.Category open import Cat.Category.Functor open import Cat.Category.Product @@ -46,21 +48,30 @@ module _ (ℓ ℓ' : Level) where isAssociative {f = F} {G} {H} = assc {F = F} {G = G} {H = H} ident : IsIdentity identity ident = ident-r , ident-l - -- NB! `ArrowsAreSets RawCat` is *not* provable. The type of functors, - -- however, form a groupoid! Therefore there is no (1-)category of - -- categories. There does, however, exist a 2-category of 1-categories. - -- Because of the note above there is not category of categories. + -- NB! `ArrowsAreSets RawCat` is *not* provable. The type of functors, + -- however, form a groupoid! Therefore there is no (1-)category of + -- categories. There does, however, exist a 2-category of 1-categories. + -- + -- Because of this there is no category of categories. Cat : (unprovable : IsCategory RawCat) → Category (lsuc (ℓ ⊔ ℓ')) (ℓ ⊔ ℓ') Category.raw (Cat _) = RawCat Category.isCategory (Cat unprovable) = unprovable - -- Category.raw Cat _ = RawCat - -- Category.isCategory Cat unprovable = unprovable --- The following to some extend depends on the category of categories being a --- category. In some places it may not actually be needed, however. +-- | In the following we will pretend there is a category of categories when +-- e.g. talking about it being cartesian closed. It still makes sense to +-- construct these things even though that category does not exist. +-- +-- If the notion of a category is later generalized to work on different +-- homotopy levels, then the proof that the category of categories is cartesian +-- closed will follow immediately from these constructions. + +-- | the category of categories have products. module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where private + module ℂ = Category ℂ + module 𝔻 = Category 𝔻 + Obj = Object ℂ × Object 𝔻 Arr : Obj → Obj → Set ℓ' Arr (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ] @@ -80,9 +91,6 @@ module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where RawCategory._∘_ rawProduct = _∘_ open RawCategory rawProduct - module ℂ = Category ℂ - module 𝔻 = Category 𝔻 - open import Cubical.Sigma arrowsAreSets : ArrowsAreSets arrowsAreSets = setSig {sA = ℂ.arrowsAreSets} {sB = λ x → 𝔻.arrowsAreSets} isIdentity : IsIdentity 𝟙' @@ -97,31 +105,35 @@ module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where IsCategory.arrowsAreSets isCategory = arrowsAreSets IsCategory.univalent isCategory = univalent - obj : Category ℓ ℓ' - Category.raw obj = rawProduct + object : Category ℓ ℓ' + Category.raw object = rawProduct - proj₁ : Functor obj ℂ + proj₁ : Functor object ℂ proj₁ = record - { raw = record { omap = fst ; fmap = fst } - ; isFunctor = record { isIdentity = refl ; isDistributive = refl } + { raw = record + { omap = fst ; fmap = fst } + ; isFunctor = record + { isIdentity = refl ; isDistributive = refl } } - proj₂ : Functor obj 𝔻 + proj₂ : Functor object 𝔻 proj₂ = record - { raw = record { omap = snd ; fmap = snd } - ; isFunctor = record { isIdentity = refl ; isDistributive = refl } + { raw = record + { omap = snd ; fmap = snd } + ; isFunctor = record + { isIdentity = refl ; isDistributive = refl } } module _ {X : Category ℓ ℓ'} (x₁ : Functor X ℂ) (x₂ : Functor X 𝔻) where private - x : Functor X obj + x : Functor X object x = record { raw = record { omap = λ x → x₁.omap x , x₂.omap x ; fmap = λ x → x₁.fmap x , x₂.fmap x } ; isFunctor = record - { isIdentity = Σ≡ x₁.isIdentity x₂.isIdentity + { isIdentity = Σ≡ x₁.isIdentity x₂.isIdentity ; isDistributive = Σ≡ x₁.isDistributive x₂.isDistributive } } @@ -150,7 +162,7 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where module P = CatProduct ℂ 𝔻 rawProduct : RawProduct Catℓ ℂ 𝔻 - RawProduct.object rawProduct = P.obj + RawProduct.object rawProduct = P.object RawProduct.proj₁ rawProduct = P.proj₁ RawProduct.proj₂ rawProduct = P.proj₂ @@ -165,24 +177,23 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where hasProducts : HasProducts Catℓ hasProducts = record { product = product } --- Basically proves that `Cat ℓ ℓ` is cartesian closed. +-- | The category of categories have expoentntials - and because it has products +-- it is therefory also cartesian closed. module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where private open Data.Product open import Cat.Categories.Fun module ℂ = Category ℂ module 𝔻 = Category 𝔻 + Categoryℓ = Category ℓ ℓ + open Fun ℂ 𝔻 renaming (identity to idN) - Categoryℓ = Category ℓ ℓ - open Fun ℂ 𝔻 renaming (identity to idN) - private omap : Functor ℂ 𝔻 × Object ℂ → Object 𝔻 - omap (F , A) = F.omap A - where - module F = Functor F + omap (F , A) = Functor.omap F A - prodObj : Categoryℓ - prodObj = Fun + -- The exponential object + object : Categoryℓ + object = Fun module _ {dom cod : Functor ℂ 𝔻 × Object ℂ} where private @@ -215,15 +226,10 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where l = 𝔻 [ θB ∘ F.fmap f ] r : 𝔻 [ F.omap A , G.omap B ] r = 𝔻 [ G.fmap f ∘ θA ] - -- There are two choices at this point, - -- but I suppose the whole point is that - -- by `θNat f` we have `l ≡ r` - -- lem : 𝔻 [ θ B ∘ F .fmap f ] ≡ 𝔻 [ G .fmap f ∘ θ A ] - -- lem = θNat f result : 𝔻 [ F.omap A , G.omap B ] result = l - open CatProduct renaming (obj to _×p_) using () + open CatProduct renaming (object to _⊗_) using () module _ {c : Functor ℂ 𝔻 × Object ℂ} where private @@ -234,7 +240,7 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where ident : fmap {c} {c} (NT.identity F , 𝟙 ℂ {A = proj₂ c}) ≡ 𝟙 𝔻 ident = begin - fmap {c} {c} (𝟙 (prodObj ×p ℂ) {c}) ≡⟨⟩ + fmap {c} {c} (𝟙 (object ⊗ ℂ) {c}) ≡⟨⟩ fmap {c} {c} (idN F , 𝟙 ℂ) ≡⟨⟩ 𝔻 [ identityTrans F C ∘ F.fmap (𝟙 ℂ)] ≡⟨⟩ 𝔻 [ 𝟙 𝔻 ∘ F.fmap (𝟙 ℂ)] ≡⟨ proj₂ 𝔻.isIdentity ⟩ @@ -254,8 +260,6 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where module F = Functor F module G = Functor G module H = Functor H - -- Not entirely clear what this is at this point: - _P⊕_ = Category._∘_ (prodObj ×p ℂ) {F×A} {G×B} {H×C} module _ -- NaturalTransformation F G × ℂ .Arrow A B @@ -305,7 +309,7 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ φ ]) (sym (θNat f)) ⟩ 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ θ B ∘ F.fmap f ] ] ∎ - eval : Functor (CatProduct.obj prodObj ℂ) 𝔻 + eval : Functor (CatProduct.object object ℂ) 𝔻 eval = record { raw = record { omap = omap @@ -317,14 +321,12 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where } } - module _ (𝔸 : Category ℓ ℓ) (F : Functor (𝔸 ×p ℂ) 𝔻) where - -- open HasProducts (hasProducts {ℓ} {ℓ} unprovable) renaming (_|×|_ to parallelProduct) - + module _ (𝔸 : Category ℓ ℓ) (F : Functor (𝔸 ⊗ ℂ) 𝔻) where postulate parallelProduct - : Functor 𝔸 prodObj → Functor ℂ ℂ - → Functor (𝔸 ×p ℂ) (prodObj ×p ℂ) - transpose : Functor 𝔸 prodObj + : Functor 𝔸 object → Functor ℂ ℂ + → Functor (𝔸 ⊗ ℂ) (object ⊗ ℂ) + transpose : Functor 𝔸 object eq : F[ eval ∘ (parallelProduct transpose (identity {C = ℂ})) ] ≡ F -- eq : F[ :eval: ∘ {!!} ] ≡ F -- eq : Catℓ [ :eval: ∘ (HasProducts._|×|_ hasProducts transpose (𝟙 Catℓ {o = ℂ})) ] ≡ F @@ -339,39 +341,30 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where -- :eval: ∘ (parallelProduct F~ (𝟙 Catℓ {o = ℂ}))] ≡ F) catTranspose = -- transpose , eq +-- We don't care about filling out the holes below since they are anyways hidden +-- behind an unprovable statement. module _ (ℓ : Level) (unprovable : IsCategory (RawCat ℓ ℓ)) where private Catℓ : Category (lsuc (ℓ ⊔ ℓ)) (ℓ ⊔ ℓ) Catℓ = Cat ℓ ℓ unprovable - module _ (ℂ 𝔻 : Category ℓ ℓ) where - open CatExponential ℂ 𝔻 using (prodObj ; eval) - -- Putting in the type annotation causes Agda to loop indefinitely. - -- eval' : Functor (CatProduct.obj prodObj ℂ) 𝔻 - -- Likewise, using it below also results in this. - eval' : _ - eval' = eval - -- private - -- -- module _ (ℂ 𝔻 : Category ℓ ℓ) where - -- postulate :isExponential: : IsExponential Catℓ ℂ 𝔻 prodObj :eval: - -- -- :isExponential: : IsExponential Catℓ ℂ 𝔻 :obj: :eval: - -- -- :isExponential: = {!catTranspose!} - -- -- where - -- -- open HasProducts (hasProducts {ℓ} {ℓ} unprovable) using (_|×|_) - -- -- :isExponential: = λ 𝔸 F → transpose 𝔸 F , eq' 𝔸 F - -- -- :exponent: : Exponential (Cat ℓ ℓ) A B - exponent : Exponential Catℓ ℂ 𝔻 - exponent = record - { obj = prodObj - ; eval = {!evalll'!} - ; isExponential = {!:isExponential:!} - } - where - open HasProducts (hasProducts unprovable) renaming (_×_ to _×p_) - open import Cat.Categories.Fun - open Fun - -- _×p_ = CatProduct.obj -- prodObj ℂ - -- eval' : Functor CatP.obj 𝔻 + module _ (ℂ 𝔻 : Category ℓ ℓ) where + module CatExp = CatExponential ℂ 𝔻 + _⊗_ = CatProduct.object + + -- Filling the hole causes Agda to loop indefinitely. + eval : Functor (CatExp.object ⊗ ℂ) 𝔻 + eval = {!CatExp.eval!} + + isExponential : IsExponential Catℓ ℂ 𝔻 CatExp.object eval + isExponential = {!CatExp.isExponential!} + + exponent : Exponential Catℓ ℂ 𝔻 + exponent = record + { obj = CatExp.object + ; eval = eval + ; isExponential = isExponential + } hasExponentials : HasExponentials Catℓ hasExponentials = record { exponent = exponent } From acb5ff4f2be92785cbd0a6ed24e74750c8aa93e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 8 Mar 2018 14:44:23 +0100 Subject: [PATCH 80/91] Closer to showing univalence for the category of sets --- src/Cat/Categories/Sets.agda | 104 +++++++++++++++++++++++++++++++---- 1 file changed, 92 insertions(+), 12 deletions(-) diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index 6f9ade2..c18b70a 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -1,35 +1,115 @@ +-- | The category of homotopy sets {-# OPTIONS --allow-unsolved-metas --cubical #-} module Cat.Categories.Sets where -open import Cubical open import Agda.Primitive open import Data.Product import Function +open import Cubical hiding (inverse ; _≃_ {- ; obverse ; recto-verso ; verso-recto -} ) +open import Cubical.Univalence using (_≃_ ; ua) +open import Cubical.GradLemma + open import Cat.Category open import Cat.Category.Functor open import Cat.Category.Product +open import Cat.Wishlist module _ (ℓ : Level) where private - open RawCategory - open IsCategory open import Cubical.Univalence open import Cubical.NType.Properties open import Cubical.Universe SetsRaw : RawCategory (lsuc ℓ) ℓ - Object SetsRaw = hSet - Arrow SetsRaw (T , _) (U , _) = T → U - 𝟙 SetsRaw = Function.id - _∘_ SetsRaw = Function._∘′_ + RawCategory.Object SetsRaw = hSet + RawCategory.Arrow SetsRaw (T , _) (U , _) = T → U + RawCategory.𝟙 SetsRaw = Function.id + RawCategory._∘_ SetsRaw = Function._∘′_ + + open RawCategory SetsRaw + open Univalence SetsRaw + + isIdentity : IsIdentity Function.id + proj₁ isIdentity = funExt λ _ → refl + proj₂ isIdentity = funExt λ _ → refl + + arrowsAreSets : ArrowsAreSets + arrowsAreSets {B = (_ , s)} = setPi λ _ → s + + module _ {hA hB : Object} where + private + A = proj₁ hA + isSetA : isSet A + isSetA = proj₂ hA + B = proj₁ hB + isSetB : isSet B + isSetB = proj₂ hB + + toIsomorphism : A ≃ B → hA ≅ hB + toIsomorphism e = obverse , inverse , verso-recto , recto-verso + where + open _≃_ e + + fromIsomorphism : hA ≅ hB → A ≃ B + fromIsomorphism iso = con obverse (gradLemma obverse inverse recto-verso verso-recto) + where + obverse : A → B + obverse = proj₁ iso + inverse : B → A + inverse = proj₁ (proj₂ iso) + -- FIXME IsInverseOf should change name to AreInverses and the + -- ordering should be swapped. + areInverses : IsInverseOf {A = hA} {hB} obverse inverse + areInverses = proj₂ (proj₂ iso) + verso-recto : ∀ a → (inverse Function.∘ obverse) a ≡ a + verso-recto a i = proj₁ areInverses i a + recto-verso : ∀ b → (obverse Function.∘ inverse) b ≡ b + recto-verso b i = proj₂ areInverses i b + + univalent : isEquiv (hA ≡ hB) (hA ≅ hB) (id-to-iso (λ {A} {B} → isIdentity {A} {B}) hA hB) + univalent = gradLemma obverse inverse verso-recto recto-verso + where + obverse : hA ≡ hB → hA ≅ hB + obverse eq = {!res!} + where + -- Problem: How do I extract this equality from `eq`? + eqq : A ≡ B + eqq = {!!} + eq' : A ≃ B + eq' = fromEquality eqq + -- Problem: Why does this not satisfy the goal? + res : hA ≅ hB + res = toIsomorphism eq' + + inverse : hA ≅ hB → hA ≡ hB + inverse iso = res + where + eq : A ≡ B + eq = ua (fromIsomorphism iso) + + -- Use the fact that being an h-level level is a mere proposition. + -- This is almost provable using `Wishlist.isSetIsProp` - although + -- this creates homogenous paths. + isSetEq : (λ i → isSet (eq i)) [ isSetA ≡ isSetB ] + isSetEq = {!!} + + res : hA ≡ hB + proj₁ (res i) = eq i + proj₂ (res i) = isSetEq i + + -- FIXME Either the name of inverse/obverse is flipped or + -- recto-verso/verso-recto is flipped. + recto-verso : ∀ y → (inverse Function.∘ obverse) y ≡ y + recto-verso x = {!!} + verso-recto : ∀ x → (obverse Function.∘ inverse) x ≡ x + verso-recto x = {!!} SetsIsCategory : IsCategory SetsRaw - isAssociative SetsIsCategory = refl - proj₁ (isIdentity SetsIsCategory) = funExt λ _ → refl - proj₂ (isIdentity SetsIsCategory) = funExt λ _ → refl - arrowsAreSets SetsIsCategory {B = (_ , s)} = setPi λ _ → s - univalent SetsIsCategory = {!!} + IsCategory.isAssociative SetsIsCategory = refl + IsCategory.isIdentity SetsIsCategory {A} {B} = isIdentity {A} {B} + IsCategory.arrowsAreSets SetsIsCategory {A} {B} = arrowsAreSets {A} {B} + IsCategory.univalent SetsIsCategory = univalent 𝓢𝓮𝓽 Sets : Category (lsuc ℓ) ℓ Category.raw 𝓢𝓮𝓽 = SetsRaw From 35390c02d3852955ab3343c9740b3f089255fe2d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 13:36:55 +0100 Subject: [PATCH 81/91] Stuff about univalence in the category of sets --- libs/cubical | 2 +- src/Cat/Categories/Sets.agda | 129 +++++++++++++++++++++++++---------- src/Cat/Category.agda | 69 ++++++++++++------- src/Cat/Category/Monad.agda | 4 +- src/Cat/Category/Yoneda.agda | 2 +- src/Cat/Wishlist.agda | 9 +-- 6 files changed, 146 insertions(+), 69 deletions(-) diff --git a/libs/cubical b/libs/cubical index a487c76..3a125a0 160000 --- a/libs/cubical +++ b/libs/cubical @@ -1 +1 @@ -Subproject commit a487c76a5f3ecf2752dabc9e5c3a8866fda28a19 +Subproject commit 3a125a0cb010903e6aa80569a0ca5339424eaf86 diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index c18b70a..a329a0f 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -4,10 +4,15 @@ module Cat.Categories.Sets where open import Agda.Primitive open import Data.Product -import Function +open import Function using (_∘_) -open import Cubical hiding (inverse ; _≃_ {- ; obverse ; recto-verso ; verso-recto -} ) -open import Cubical.Univalence using (_≃_ ; ua) +open import Cubical hiding (_≃_ ; inverse) +open import Cubical.Equivalence + renaming + ( _≅_ to _A≅_ ) + using + (_≃_ ; con ; AreInverses) +open import Cubical.Univalence open import Cubical.GradLemma open import Cat.Category @@ -27,7 +32,7 @@ module _ (ℓ : Level) where RawCategory.𝟙 SetsRaw = Function.id RawCategory._∘_ SetsRaw = Function._∘′_ - open RawCategory SetsRaw + open RawCategory SetsRaw hiding (_∘_) open Univalence SetsRaw isIdentity : IsIdentity Function.id @@ -62,48 +67,100 @@ module _ (ℓ : Level) where -- ordering should be swapped. areInverses : IsInverseOf {A = hA} {hB} obverse inverse areInverses = proj₂ (proj₂ iso) - verso-recto : ∀ a → (inverse Function.∘ obverse) a ≡ a + verso-recto : ∀ a → (inverse ∘ obverse) a ≡ a verso-recto a i = proj₁ areInverses i a recto-verso : ∀ b → (obverse Function.∘ inverse) b ≡ b recto-verso b i = proj₂ areInverses i b - univalent : isEquiv (hA ≡ hB) (hA ≅ hB) (id-to-iso (λ {A} {B} → isIdentity {A} {B}) hA hB) - univalent = gradLemma obverse inverse verso-recto recto-verso - where + private + univIso : (A ≡ B) A≅ (A ≃ B) + univIso = _≃_.toIsomorphism univalence + obverse' : A ≡ B → A ≃ B + obverse' = proj₁ univIso + inverse' : A ≃ B → A ≡ B + inverse' = proj₁ (proj₂ univIso) + -- Drop proof of being a set from both sides of an equality. + dropP : hA ≡ hB → A ≡ B + dropP eq i = proj₁ (eq i) + -- Add proof of being a set to both sides of a set-theoretic equivalence + -- returning a category-theoretic equivalence. + addE : A A≅ B → hA ≅ hB + addE eqv = proj₁ eqv , (proj₁ (proj₂ eqv)) , asPair + where + areeqv = proj₂ (proj₂ eqv) + asPair = + let module Inv = AreInverses areeqv + in Inv.verso-recto , Inv.recto-verso + obverse : hA ≡ hB → hA ≅ hB - obverse eq = {!res!} - where - -- Problem: How do I extract this equality from `eq`? - eqq : A ≡ B - eqq = {!!} - eq' : A ≃ B - eq' = fromEquality eqq - -- Problem: Why does this not satisfy the goal? - res : hA ≅ hB - res = toIsomorphism eq' + obverse = addE ∘ _≃_.toIsomorphism ∘ obverse' ∘ dropP + -- Drop proof of being a set form both sides of a category-theoretic + -- equivalence returning a set-theoretic equivalence. + dropE : hA ≅ hB → A A≅ B + dropE eqv = obv , inv , asAreInverses + where + obv = proj₁ eqv + inv = proj₁ (proj₂ eqv) + areEq = proj₂ (proj₂ eqv) + asAreInverses : AreInverses A B obv inv + asAreInverses = record { verso-recto = proj₁ areEq ; recto-verso = proj₂ areEq } + + -- Dunno if this is a thing. + isoToEquiv : A A≅ B → A ≃ B + isoToEquiv = {!!} + -- Add proof of being a set to both sides of an equality. + addP : A ≡ B → hA ≡ hB + addP p = lemSig (λ X → propPi λ x → propPi (λ y → propIsProp)) hA hB p inverse : hA ≅ hB → hA ≡ hB - inverse iso = res - where - eq : A ≡ B - eq = ua (fromIsomorphism iso) + inverse = addP ∘ inverse' ∘ isoToEquiv ∘ dropE - -- Use the fact that being an h-level level is a mere proposition. - -- This is almost provable using `Wishlist.isSetIsProp` - although - -- this creates homogenous paths. - isSetEq : (λ i → isSet (eq i)) [ isSetA ≡ isSetB ] - isSetEq = {!!} + -- open AreInverses (proj₂ (proj₂ univIso)) renaming + -- ( verso-recto to verso-recto' + -- ; recto-verso to recto-verso' + -- ) + -- I can just open them but I wanna be able to see the type annotations. + verso-recto' : inverse' ∘ obverse' ≡ Function.id + verso-recto' = AreInverses.verso-recto (proj₂ (proj₂ univIso)) + recto-verso' : obverse' ∘ inverse' ≡ Function.id + recto-verso' = AreInverses.recto-verso (proj₂ (proj₂ univIso)) + verso-recto : (iso : hA ≅ hB) → obverse (inverse iso) ≡ iso + verso-recto iso = begin + obverse (inverse iso) ≡⟨⟩ + ( addE ∘ _≃_.toIsomorphism + ∘ obverse' ∘ dropP ∘ addP + ∘ inverse' ∘ isoToEquiv + ∘ dropE) iso + ≡⟨⟩ + ( addE ∘ _≃_.toIsomorphism + ∘ obverse' + ∘ inverse' ∘ isoToEquiv + ∘ dropE) iso + ≡⟨ {!!} ⟩ -- obverse' inverse' are inverses + ( addE ∘ _≃_.toIsomorphism ∘ isoToEquiv ∘ dropE) iso + ≡⟨ {!!} ⟩ -- should be easy to prove + -- _≃_.toIsomorphism ∘ isoToEquiv ≡ id + (addE ∘ dropE) iso + ≡⟨⟩ + iso ∎ - res : hA ≡ hB - proj₁ (res i) = eq i - proj₂ (res i) = isSetEq i + -- Similar to above. + recto-verso : (eq : hA ≡ hB) → inverse (obverse eq) ≡ eq + recto-verso eq = begin + inverse (obverse eq) ≡⟨ {!!} ⟩ + eq ∎ - -- FIXME Either the name of inverse/obverse is flipped or - -- recto-verso/verso-recto is flipped. - recto-verso : ∀ y → (inverse Function.∘ obverse) y ≡ y - recto-verso x = {!!} - verso-recto : ∀ x → (obverse Function.∘ inverse) x ≡ x - verso-recto x = {!!} + -- Use the fact that being an h-level is a mere proposition. + -- This is almost provable using `Wishlist.isSetIsProp` - although + -- this creates homogenous paths. + isSetEq : (p : A ≡ B) → (λ i → isSet (p i)) [ isSetA ≡ isSetB ] + isSetEq = {!!} + + res : hA ≡ hB + proj₁ (res i) = {!!} + proj₂ (res i) = isSetEq {!!} i + univalent : isEquiv (hA ≡ hB) (hA ≅ hB) (id-to-iso (λ {A} {B} → isIdentity {A} {B}) hA hB) + univalent = {!gradLemma obverse inverse verso-recto recto-verso!} SetsIsCategory : IsCategory SetsRaw IsCategory.isAssociative SetsIsCategory = refl diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index e547a81..5a13f41 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -129,7 +129,9 @@ record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where Terminal : Set (ℓa ⊔ ℓb) Terminal = Σ Object IsTerminal --- Univalence is indexed by a raw category as well as an identity proof. +-- | Univalence is indexed by a raw category as well as an identity proof. +-- +-- FIXME Put this in `RawCategory` and index it on the witness to `isIdentity`. module Univalence {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where open RawCategory ℂ module _ (isIdentity : IsIdentity 𝟙) where @@ -150,6 +152,8 @@ module Univalence {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where -- iso-is-epi : Isomorphism f → Epimorphism {X = X} f -- iso-is-mono : Isomorphism f → Monomorphism {X = X} f -- +-- Sans `univalent` this would be what is referred to as a pre-category in +-- [HoTT]. record IsCategory {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) : Set (lsuc (ℓa ⊔ ℓb)) where open RawCategory ℂ public open Univalence ℂ public @@ -248,51 +252,66 @@ module Propositionality {ℓa ℓb : Level} {C : RawCategory ℓa ℓb} where -- adverse effects this may have. isIdentity : (λ _ → IsIdentity 𝟙) [ X.isIdentity ≡ Y.isIdentity ] isIdentity = propIsIdentity x X.isIdentity Y.isIdentity - done : x ≡ y U : ∀ {a : IsIdentity 𝟙} → (λ _ → IsIdentity 𝟙) [ X.isIdentity ≡ a ] → (b : Univalent a) → Set _ - U eqwal bbb = + U eqwal univ = (λ i → Univalent (eqwal i)) - [ X.univalent ≡ bbb ] + [ X.univalent ≡ univ ] P : (y : IsIdentity 𝟙) → (λ _ → IsIdentity 𝟙) [ X.isIdentity ≡ y ] → Set _ - P y eq = ∀ (b' : Univalent y) → U eq b' - helper : ∀ (b' : Univalent X.isIdentity) + P y eq = ∀ (univ : Univalent y) → U eq univ + p : ∀ (b' : Univalent X.isIdentity) → (λ _ → Univalent X.isIdentity) [ X.univalent ≡ b' ] - helper univ = propUnivalent x X.univalent univ - foo = pathJ P helper Y.isIdentity isIdentity + p univ = propUnivalent x X.univalent univ + helper : P Y.isIdentity isIdentity + helper = pathJ P p Y.isIdentity isIdentity eqUni : U isIdentity Y.univalent - eqUni = foo Y.univalent - IC.isAssociative (done i) = propIsAssociative x X.isAssociative Y.isAssociative i - IC.isIdentity (done i) = isIdentity i + eqUni = helper Y.univalent + done : x ≡ y + IC.isAssociative (done i) = propIsAssociative x X.isAssociative Y.isAssociative i + IC.isIdentity (done i) = isIdentity i IC.arrowsAreSets (done i) = propArrowIsSet x X.arrowsAreSets Y.arrowsAreSets i - IC.univalent (done i) = eqUni i + IC.univalent (done i) = eqUni i propIsCategory : isProp (IsCategory C) propIsCategory = done -- | Univalent categories -- --- Just bundles up the data with witnesses inhabting the propositions. +-- Just bundles up the data with witnesses inhabiting the propositions. record Category (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where field - raw : RawCategory ℓa ℓb + raw : RawCategory ℓa ℓb {{isCategory}} : IsCategory raw open IsCategory isCategory public -Category≡ : {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} → Category.raw ℂ ≡ Category.raw 𝔻 → ℂ ≡ 𝔻 -Category≡ {ℂ = ℂ} {𝔻} eq i = record - { raw = eq i - ; isCategory = isCategoryEq i - } - where - open Category - module ℂ = Category ℂ - isCategoryEq : (λ i → IsCategory (eq i)) [ isCategory ℂ ≡ isCategory 𝔻 ] - isCategoryEq = {!!} +-- The fact that being a category is a mere proposition gives rise to this +-- equality principle for categories. +module _ {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} where + private + module ℂ = Category ℂ + module 𝔻 = Category 𝔻 + + module _ (rawEq : ℂ.raw ≡ 𝔻.raw) where + private + P : (target : RawCategory ℓa ℓb) → ({!!} ≡ target) → Set _ + P _ eq = ∀ isCategory' → (λ i → IsCategory (eq i)) [ ℂ.isCategory ≡ isCategory' ] + + p : P ℂ.raw refl + p isCategory' = Propositionality.propIsCategory {!!} {!!} + + -- TODO Make and use heterogeneous version of Category≡ + isCategoryEq : (λ i → IsCategory (rawEq i)) [ ℂ.isCategory ≡ 𝔻.isCategory ] + isCategoryEq = {!!} + + Category≡ : ℂ ≡ 𝔻 + Category≡ i = record + { raw = rawEq i + ; isCategory = isCategoryEq i + } -- | Syntax for arrows- and composition in a given category. module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where @@ -318,7 +337,7 @@ module Opposite {ℓa ℓb : Level} where RawCategory._∘_ opRaw = Function.flip ℂ._∘_ open RawCategory opRaw - open Univalence opRaw + open Univalence opRaw isIdentity : IsIdentity 𝟙 isIdentity = swap ℂ.isIdentity diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index f020383..5a8d4c1 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -735,7 +735,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where m ∎ where lem : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ Function.id - lem = verso-recto Monoidal≃Kleisli + lem = {!!} -- verso-recto Monoidal≃Kleisli t : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} → a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b ≡ a ∘ b t {a = a} {b} = cong (λ φ → a ∘ φ ∘ b) lem @@ -763,7 +763,7 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ where - t = cong (λ φ → voe-2-3-1-fromMonad ∘ φ ∘ voe-2-3.voe-2-3-1.toMonad) (recto-verso Monoidal≃Kleisli) + t = {!!} -- cong (λ φ → voe-2-3-1-fromMonad ∘ φ ∘ voe-2-3.voe-2-3-1.toMonad) (recto-verso Monoidal≃Kleisli) voe-isEquiv : isEquiv (voe-2-3-1 omap pure) (voe-2-3-2 omap pure) forth voe-isEquiv = gradLemma forth back forthEq backEq diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index 0e19c04..af7567a 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -29,7 +29,7 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where -- -- In stead we'll use an ad-hoc definition -- which is definitionally -- equivalent to that other one. - _⇑_ = CatExponential.prodObj + _⇑_ = CatExponential.object module _ {A B : ℂ.Object} (f : ℂ [ A , B ]) where fmap : Transformation (prshf A) (prshf B) diff --git a/src/Cat/Wishlist.agda b/src/Cat/Wishlist.agda index d23f52a..8a63dc4 100644 --- a/src/Cat/Wishlist.agda +++ b/src/Cat/Wishlist.agda @@ -4,12 +4,13 @@ open import Level open import Cubical.NType open import Data.Nat using (_≤_ ; z≤n ; s≤s) +open import Cubical.NType.Properties public using (propHasLevel) + postulate ntypeCommulative : ∀ {ℓ n m} {A : Set ℓ} → n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A module _ {ℓ : Level} {A : Set ℓ} where - -- This is §7.1.10 in [HoTT]. Andrea says the proof is in `cubical` but I - -- can't find it. - postulate propHasLevel : ∀ n → isProp (HasLevel n A) - isSetIsProp : isProp (isSet A) isSetIsProp = propHasLevel (S (S ⟨-2⟩)) + + propIsProp : isProp (isProp A) + propIsProp = propHasLevel (S ⟨-2⟩) From a7214fcc66e6ca1a8ad95fcd9ff43cdac0acc16e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 13:51:29 +0100 Subject: [PATCH 82/91] Finish equality principle for categories --- src/Cat/Category.agda | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index 5a13f41..5b2f025 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -38,7 +38,7 @@ open import Data.Product renaming open import Data.Empty import Function open import Cubical -open import Cubical.NType.Properties using ( propIsEquiv ) +open import Cubical.NType.Properties using ( propIsEquiv ; lemPropF ) open import Cat.Wishlist @@ -195,9 +195,9 @@ record IsCategory {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) : Set (lsuc -- -- Proves that all projections of `IsCategory` are mere propositions as well as -- `IsCategory` itself being a mere proposition. -module Propositionality {ℓa ℓb : Level} {C : RawCategory ℓa ℓb} where - open RawCategory C - module _ (ℂ : IsCategory C) where +module Propositionality {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where + open RawCategory ℂ + module _ (ℂ : IsCategory ℂ) where open IsCategory ℂ using (isAssociative ; arrowsAreSets ; isIdentity ; Univalent) open import Cubical.NType open import Cubical.NType.Properties @@ -241,11 +241,11 @@ module Propositionality {ℓa ℓb : Level} {C : RawCategory ℓa ℓb} where propUnivalent a b i = propPi (λ iso → propHasLevel ⟨-2⟩) a b i private - module _ (x y : IsCategory C) where + module _ (x y : IsCategory ℂ) where module IC = IsCategory module X = IsCategory x module Y = IsCategory y - open Univalence C + open Univalence ℂ -- In a few places I use the result of propositionality of the various -- projections of `IsCategory` - I've arbitrarily chosed to use this -- result from `x : IsCategory C`. I don't know which (if any) possibly @@ -275,7 +275,7 @@ module Propositionality {ℓa ℓb : Level} {C : RawCategory ℓa ℓb} where IC.arrowsAreSets (done i) = propArrowIsSet x X.arrowsAreSets Y.arrowsAreSets i IC.univalent (done i) = eqUni i - propIsCategory : isProp (IsCategory C) + propIsCategory : isProp (IsCategory ℂ) propIsCategory = done -- | Univalent categories @@ -297,15 +297,8 @@ module _ {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} where module _ (rawEq : ℂ.raw ≡ 𝔻.raw) where private - P : (target : RawCategory ℓa ℓb) → ({!!} ≡ target) → Set _ - P _ eq = ∀ isCategory' → (λ i → IsCategory (eq i)) [ ℂ.isCategory ≡ isCategory' ] - - p : P ℂ.raw refl - p isCategory' = Propositionality.propIsCategory {!!} {!!} - - -- TODO Make and use heterogeneous version of Category≡ isCategoryEq : (λ i → IsCategory (rawEq i)) [ ℂ.isCategory ≡ 𝔻.isCategory ] - isCategoryEq = {!!} + isCategoryEq = lemPropF Propositionality.propIsCategory rawEq Category≡ : ℂ ≡ 𝔻 Category≡ i = record From c0cf6789cdfc3585106ffaeb2951e84ffafae309 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 13:56:49 +0100 Subject: [PATCH 83/91] Use propositions straight from the horses mouth --- libs/cubical | 2 +- src/Cat/Wishlist.agda | 9 +-------- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/libs/cubical b/libs/cubical index 3a125a0..5b35333 160000 --- a/libs/cubical +++ b/libs/cubical @@ -1 +1 @@ -Subproject commit 3a125a0cb010903e6aa80569a0ca5339424eaf86 +Subproject commit 5b35333dbbd8fa523e478c1cfe60657321ca38fe diff --git a/src/Cat/Wishlist.agda b/src/Cat/Wishlist.agda index 8a63dc4..67eeccc 100644 --- a/src/Cat/Wishlist.agda +++ b/src/Cat/Wishlist.agda @@ -4,13 +4,6 @@ open import Level open import Cubical.NType open import Data.Nat using (_≤_ ; z≤n ; s≤s) -open import Cubical.NType.Properties public using (propHasLevel) +open import Cubical.NType.Properties postulate ntypeCommulative : ∀ {ℓ n m} {A : Set ℓ} → n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A - -module _ {ℓ : Level} {A : Set ℓ} where - isSetIsProp : isProp (isSet A) - isSetIsProp = propHasLevel (S (S ⟨-2⟩)) - - propIsProp : isProp (isProp A) - propIsProp = propHasLevel (S ⟨-2⟩) From aa645fb11e9edab11bb925d682f843d8f138bbe7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 14:04:10 +0100 Subject: [PATCH 84/91] Move voevodsky's construction to own module --- src/Cat.agda | 1 + src/Cat/Category/Monad.agda | 208 ------------------------ src/Cat/Category/Monad/Voevodsky.agda | 221 ++++++++++++++++++++++++++ 3 files changed, 222 insertions(+), 208 deletions(-) create mode 100644 src/Cat/Category/Monad/Voevodsky.agda diff --git a/src/Cat.agda b/src/Cat.agda index 478b725..86e6879 100644 --- a/src/Cat.agda +++ b/src/Cat.agda @@ -9,6 +9,7 @@ open import Cat.Category.CartesianClosed open import Cat.Category.NaturalTransformation open import Cat.Category.Yoneda open import Cat.Category.Monad +open import Cat.Category.Monad.Voevodsky open import Cat.Categories.Sets open import Cat.Categories.Cat diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 5a8d4c1..257721e 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -389,9 +389,6 @@ module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where Monad.isMonad (Monad≡ i) = eqIsMonad i -- | The monoidal- and kleisli presentation of monads are equivalent. --- --- This is *not* problem 2.3 in [voe]. --- This is problem 2.3 in [voe]. module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private module ℂ = Category ℂ @@ -565,208 +562,3 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Monoidal≃Kleisli : M.Monad ≃ K.Monad Monoidal≃Kleisli = forth , eqv - -module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where - private - ℓ = ℓa ⊔ ℓb - module ℂ = Category ℂ - open ℂ using (Object ; Arrow ; _∘_) - open NaturalTransformation ℂ ℂ - module M = Monoidal ℂ - module K = Kleisli ℂ - - module voe-2-3 (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where - record voe-2-3-1 : Set ℓ where - open M - - field - fmap : Fmap ℂ ℂ omap - join : {A : Object} → ℂ [ omap (omap A) , omap A ] - - Rraw : RawFunctor ℂ ℂ - Rraw = record - { omap = omap - ; fmap = fmap - } - - field - RisFunctor : IsFunctor ℂ ℂ Rraw - - R : EndoFunctor ℂ - R = record - { raw = Rraw - ; isFunctor = RisFunctor - } - - pureT : (X : Object) → Arrow X (omap X) - pureT X = pure {X} - - field - pureN : Natural F.identity R pureT - - pureNT : NaturalTransformation F.identity R - pureNT = pureT , pureN - - joinT : (A : Object) → ℂ [ omap (omap A) , omap A ] - joinT A = join {A} - - field - joinN : Natural F[ R ∘ R ] R joinT - - joinNT : NaturalTransformation F[ R ∘ R ] R - joinNT = joinT , joinN - - rawMnd : RawMonad - rawMnd = record - { R = R - ; pureNT = pureNT - ; joinNT = joinNT - } - - field - isMnd : IsMonad rawMnd - - toMonad : Monad - toMonad = record - { raw = rawMnd - ; isMonad = isMnd - } - - record voe-2-3-2 : Set ℓ where - open K - - field - bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] - - rawMnd : RawMonad - rawMnd = record - { omap = omap - ; pure = pure - ; bind = bind - } - - field - isMnd : IsMonad rawMnd - - toMonad : Monad - toMonad = record - { raw = rawMnd - ; isMonad = isMnd - } - -module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where - private - module M = Monoidal ℂ - module K = Kleisli ℂ - open voe-2-3 ℂ - - voe-2-3-1-fromMonad : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) - voe-2-3-1-fromMonad m = record - { fmap = Functor.fmap R - ; RisFunctor = Functor.isFunctor R - ; pureN = pureN - ; join = λ {X} → joinT X - ; joinN = joinN - ; isMnd = M.Monad.isMonad m - } - where - raw = M.Monad.raw m - R = M.RawMonad.R raw - pureT = M.RawMonad.pureT raw - pureN = M.RawMonad.pureN raw - joinT = M.RawMonad.joinT raw - joinN = M.RawMonad.joinN raw - - voe-2-3-2-fromMonad : (m : K.Monad) → voe-2-3-2 (K.Monad.omap m) (K.Monad.pure m) - voe-2-3-2-fromMonad m = record - { bind = K.Monad.bind m - ; isMnd = K.Monad.isMonad m - } - -module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where - private - ℓ = ℓa ⊔ ℓb - module ℂ = Category ℂ - open ℂ using (Object ; Arrow) - open NaturalTransformation ℂ ℂ - module M = Monoidal ℂ - module K = Kleisli ℂ - open import Function using (_∘_ ; _$_) - - module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where - open voe-2-3 ℂ - private - Monoidal→Kleisli : M.Monad → K.Monad - Monoidal→Kleisli = proj₁ Monoidal≃Kleisli - - Kleisli→Monoidal : K.Monad → M.Monad - Kleisli→Monoidal = inverse Monoidal≃Kleisli - - forth : voe-2-3-1 omap pure → voe-2-3-2 omap pure - forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ voe-2-3.voe-2-3-1.toMonad - - back : voe-2-3-2 omap pure → voe-2-3-1 omap pure - back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ voe-2-3.voe-2-3-2.toMonad - - forthEq : ∀ m → _ ≡ _ - forthEq m = begin - (forth ∘ back) m ≡⟨⟩ - -- In full gory detail: - ( voe-2-3-2-fromMonad - ∘ Monoidal→Kleisli - ∘ voe-2-3.voe-2-3-1.toMonad - ∘ voe-2-3-1-fromMonad - ∘ Kleisli→Monoidal - ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨⟩ -- fromMonad and toMonad are inverses - ( voe-2-3-2-fromMonad - ∘ Monoidal→Kleisli - ∘ Kleisli→Monoidal - ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨ u ⟩ - -- Monoidal→Kleisli and Kleisli→Monoidal are inverses - -- I should be able to prove this using congruence and `lem` below. - ( voe-2-3-2-fromMonad - ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨⟩ - ( voe-2-3-2-fromMonad - ∘ voe-2-3.voe-2-3-2.toMonad - ) m ≡⟨⟩ -- fromMonad and toMonad are inverses - m ∎ - where - lem : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ Function.id - lem = {!!} -- verso-recto Monoidal≃Kleisli - t : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} - → a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b ≡ a ∘ b - t {a = a} {b} = cong (λ φ → a ∘ φ ∘ b) lem - u : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} - → {m : _} → (a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b) m ≡ (a ∘ b) m - u {m = m} = cong (λ φ → φ m) t - - backEq : ∀ m → (back ∘ forth) m ≡ m - backEq m = begin - (back ∘ forth) m ≡⟨⟩ - ( voe-2-3-1-fromMonad - ∘ Kleisli→Monoidal - ∘ voe-2-3.voe-2-3-2.toMonad - ∘ voe-2-3-2-fromMonad - ∘ Monoidal→Kleisli - ∘ voe-2-3.voe-2-3-1.toMonad - ) m ≡⟨⟩ -- fromMonad and toMonad are inverses - ( voe-2-3-1-fromMonad - ∘ Kleisli→Monoidal - ∘ Monoidal→Kleisli - ∘ voe-2-3.voe-2-3-1.toMonad - ) m ≡⟨ cong (λ φ → φ m) t ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses - ( voe-2-3-1-fromMonad - ∘ voe-2-3.voe-2-3-1.toMonad - ) m ≡⟨⟩ -- fromMonad and toMonad are inverses - m ∎ - where - t = {!!} -- cong (λ φ → voe-2-3-1-fromMonad ∘ φ ∘ voe-2-3.voe-2-3-1.toMonad) (recto-verso Monoidal≃Kleisli) - - voe-isEquiv : isEquiv (voe-2-3-1 omap pure) (voe-2-3-2 omap pure) forth - voe-isEquiv = gradLemma forth back forthEq backEq - - equiv-2-3 : voe-2-3-1 omap pure ≃ voe-2-3-2 omap pure - equiv-2-3 = forth , voe-isEquiv diff --git a/src/Cat/Category/Monad/Voevodsky.agda b/src/Cat/Category/Monad/Voevodsky.agda new file mode 100644 index 0000000..02898a1 --- /dev/null +++ b/src/Cat/Category/Monad/Voevodsky.agda @@ -0,0 +1,221 @@ +{-# OPTIONS --cubical --allow-unsolved-metas #-} +module Cat.Category.Monad.Voevodsky where + +open import Agda.Primitive + +open import Data.Product + +open import Cubical +open import Cubical.NType.Properties using (lemPropF ; lemSig ; lemSigP) +open import Cubical.GradLemma using (gradLemma) + +open import Cat.Category +open import Cat.Category.Functor as F +open import Cat.Category.NaturalTransformation +open import Cat.Category.Monad +open import Cat.Categories.Fun + +module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where + private + ℓ = ℓa ⊔ ℓb + module ℂ = Category ℂ + open ℂ using (Object ; Arrow ; _∘_) + open NaturalTransformation ℂ ℂ + module M = Monoidal ℂ + module K = Kleisli ℂ + + module voe-2-3 (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where + record voe-2-3-1 : Set ℓ where + open M + + field + fmap : Fmap ℂ ℂ omap + join : {A : Object} → ℂ [ omap (omap A) , omap A ] + + Rraw : RawFunctor ℂ ℂ + Rraw = record + { omap = omap + ; fmap = fmap + } + + field + RisFunctor : IsFunctor ℂ ℂ Rraw + + R : EndoFunctor ℂ + R = record + { raw = Rraw + ; isFunctor = RisFunctor + } + + pureT : (X : Object) → Arrow X (omap X) + pureT X = pure {X} + + field + pureN : Natural F.identity R pureT + + pureNT : NaturalTransformation F.identity R + pureNT = pureT , pureN + + joinT : (A : Object) → ℂ [ omap (omap A) , omap A ] + joinT A = join {A} + + field + joinN : Natural F[ R ∘ R ] R joinT + + joinNT : NaturalTransformation F[ R ∘ R ] R + joinNT = joinT , joinN + + rawMnd : RawMonad + rawMnd = record + { R = R + ; pureNT = pureNT + ; joinNT = joinNT + } + + field + isMnd : IsMonad rawMnd + + toMonad : Monad + toMonad = record + { raw = rawMnd + ; isMonad = isMnd + } + + record voe-2-3-2 : Set ℓ where + open K + + field + bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] + + rawMnd : RawMonad + rawMnd = record + { omap = omap + ; pure = pure + ; bind = bind + } + + field + isMnd : IsMonad rawMnd + + toMonad : Monad + toMonad = record + { raw = rawMnd + ; isMonad = isMnd + } + +module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where + private + module M = Monoidal ℂ + module K = Kleisli ℂ + open voe-2-3 ℂ + + voe-2-3-1-fromMonad : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + voe-2-3-1-fromMonad m = record + { fmap = Functor.fmap R + ; RisFunctor = Functor.isFunctor R + ; pureN = pureN + ; join = λ {X} → joinT X + ; joinN = joinN + ; isMnd = M.Monad.isMonad m + } + where + raw = M.Monad.raw m + R = M.RawMonad.R raw + pureT = M.RawMonad.pureT raw + pureN = M.RawMonad.pureN raw + joinT = M.RawMonad.joinT raw + joinN = M.RawMonad.joinN raw + + voe-2-3-2-fromMonad : (m : K.Monad) → voe-2-3-2 (K.Monad.omap m) (K.Monad.pure m) + voe-2-3-2-fromMonad m = record + { bind = K.Monad.bind m + ; isMnd = K.Monad.isMonad m + } + +module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where + private + ℓ = ℓa ⊔ ℓb + module ℂ = Category ℂ + open ℂ using (Object ; Arrow) + open NaturalTransformation ℂ ℂ + module M = Monoidal ℂ + module K = Kleisli ℂ + open import Function using (_∘_ ; _$_) + + module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where + open voe-2-3 ℂ + private + Monoidal→Kleisli : M.Monad → K.Monad + Monoidal→Kleisli = proj₁ Monoidal≃Kleisli + + Kleisli→Monoidal : K.Monad → M.Monad + Kleisli→Monoidal = inverse Monoidal≃Kleisli + + forth : voe-2-3-1 omap pure → voe-2-3-2 omap pure + forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ voe-2-3.voe-2-3-1.toMonad + + back : voe-2-3-2 omap pure → voe-2-3-1 omap pure + back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ voe-2-3.voe-2-3-2.toMonad + + forthEq : ∀ m → _ ≡ _ + forthEq m = begin + (forth ∘ back) m ≡⟨⟩ + -- In full gory detail: + ( voe-2-3-2-fromMonad + ∘ Monoidal→Kleisli + ∘ voe-2-3.voe-2-3-1.toMonad + ∘ voe-2-3-1-fromMonad + ∘ Kleisli→Monoidal + ∘ voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + ( voe-2-3-2-fromMonad + ∘ Monoidal→Kleisli + ∘ Kleisli→Monoidal + ∘ voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨ u ⟩ + -- Monoidal→Kleisli and Kleisli→Monoidal are inverses + -- I should be able to prove this using congruence and `lem` below. + ( voe-2-3-2-fromMonad + ∘ voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨⟩ + ( voe-2-3-2-fromMonad + ∘ voe-2-3.voe-2-3-2.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + m ∎ + where + lem : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ Function.id + lem = {!!} -- verso-recto Monoidal≃Kleisli + t : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} + → a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b ≡ a ∘ b + t {a = a} {b} = cong (λ φ → a ∘ φ ∘ b) lem + u : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} + → {m : _} → (a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b) m ≡ (a ∘ b) m + u {m = m} = cong (λ φ → φ m) t + + backEq : ∀ m → (back ∘ forth) m ≡ m + backEq m = begin + (back ∘ forth) m ≡⟨⟩ + ( voe-2-3-1-fromMonad + ∘ Kleisli→Monoidal + ∘ voe-2-3.voe-2-3-2.toMonad + ∘ voe-2-3-2-fromMonad + ∘ Monoidal→Kleisli + ∘ voe-2-3.voe-2-3-1.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + ( voe-2-3-1-fromMonad + ∘ Kleisli→Monoidal + ∘ Monoidal→Kleisli + ∘ voe-2-3.voe-2-3-1.toMonad + ) m ≡⟨ cong (λ φ → φ m) t ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses + ( voe-2-3-1-fromMonad + ∘ voe-2-3.voe-2-3-1.toMonad + ) m ≡⟨⟩ -- fromMonad and toMonad are inverses + m ∎ + where + t = {!!} -- cong (λ φ → voe-2-3-1-fromMonad ∘ φ ∘ voe-2-3.voe-2-3-1.toMonad) (recto-verso Monoidal≃Kleisli) + + voe-isEquiv : isEquiv (voe-2-3-1 omap pure) (voe-2-3-2 omap pure) forth + voe-isEquiv = gradLemma forth back forthEq backEq + + equiv-2-3 : voe-2-3-1 omap pure ≃ voe-2-3-2 omap pure + equiv-2-3 = forth , voe-isEquiv From 8dadfa22a0b02382f9c6015e7311ed515ff99c26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 14:11:31 +0100 Subject: [PATCH 85/91] Add documentation header to monad module --- src/Cat/Category/Monad.agda | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 257721e..db4e356 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -1,3 +1,21 @@ +{--- +Monads + +This module presents two formulations of monads: + + * The standard monoidal presentation + * Kleisli's presentation + +The first one defines a monad in terms of an endofunctor and two natural +transformations. The second defines it in terms of a function on objects and a +pair of arrows. + +These two formulations are proven to be equivalent: + + Monoidal.Monad ≃ Kleisli.Monad + + ---} + {-# OPTIONS --cubical --allow-unsolved-metas #-} module Cat.Category.Monad where From ccf753d4386c75250cd5b2d74e03a4b07846c53b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 14:20:49 +0100 Subject: [PATCH 86/91] Move monoidal and kleisli representation to own modules --- src/Cat/Category/Monad.agda | 377 +------------------------- src/Cat/Category/Monad/Kleisli.agda | 253 +++++++++++++++++ src/Cat/Category/Monad/Monoidal.agda | 154 +++++++++++ src/Cat/Category/Monad/Voevodsky.agda | 4 +- 4 files changed, 413 insertions(+), 375 deletions(-) create mode 100644 src/Cat/Category/Monad/Kleisli.agda create mode 100644 src/Cat/Category/Monad/Monoidal.agda diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index db4e356..2f42f32 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -14,6 +14,7 @@ These two formulations are proven to be equivalent: Monoidal.Monad ≃ Kleisli.Monad +The monoidal representation is exposed by default from this module. ---} {-# OPTIONS --cubical --allow-unsolved-metas #-} @@ -30,382 +31,10 @@ open import Cubical.GradLemma using (gradLemma) open import Cat.Category open import Cat.Category.Functor as F open import Cat.Category.NaturalTransformation +open import Cat.Category.Monad.Monoidal as Monoidal public +open import Cat.Category.Monad.Kleisli as Kleisli open import Cat.Categories.Fun --- "A monad in the monoidal form" [voe] -module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where - private - ℓ = ℓa ⊔ ℓb - - open Category ℂ using (Object ; Arrow ; 𝟙 ; _∘_) - open NaturalTransformation ℂ ℂ - record RawMonad : Set ℓ where - field - R : EndoFunctor ℂ - pureNT : NaturalTransformation F.identity R - joinNT : NaturalTransformation F[ R ∘ R ] R - - -- Note that `pureT` and `joinT` differs from their definition in the - -- kleisli formulation only by having an explicit parameter. - pureT : Transformation F.identity R - pureT = proj₁ pureNT - pureN : Natural F.identity R pureT - pureN = proj₂ pureNT - - joinT : Transformation F[ R ∘ R ] R - joinT = proj₁ joinNT - joinN : Natural F[ R ∘ R ] R joinT - joinN = proj₂ joinNT - - Romap = Functor.omap R - Rfmap = Functor.fmap R - - bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] - bind {X} {Y} f = joinT Y ∘ Rfmap f - - IsAssociative : Set _ - IsAssociative = {X : Object} - → joinT X ∘ Rfmap (joinT X) ≡ joinT X ∘ joinT (Romap X) - IsInverse : Set _ - IsInverse = {X : Object} - → joinT X ∘ pureT (Romap X) ≡ 𝟙 - × joinT X ∘ Rfmap (pureT X) ≡ 𝟙 - IsNatural = ∀ {X Y} f → joinT Y ∘ Rfmap f ∘ pureT X ≡ f - IsDistributive = ∀ {X Y Z} (g : Arrow Y (Romap Z)) (f : Arrow X (Romap Y)) - → joinT Z ∘ Rfmap g ∘ (joinT Y ∘ Rfmap f) - ≡ joinT Z ∘ Rfmap (joinT Z ∘ Rfmap g ∘ f) - - record IsMonad (raw : RawMonad) : Set ℓ where - open RawMonad raw public - field - isAssociative : IsAssociative - isInverse : IsInverse - - private - module R = Functor R - module ℂ = Category ℂ - - isNatural : IsNatural - isNatural {X} {Y} f = begin - joinT Y ∘ R.fmap f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩ - joinT Y ∘ (R.fmap f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩ - joinT Y ∘ (pureT (R.omap Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ - joinT Y ∘ pureT (R.omap Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ - 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ - f ∎ - - isDistributive : IsDistributive - isDistributive {X} {Y} {Z} g f = sym aux - where - module R² = Functor F[ R ∘ R ] - distrib3 : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} - → R.fmap (a ∘ b ∘ c) - ≡ R.fmap a ∘ R.fmap b ∘ R.fmap c - distrib3 {a = a} {b} {c} = begin - R.fmap (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩ - R.fmap (a ∘ b) ∘ R.fmap c ≡⟨ cong (_∘ _) R.isDistributive ⟩ - 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 - field - raw : RawMonad - isMonad : IsMonad raw - open IsMonad isMonad public - - private - module _ {m : RawMonad} where - open RawMonad m - propIsAssociative : isProp IsAssociative - propIsAssociative x y i {X} - = Category.arrowsAreSets ℂ _ _ (x {X}) (y {X}) i - propIsInverse : isProp IsInverse - propIsInverse x y i {X} = e1 i , e2 i - where - xX = x {X} - yX = y {X} - e1 = Category.arrowsAreSets ℂ _ _ (proj₁ xX) (proj₁ yX) - e2 = Category.arrowsAreSets ℂ _ _ (proj₂ xX) (proj₂ yX) - - open IsMonad - propIsMonad : (raw : _) → isProp (IsMonad raw) - IsMonad.isAssociative (propIsMonad raw a b i) j - = propIsAssociative {raw} - (isAssociative a) (isAssociative b) i j - IsMonad.isInverse (propIsMonad raw a b i) - = propIsInverse {raw} - (isInverse a) (isInverse b) i - - module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where - private - eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - eqIsMonad = lemPropF propIsMonad eq - - Monad≡ : m ≡ n - Monad.raw (Monad≡ i) = eq i - Monad.isMonad (Monad≡ i) = eqIsMonad i - --- "A monad in the Kleisli form" [voe] -module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where - private - ℓ = ℓa ⊔ ℓb - module ℂ = Category ℂ - open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) - - -- | Data for a monad. - -- - -- Note that (>>=) is not expressible in a general category because objects - -- are not generally types. - record RawMonad : Set ℓ where - field - omap : Object → Object - pure : {X : Object} → ℂ [ X , omap X ] - bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] - - -- | functor map - -- - -- This should perhaps be defined in a "Klesli-version" of functors as well? - fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ] - fmap f = bind (pure ∘ f) - - -- | Composition of monads aka. the kleisli-arrow. - _>=>_ : {A B C : Object} → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ] - f >=> g = f >>> (bind g) - - -- | Flattening nested monads. - join : {A : Object} → ℂ [ omap (omap A) , omap A ] - join = bind 𝟙 - - ------------------ - -- * Monad laws -- - ------------------ - - -- There may be better names than what I've chosen here. - - IsIdentity = {X : Object} - → bind pure ≡ 𝟙 {omap X} - IsNatural = {X Y : Object} (f : ℂ [ X , omap Y ]) - → pure >>> (bind f) ≡ f - IsDistributive = {X Y Z : Object} (g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ]) - → (bind f) >>> (bind g) ≡ bind (f >=> g) - - -- | Functor map fusion. - -- - -- This is really a functor law. Should we have a kleisli-representation of - -- functors as well and make them a super-class? - Fusion = {X Y Z : Object} {g : ℂ [ Y , Z ]} {f : ℂ [ X , Y ]} - → fmap (g ∘ f) ≡ fmap g ∘ fmap f - - -- In the ("foreign") formulation of a monad `IsNatural`'s analogue here would be: - IsNaturalForeign : Set _ - IsNaturalForeign = {X : Object} → join {X} ∘ fmap join ≡ join ∘ join - - IsInverse : Set _ - IsInverse = {X : Object} → join {X} ∘ pure ≡ 𝟙 × join {X} ∘ fmap pure ≡ 𝟙 - - record IsMonad (raw : RawMonad) : Set ℓ where - open RawMonad raw public - field - isIdentity : IsIdentity - isNatural : IsNatural - isDistributive : IsDistributive - - -- | Map fusion is admissable. - fusion : Fusion - fusion {g = g} {f} = begin - fmap (g ∘ f) ≡⟨⟩ - bind ((f >>> g) >>> pure) ≡⟨ cong bind ℂ.isAssociative ⟩ - 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 distrib ⟩ - bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ - fmap g ∘ fmap f ∎ - where - distrib : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) - distrib = isDistributive (pure ∘ g) (pure ∘ f) - - -- | This formulation gives rise to the following endo-functor. - private - rawR : RawFunctor ℂ ℂ - RawFunctor.omap rawR = omap - RawFunctor.fmap rawR = fmap - - isFunctorR : IsFunctor ℂ ℂ rawR - IsFunctor.isIdentity isFunctorR = begin - bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ - bind pure ≡⟨ isIdentity ⟩ - 𝟙 ∎ - - IsFunctor.isDistributive isFunctorR {f = f} {g} = begin - bind (pure ∘ (g ∘ f)) ≡⟨⟩ - fmap (g ∘ f) ≡⟨ fusion ⟩ - fmap g ∘ fmap f ≡⟨⟩ - bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ - - -- FIXME Naming! - R : EndoFunctor ℂ - Functor.raw R = rawR - Functor.isFunctor R = isFunctorR - - private - open NaturalTransformation ℂ ℂ - - R⁰ : EndoFunctor ℂ - R⁰ = F.identity - R² : EndoFunctor ℂ - R² = F[ R ∘ R ] - module R = Functor R - module R⁰ = Functor R⁰ - module R² = Functor R² - pureT : Transformation R⁰ R - pureT A = pure - pureN : Natural R⁰ R pureT - pureN {A} {B} f = begin - pureT B ∘ R⁰.fmap f ≡⟨⟩ - pure ∘ f ≡⟨ sym (isNatural _) ⟩ - bind (pure ∘ f) ∘ pure ≡⟨⟩ - fmap f ∘ pure ≡⟨⟩ - R.fmap f ∘ pureT A ∎ - joinT : Transformation R² R - joinT C = join - joinN : Natural R² R joinT - joinN f = begin - join ∘ R².fmap f ≡⟨⟩ - bind 𝟙 ∘ R².fmap f ≡⟨⟩ - R².fmap f >>> bind 𝟙 ≡⟨⟩ - fmap (fmap f) >>> bind 𝟙 ≡⟨⟩ - fmap (bind (f >>> pure)) >>> bind 𝟙 ≡⟨⟩ - bind (bind (f >>> pure) >>> pure) >>> bind 𝟙 - ≡⟨ isDistributive _ _ ⟩ - bind ((bind (f >>> pure) >>> pure) >=> 𝟙) - ≡⟨⟩ - bind ((bind (f >>> pure) >>> pure) >>> bind 𝟙) - ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (bind (f >>> pure) >>> (pure >>> bind 𝟙)) - ≡⟨ cong (λ φ → bind (bind (f >>> pure) >>> φ)) (isNatural _) ⟩ - bind (bind (f >>> pure) >>> 𝟙) - ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ - bind (bind (f >>> pure)) - ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ - bind (𝟙 >>> bind (f >>> pure)) ≡⟨⟩ - bind (𝟙 >=> (f >>> pure)) - ≡⟨ sym (isDistributive _ _) ⟩ - bind 𝟙 >>> bind (f >>> pure) ≡⟨⟩ - bind 𝟙 >>> fmap f ≡⟨⟩ - bind 𝟙 >>> R.fmap f ≡⟨⟩ - R.fmap f ∘ bind 𝟙 ≡⟨⟩ - R.fmap f ∘ join ∎ - - pureNT : NaturalTransformation R⁰ R - proj₁ pureNT = pureT - proj₂ pureNT = pureN - - joinNT : NaturalTransformation R² R - proj₁ joinNT = joinT - proj₂ joinNT = joinN - - isNaturalForeign : IsNaturalForeign - isNaturalForeign = begin - fmap join >>> join ≡⟨⟩ - bind (join >>> pure) >>> bind 𝟙 - ≡⟨ isDistributive _ _ ⟩ - bind ((join >>> pure) >>> bind 𝟙) - ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (join >>> (pure >>> bind 𝟙)) - ≡⟨ cong (λ φ → bind (join >>> φ)) (isNatural _) ⟩ - bind (join >>> 𝟙) - ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ - bind join ≡⟨⟩ - bind (bind 𝟙) - ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ - bind (𝟙 >>> bind 𝟙) ≡⟨⟩ - bind (𝟙 >=> 𝟙) ≡⟨ sym (isDistributive _ _) ⟩ - bind 𝟙 >>> bind 𝟙 ≡⟨⟩ - join >>> join ∎ - - isInverse : IsInverse - isInverse = inv-l , inv-r - where - inv-l = begin - pure >>> join ≡⟨⟩ - pure >>> bind 𝟙 ≡⟨ isNatural _ ⟩ - 𝟙 ∎ - inv-r = begin - fmap pure >>> join ≡⟨⟩ - bind (pure >>> pure) >>> bind 𝟙 - ≡⟨ isDistributive _ _ ⟩ - bind ((pure >>> pure) >=> 𝟙) ≡⟨⟩ - bind ((pure >>> pure) >>> bind 𝟙) - ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (pure >>> (pure >>> bind 𝟙)) - ≡⟨ cong (λ φ → bind (pure >>> φ)) (isNatural _) ⟩ - bind (pure >>> 𝟙) - ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ - bind pure ≡⟨ isIdentity ⟩ - 𝟙 ∎ - - record Monad : Set ℓ where - field - raw : RawMonad - isMonad : IsMonad raw - open IsMonad isMonad public - - private - module _ (raw : RawMonad) where - open RawMonad raw - propIsIdentity : isProp IsIdentity - propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i - propIsNatural : isProp IsNatural - propIsNatural x y i = λ f - → ℂ.arrowsAreSets _ _ (x f) (y f) i - propIsDistributive : isProp IsDistributive - propIsDistributive x y i = λ g f - → ℂ.arrowsAreSets _ _ (x g f) (y g f) i - - open IsMonad - propIsMonad : (raw : _) → isProp (IsMonad raw) - IsMonad.isIdentity (propIsMonad raw x y i) - = propIsIdentity raw (isIdentity x) (isIdentity y) i - IsMonad.isNatural (propIsMonad raw x y i) - = propIsNatural raw (isNatural x) (isNatural y) i - IsMonad.isDistributive (propIsMonad raw x y i) - = propIsDistributive raw (isDistributive x) (isDistributive y) i - - module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where - private - eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - eqIsMonad = lemPropF propIsMonad eq - - Monad≡ : m ≡ n - Monad.raw (Monad≡ i) = eq i - Monad.isMonad (Monad≡ i) = eqIsMonad i - -- | The monoidal- and kleisli presentation of monads are equivalent. module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private diff --git a/src/Cat/Category/Monad/Kleisli.agda b/src/Cat/Category/Monad/Kleisli.agda new file mode 100644 index 0000000..8f96b82 --- /dev/null +++ b/src/Cat/Category/Monad/Kleisli.agda @@ -0,0 +1,253 @@ +{--- +The Kleisli formulation of monads + ---} +{-# OPTIONS --cubical --allow-unsolved-metas #-} +open import Agda.Primitive + +open import Data.Product + +open import Cubical +open import Cubical.NType.Properties using (lemPropF ; lemSig ; lemSigP) +open import Cubical.GradLemma using (gradLemma) + +open import Cat.Category +open import Cat.Category.Functor as F +open import Cat.Category.NaturalTransformation +open import Cat.Categories.Fun + +-- "A monad in the Kleisli form" [voe] +module Cat.Category.Monad.Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where +private + ℓ = ℓa ⊔ ℓb + module ℂ = Category ℂ + open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) + +-- | Data for a monad. +-- +-- Note that (>>=) is not expressible in a general category because objects +-- are not generally types. +record RawMonad : Set ℓ where + field + omap : Object → Object + pure : {X : Object} → ℂ [ X , omap X ] + bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] + + -- | functor map + -- + -- This should perhaps be defined in a "Klesli-version" of functors as well? + fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ] + fmap f = bind (pure ∘ f) + + -- | Composition of monads aka. the kleisli-arrow. + _>=>_ : {A B C : Object} → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ] + f >=> g = f >>> (bind g) + + -- | Flattening nested monads. + join : {A : Object} → ℂ [ omap (omap A) , omap A ] + join = bind 𝟙 + + ------------------ + -- * Monad laws -- + ------------------ + + -- There may be better names than what I've chosen here. + + IsIdentity = {X : Object} + → bind pure ≡ 𝟙 {omap X} + IsNatural = {X Y : Object} (f : ℂ [ X , omap Y ]) + → pure >>> (bind f) ≡ f + IsDistributive = {X Y Z : Object} (g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ]) + → (bind f) >>> (bind g) ≡ bind (f >=> g) + + -- | Functor map fusion. + -- + -- This is really a functor law. Should we have a kleisli-representation of + -- functors as well and make them a super-class? + Fusion = {X Y Z : Object} {g : ℂ [ Y , Z ]} {f : ℂ [ X , Y ]} + → fmap (g ∘ f) ≡ fmap g ∘ fmap f + + -- In the ("foreign") formulation of a monad `IsNatural`'s analogue here would be: + IsNaturalForeign : Set _ + IsNaturalForeign = {X : Object} → join {X} ∘ fmap join ≡ join ∘ join + + IsInverse : Set _ + IsInverse = {X : Object} → join {X} ∘ pure ≡ 𝟙 × join {X} ∘ fmap pure ≡ 𝟙 + +record IsMonad (raw : RawMonad) : Set ℓ where + open RawMonad raw public + field + isIdentity : IsIdentity + isNatural : IsNatural + isDistributive : IsDistributive + + -- | Map fusion is admissable. + fusion : Fusion + fusion {g = g} {f} = begin + fmap (g ∘ f) ≡⟨⟩ + bind ((f >>> g) >>> pure) ≡⟨ cong bind ℂ.isAssociative ⟩ + 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 distrib ⟩ + bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ + fmap g ∘ fmap f ∎ + where + distrib : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) + distrib = isDistributive (pure ∘ g) (pure ∘ f) + + -- | This formulation gives rise to the following endo-functor. + private + rawR : RawFunctor ℂ ℂ + RawFunctor.omap rawR = omap + RawFunctor.fmap rawR = fmap + + isFunctorR : IsFunctor ℂ ℂ rawR + IsFunctor.isIdentity isFunctorR = begin + bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ + bind pure ≡⟨ isIdentity ⟩ + 𝟙 ∎ + + IsFunctor.isDistributive isFunctorR {f = f} {g} = begin + bind (pure ∘ (g ∘ f)) ≡⟨⟩ + fmap (g ∘ f) ≡⟨ fusion ⟩ + fmap g ∘ fmap f ≡⟨⟩ + bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ + + -- FIXME Naming! + R : EndoFunctor ℂ + Functor.raw R = rawR + Functor.isFunctor R = isFunctorR + + private + open NaturalTransformation ℂ ℂ + + R⁰ : EndoFunctor ℂ + R⁰ = F.identity + R² : EndoFunctor ℂ + R² = F[ R ∘ R ] + module R = Functor R + module R⁰ = Functor R⁰ + module R² = Functor R² + pureT : Transformation R⁰ R + pureT A = pure + pureN : Natural R⁰ R pureT + pureN {A} {B} f = begin + pureT B ∘ R⁰.fmap f ≡⟨⟩ + pure ∘ f ≡⟨ sym (isNatural _) ⟩ + bind (pure ∘ f) ∘ pure ≡⟨⟩ + fmap f ∘ pure ≡⟨⟩ + R.fmap f ∘ pureT A ∎ + joinT : Transformation R² R + joinT C = join + joinN : Natural R² R joinT + joinN f = begin + join ∘ R².fmap f ≡⟨⟩ + bind 𝟙 ∘ R².fmap f ≡⟨⟩ + R².fmap f >>> bind 𝟙 ≡⟨⟩ + fmap (fmap f) >>> bind 𝟙 ≡⟨⟩ + fmap (bind (f >>> pure)) >>> bind 𝟙 ≡⟨⟩ + bind (bind (f >>> pure) >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((bind (f >>> pure) >>> pure) >=> 𝟙) + ≡⟨⟩ + bind ((bind (f >>> pure) >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (bind (f >>> pure) >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (bind (f >>> pure) >>> φ)) (isNatural _) ⟩ + bind (bind (f >>> pure) >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind (bind (f >>> pure)) + ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ + bind (𝟙 >>> bind (f >>> pure)) ≡⟨⟩ + bind (𝟙 >=> (f >>> pure)) + ≡⟨ sym (isDistributive _ _) ⟩ + bind 𝟙 >>> bind (f >>> pure) ≡⟨⟩ + bind 𝟙 >>> fmap f ≡⟨⟩ + bind 𝟙 >>> R.fmap f ≡⟨⟩ + R.fmap f ∘ bind 𝟙 ≡⟨⟩ + R.fmap f ∘ join ∎ + + pureNT : NaturalTransformation R⁰ R + proj₁ pureNT = pureT + proj₂ pureNT = pureN + + joinNT : NaturalTransformation R² R + proj₁ joinNT = joinT + proj₂ joinNT = joinN + + isNaturalForeign : IsNaturalForeign + isNaturalForeign = begin + fmap join >>> join ≡⟨⟩ + bind (join >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((join >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (join >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (join >>> φ)) (isNatural _) ⟩ + bind (join >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind join ≡⟨⟩ + bind (bind 𝟙) + ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ + bind (𝟙 >>> bind 𝟙) ≡⟨⟩ + bind (𝟙 >=> 𝟙) ≡⟨ sym (isDistributive _ _) ⟩ + bind 𝟙 >>> bind 𝟙 ≡⟨⟩ + join >>> join ∎ + + isInverse : IsInverse + isInverse = inv-l , inv-r + where + inv-l = begin + pure >>> join ≡⟨⟩ + pure >>> bind 𝟙 ≡⟨ isNatural _ ⟩ + 𝟙 ∎ + inv-r = begin + fmap pure >>> join ≡⟨⟩ + bind (pure >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((pure >>> pure) >=> 𝟙) ≡⟨⟩ + bind ((pure >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (pure >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (pure >>> φ)) (isNatural _) ⟩ + bind (pure >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind pure ≡⟨ isIdentity ⟩ + 𝟙 ∎ + +record Monad : Set ℓ where + field + raw : RawMonad + isMonad : IsMonad raw + open IsMonad isMonad public + +private + module _ (raw : RawMonad) where + open RawMonad raw + propIsIdentity : isProp IsIdentity + propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i + propIsNatural : isProp IsNatural + propIsNatural x y i = λ f + → ℂ.arrowsAreSets _ _ (x f) (y f) i + propIsDistributive : isProp IsDistributive + propIsDistributive x y i = λ g f + → ℂ.arrowsAreSets _ _ (x g f) (y g f) i + + open IsMonad + propIsMonad : (raw : _) → isProp (IsMonad raw) + IsMonad.isIdentity (propIsMonad raw x y i) + = propIsIdentity raw (isIdentity x) (isIdentity y) i + IsMonad.isNatural (propIsMonad raw x y i) + = propIsNatural raw (isNatural x) (isNatural y) i + IsMonad.isDistributive (propIsMonad raw x y i) + = propIsDistributive raw (isDistributive x) (isDistributive y) i + +module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where + private + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq + + Monad≡ : m ≡ n + Monad.raw (Monad≡ i) = eq i + Monad.isMonad (Monad≡ i) = eqIsMonad i diff --git a/src/Cat/Category/Monad/Monoidal.agda b/src/Cat/Category/Monad/Monoidal.agda new file mode 100644 index 0000000..b969187 --- /dev/null +++ b/src/Cat/Category/Monad/Monoidal.agda @@ -0,0 +1,154 @@ +{--- +Monoidal formulation of monads + ---} +{-# OPTIONS --cubical --allow-unsolved-metas #-} +open import Agda.Primitive + +open import Data.Product + +open import Cubical +open import Cubical.NType.Properties using (lemPropF ; lemSig ; lemSigP) +open import Cubical.GradLemma using (gradLemma) + +open import Cat.Category +open import Cat.Category.Functor as F +open import Cat.Category.NaturalTransformation +open import Cat.Categories.Fun + +module Cat.Category.Monad.Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where + +-- "A monad in the monoidal form" [voe] +private + ℓ = ℓa ⊔ ℓb + +open Category ℂ using (Object ; Arrow ; 𝟙 ; _∘_) +open NaturalTransformation ℂ ℂ +record RawMonad : Set ℓ where + field + R : EndoFunctor ℂ + pureNT : NaturalTransformation F.identity R + joinNT : NaturalTransformation F[ R ∘ R ] R + + -- Note that `pureT` and `joinT` differs from their definition in the + -- kleisli formulation only by having an explicit parameter. + pureT : Transformation F.identity R + pureT = proj₁ pureNT + pureN : Natural F.identity R pureT + pureN = proj₂ pureNT + + joinT : Transformation F[ R ∘ R ] R + joinT = proj₁ joinNT + joinN : Natural F[ R ∘ R ] R joinT + joinN = proj₂ joinNT + + Romap = Functor.omap R + Rfmap = Functor.fmap R + + bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] + bind {X} {Y} f = joinT Y ∘ Rfmap f + + IsAssociative : Set _ + IsAssociative = {X : Object} + → joinT X ∘ Rfmap (joinT X) ≡ joinT X ∘ joinT (Romap X) + IsInverse : Set _ + IsInverse = {X : Object} + → joinT X ∘ pureT (Romap X) ≡ 𝟙 + × joinT X ∘ Rfmap (pureT X) ≡ 𝟙 + IsNatural = ∀ {X Y} f → joinT Y ∘ Rfmap f ∘ pureT X ≡ f + IsDistributive = ∀ {X Y Z} (g : Arrow Y (Romap Z)) (f : Arrow X (Romap Y)) + → joinT Z ∘ Rfmap g ∘ (joinT Y ∘ Rfmap f) + ≡ joinT Z ∘ Rfmap (joinT Z ∘ Rfmap g ∘ f) + +record IsMonad (raw : RawMonad) : Set ℓ where + open RawMonad raw public + field + isAssociative : IsAssociative + isInverse : IsInverse + + private + module R = Functor R + module ℂ = Category ℂ + + isNatural : IsNatural + isNatural {X} {Y} f = begin + joinT Y ∘ R.fmap f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩ + joinT Y ∘ (R.fmap f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩ + joinT Y ∘ (pureT (R.omap Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ + joinT Y ∘ pureT (R.omap Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ + 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ + f ∎ + + isDistributive : IsDistributive + isDistributive {X} {Y} {Z} g f = sym aux + where + module R² = Functor F[ R ∘ R ] + distrib3 : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} + → R.fmap (a ∘ b ∘ c) + ≡ R.fmap a ∘ R.fmap b ∘ R.fmap c + distrib3 {a = a} {b} {c} = begin + R.fmap (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩ + R.fmap (a ∘ b) ∘ R.fmap c ≡⟨ cong (_∘ _) R.isDistributive ⟩ + 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 + field + raw : RawMonad + isMonad : IsMonad raw + open IsMonad isMonad public + +private + module _ {m : RawMonad} where + open RawMonad m + propIsAssociative : isProp IsAssociative + propIsAssociative x y i {X} + = Category.arrowsAreSets ℂ _ _ (x {X}) (y {X}) i + propIsInverse : isProp IsInverse + propIsInverse x y i {X} = e1 i , e2 i + where + xX = x {X} + yX = y {X} + e1 = Category.arrowsAreSets ℂ _ _ (proj₁ xX) (proj₁ yX) + e2 = Category.arrowsAreSets ℂ _ _ (proj₂ xX) (proj₂ yX) + + open IsMonad + propIsMonad : (raw : _) → isProp (IsMonad raw) + IsMonad.isAssociative (propIsMonad raw a b i) j + = propIsAssociative {raw} + (isAssociative a) (isAssociative b) i j + IsMonad.isInverse (propIsMonad raw a b i) + = propIsInverse {raw} + (isInverse a) (isInverse b) i + +module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where + private + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq + + Monad≡ : m ≡ n + Monad.raw (Monad≡ i) = eq i + Monad.isMonad (Monad≡ i) = eqIsMonad i diff --git a/src/Cat/Category/Monad/Voevodsky.agda b/src/Cat/Category/Monad/Voevodsky.agda index 02898a1..7644f53 100644 --- a/src/Cat/Category/Monad/Voevodsky.agda +++ b/src/Cat/Category/Monad/Voevodsky.agda @@ -12,7 +12,9 @@ open import Cubical.GradLemma using (gradLemma) open import Cat.Category open import Cat.Category.Functor as F open import Cat.Category.NaturalTransformation -open import Cat.Category.Monad +open import Cat.Category.Monad using (Monoidal≃Kleisli) +import Cat.Category.Monad.Monoidal as Monoidal +import Cat.Category.Monad.Kleisli as Kleisli open import Cat.Categories.Fun module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where From 5e092964c8adaf454dc3d3318c9b1411809a9ce0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 14:38:52 +0100 Subject: [PATCH 87/91] Change naming and fuse some modules --- src/Cat/Category/Monad/Voevodsky.agda | 66 +++++++++++---------------- 1 file changed, 27 insertions(+), 39 deletions(-) diff --git a/src/Cat/Category/Monad/Voevodsky.agda b/src/Cat/Category/Monad/Voevodsky.agda index 7644f53..27bf449 100644 --- a/src/Cat/Category/Monad/Voevodsky.agda +++ b/src/Cat/Category/Monad/Voevodsky.agda @@ -1,3 +1,6 @@ +{- +This module provides construction 2.3 in [voe] +-} {-# OPTIONS --cubical --allow-unsolved-metas #-} module Cat.Category.Monad.Voevodsky where @@ -17,17 +20,18 @@ import Cat.Category.Monad.Monoidal as Monoidal import Cat.Category.Monad.Kleisli as Kleisli open import Cat.Categories.Fun -module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where +module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private ℓ = ℓa ⊔ ℓb module ℂ = Category ℂ - open ℂ using (Object ; Arrow ; _∘_) + open ℂ using (Object ; Arrow) open NaturalTransformation ℂ ℂ + open import Function using (_∘_ ; _$_) module M = Monoidal ℂ module K = Kleisli ℂ - module voe-2-3 (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where - record voe-2-3-1 : Set ℓ where + module §2-3 (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where + record §1 : Set ℓ where open M field @@ -83,7 +87,7 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where ; isMonad = isMnd } - record voe-2-3-2 : Set ℓ where + record §2 : Set ℓ where open K field @@ -105,13 +109,8 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where ; isMonad = isMnd } -module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where - private - module M = Monoidal ℂ - module K = Kleisli ℂ - open voe-2-3 ℂ - - voe-2-3-1-fromMonad : (m : M.Monad) → voe-2-3-1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + voe-2-3-1-fromMonad : (m : M.Monad) → §2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + -- voe-2-3-1-fromMonad : (m : M.Monad) → voe.§2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) voe-2-3-1-fromMonad m = record { fmap = Functor.fmap R ; RisFunctor = Functor.isFunctor R @@ -128,24 +127,13 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where joinT = M.RawMonad.joinT raw joinN = M.RawMonad.joinN raw - voe-2-3-2-fromMonad : (m : K.Monad) → voe-2-3-2 (K.Monad.omap m) (K.Monad.pure m) + voe-2-3-2-fromMonad : (m : K.Monad) → §2-3.§2 (K.Monad.omap m) (K.Monad.pure m) voe-2-3-2-fromMonad m = record { bind = K.Monad.bind m ; isMnd = K.Monad.isMonad m } -module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where - private - ℓ = ℓa ⊔ ℓb - module ℂ = Category ℂ - open ℂ using (Object ; Arrow) - open NaturalTransformation ℂ ℂ - module M = Monoidal ℂ - module K = Kleisli ℂ - open import Function using (_∘_ ; _$_) - module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where - open voe-2-3 ℂ private Monoidal→Kleisli : M.Monad → K.Monad Monoidal→Kleisli = proj₁ Monoidal≃Kleisli @@ -153,11 +141,11 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where Kleisli→Monoidal : K.Monad → M.Monad Kleisli→Monoidal = inverse Monoidal≃Kleisli - forth : voe-2-3-1 omap pure → voe-2-3-2 omap pure - forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ voe-2-3.voe-2-3-1.toMonad + forth : §2-3.§1 omap pure → §2-3.§2 omap pure + forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad - back : voe-2-3-2 omap pure → voe-2-3-1 omap pure - back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ voe-2-3.voe-2-3-2.toMonad + back : §2-3.§2 omap pure → §2-3.§1 omap pure + back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ §2-3.§2.toMonad forthEq : ∀ m → _ ≡ _ forthEq m = begin @@ -165,23 +153,23 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where -- In full gory detail: ( voe-2-3-2-fromMonad ∘ Monoidal→Kleisli - ∘ voe-2-3.voe-2-3-1.toMonad + ∘ §2-3.§1.toMonad ∘ voe-2-3-1-fromMonad ∘ Kleisli→Monoidal - ∘ voe-2-3.voe-2-3-2.toMonad + ∘ §2-3.§2.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses ( voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ Kleisli→Monoidal - ∘ voe-2-3.voe-2-3-2.toMonad + ∘ §2-3.§2.toMonad ) m ≡⟨ u ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses -- I should be able to prove this using congruence and `lem` below. ( voe-2-3-2-fromMonad - ∘ voe-2-3.voe-2-3-2.toMonad + ∘ §2-3.§2.toMonad ) m ≡⟨⟩ ( voe-2-3-2-fromMonad - ∘ voe-2-3.voe-2-3-2.toMonad + ∘ §2-3.§2.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ where @@ -199,25 +187,25 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where (back ∘ forth) m ≡⟨⟩ ( voe-2-3-1-fromMonad ∘ Kleisli→Monoidal - ∘ voe-2-3.voe-2-3-2.toMonad + ∘ §2-3.§2.toMonad ∘ voe-2-3-2-fromMonad ∘ Monoidal→Kleisli - ∘ voe-2-3.voe-2-3-1.toMonad + ∘ §2-3.§1.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses ( voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ Monoidal→Kleisli - ∘ voe-2-3.voe-2-3-1.toMonad + ∘ §2-3.§1.toMonad ) m ≡⟨ cong (λ φ → φ m) t ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses ( voe-2-3-1-fromMonad - ∘ voe-2-3.voe-2-3-1.toMonad + ∘ §2-3.§1.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ where t = {!!} -- cong (λ φ → voe-2-3-1-fromMonad ∘ φ ∘ voe-2-3.voe-2-3-1.toMonad) (recto-verso Monoidal≃Kleisli) - voe-isEquiv : isEquiv (voe-2-3-1 omap pure) (voe-2-3-2 omap pure) forth + voe-isEquiv : isEquiv (§2-3.§1 omap pure) (§2-3.§2 omap pure) forth voe-isEquiv = gradLemma forth back forthEq backEq - equiv-2-3 : voe-2-3-1 omap pure ≃ voe-2-3-2 omap pure + equiv-2-3 : §2-3.§1 omap pure ≃ §2-3.§2 omap pure equiv-2-3 = forth , voe-isEquiv From c52384b0127e41e9ede8e46591fe55373a149963 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 14:43:43 +0100 Subject: [PATCH 88/91] Change name of fromMonad --- src/Cat/Category/Monad/Voevodsky.agda | 30 +++++++++++++-------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Cat/Category/Monad/Voevodsky.agda b/src/Cat/Category/Monad/Voevodsky.agda index 27bf449..3c0554f 100644 --- a/src/Cat/Category/Monad/Voevodsky.agda +++ b/src/Cat/Category/Monad/Voevodsky.agda @@ -109,9 +109,9 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where ; isMonad = isMnd } - voe-2-3-1-fromMonad : (m : M.Monad) → §2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) + §1-fromMonad : (m : M.Monad) → §2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) -- voe-2-3-1-fromMonad : (m : M.Monad) → voe.§2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X) - voe-2-3-1-fromMonad m = record + §1-fromMonad m = record { fmap = Functor.fmap R ; RisFunctor = Functor.isFunctor R ; pureN = pureN @@ -127,8 +127,8 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where joinT = M.RawMonad.joinT raw joinN = M.RawMonad.joinN raw - voe-2-3-2-fromMonad : (m : K.Monad) → §2-3.§2 (K.Monad.omap m) (K.Monad.pure m) - voe-2-3-2-fromMonad m = record + §2-fromMonad : (m : K.Monad) → §2-3.§2 (K.Monad.omap m) (K.Monad.pure m) + §2-fromMonad m = record { bind = K.Monad.bind m ; isMnd = K.Monad.isMonad m } @@ -142,33 +142,33 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where Kleisli→Monoidal = inverse Monoidal≃Kleisli forth : §2-3.§1 omap pure → §2-3.§2 omap pure - forth = voe-2-3-2-fromMonad ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad + forth = §2-fromMonad ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad back : §2-3.§2 omap pure → §2-3.§1 omap pure - back = voe-2-3-1-fromMonad ∘ Kleisli→Monoidal ∘ §2-3.§2.toMonad + back = §1-fromMonad ∘ Kleisli→Monoidal ∘ §2-3.§2.toMonad forthEq : ∀ m → _ ≡ _ forthEq m = begin (forth ∘ back) m ≡⟨⟩ -- In full gory detail: - ( voe-2-3-2-fromMonad + ( §2-fromMonad ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad - ∘ voe-2-3-1-fromMonad + ∘ §1-fromMonad ∘ Kleisli→Monoidal ∘ §2-3.§2.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses - ( voe-2-3-2-fromMonad + ( §2-fromMonad ∘ Monoidal→Kleisli ∘ Kleisli→Monoidal ∘ §2-3.§2.toMonad ) m ≡⟨ u ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses -- I should be able to prove this using congruence and `lem` below. - ( voe-2-3-2-fromMonad + ( §2-fromMonad ∘ §2-3.§2.toMonad ) m ≡⟨⟩ - ( voe-2-3-2-fromMonad + ( §2-fromMonad ∘ §2-3.§2.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ @@ -185,19 +185,19 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where backEq : ∀ m → (back ∘ forth) m ≡ m backEq m = begin (back ∘ forth) m ≡⟨⟩ - ( voe-2-3-1-fromMonad + ( §1-fromMonad ∘ Kleisli→Monoidal ∘ §2-3.§2.toMonad - ∘ voe-2-3-2-fromMonad + ∘ §2-fromMonad ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses - ( voe-2-3-1-fromMonad + ( §1-fromMonad ∘ Kleisli→Monoidal ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad ) m ≡⟨ cong (λ φ → φ m) t ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses - ( voe-2-3-1-fromMonad + ( §1-fromMonad ∘ §2-3.§1.toMonad ) m ≡⟨⟩ -- fromMonad and toMonad are inverses m ∎ From fe453a6d3a160273292df1e15c623343c393a470 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Mon, 12 Mar 2018 16:00:27 +0100 Subject: [PATCH 89/91] Trying to prove cummulativity of homotopy levels --- src/Cat/Category/Monad/Voevodsky.agda | 12 ++++----- src/Cat/Wishlist.agda | 38 ++++++++++++++++++++++++--- 2 files changed, 41 insertions(+), 9 deletions(-) diff --git a/src/Cat/Category/Monad/Voevodsky.agda b/src/Cat/Category/Monad/Voevodsky.agda index 3c0554f..3a807de 100644 --- a/src/Cat/Category/Monad/Voevodsky.agda +++ b/src/Cat/Category/Monad/Voevodsky.agda @@ -175,12 +175,12 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where where lem : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ Function.id lem = {!!} -- verso-recto Monoidal≃Kleisli - t : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} - → a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b ≡ a ∘ b - t {a = a} {b} = cong (λ φ → a ∘ φ ∘ b) lem - u : {ℓ : Level} {A B : Set ℓ} {a : _ → A} {b : B → _} - → {m : _} → (a ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ b) m ≡ (a ∘ b) m - u {m = m} = cong (λ φ → φ m) t + t : (§2-fromMonad ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ §2-3.§2.toMonad) + ≡ (§2-fromMonad ∘ §2-3.§2.toMonad) + t = cong (λ φ → §2-fromMonad ∘ (λ{ {ω} → φ {{!????!}}}) ∘ §2-3.§2.toMonad) {!lem!} + u : (§2-fromMonad ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ §2-3.§2.toMonad) m + ≡ (§2-fromMonad ∘ §2-3.§2.toMonad) m + u = cong (λ φ → φ m) t backEq : ∀ m → (back ∘ forth) m ≡ m backEq m = begin diff --git a/src/Cat/Wishlist.agda b/src/Cat/Wishlist.agda index 67eeccc..8385afd 100644 --- a/src/Cat/Wishlist.agda +++ b/src/Cat/Wishlist.agda @@ -1,9 +1,41 @@ +{-# OPTIONS --allow-unsolved-metas #-} module Cat.Wishlist where -open import Level +open import Level hiding (suc) +open import Cubical open import Cubical.NType -open import Data.Nat using (_≤_ ; z≤n ; s≤s) +open import Data.Nat using (_≤_ ; z≤n ; s≤s ; zero ; suc) +open import Agda.Builtin.Sigma open import Cubical.NType.Properties -postulate ntypeCommulative : ∀ {ℓ n m} {A : Set ℓ} → n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A +step : ∀ {ℓ} {A : Set ℓ} → isContr A → (x y : A) → isContr (x ≡ y) +step (a , contr) x y = {!p , c!} + -- where + -- p : x ≡ y + -- p = begin + -- x ≡⟨ sym (contr x) ⟩ + -- a ≡⟨ contr y ⟩ + -- y ∎ + -- c : (q : x ≡ y) → p ≡ q + -- c q i j = contr (p {!!}) {!!} + +-- Contractible types have any given homotopy level. +contrInitial : {ℓ : Level} {A : Set ℓ} → ∀ n → isContr A → HasLevel n A +contrInitial ⟨-2⟩ contr = contr +-- lem' (S ⟨-2⟩) (a , contr) = {!step!} +contrInitial (S ⟨-2⟩) (a , contr) x y = begin + x ≡⟨ sym (contr x) ⟩ + a ≡⟨ contr y ⟩ + y ∎ +contrInitial (S (S n)) contr x y = {!lvl!} -- Why is this not well-founded? + where + c : isContr (x ≡ y) + c = step contr x y + lvl : HasLevel (S n) (x ≡ y) + lvl = contrInitial {A = x ≡ y} (S n) c + +module _ {ℓ : Level} {A : Set ℓ} where + ntypeCommulative : ∀ {n m} → n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A + ntypeCommulative {n = zero} {m} z≤n lvl = {!contrInitial ⟨ m ⟩₋₂ lvl!} + ntypeCommulative {n = .(suc _)} {.(suc _)} (s≤s x) lvl = {!!} From 896e0d3d37dd60f55dc7ab86023a2ed11e0eb8c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 13 Mar 2018 10:24:50 +0100 Subject: [PATCH 90/91] Stuff about univalence for the category of functors --- src/Cat/Categories/Fun.agda | 90 ++++++++++++++++++++++++++++++++++++- 1 file changed, 88 insertions(+), 2 deletions(-) diff --git a/src/Cat/Categories/Fun.agda b/src/Cat/Categories/Fun.agda index 9c1b380..019e8b6 100644 --- a/src/Cat/Categories/Fun.agda +++ b/src/Cat/Categories/Fun.agda @@ -6,6 +6,7 @@ open import Data.Product open import Cubical +open import Cubical.GradLemma open import Cubical.NType.Properties open import Cat.Category @@ -13,10 +14,10 @@ open import Cat.Category.Functor hiding (identity) open import Cat.Category.NaturalTransformation module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where - open Category using (Object ; 𝟙) module NT = NaturalTransformation ℂ 𝔻 open NT public private + module ℂ = Category ℂ module 𝔻 = Category 𝔻 private module _ {A B C D : Functor ℂ 𝔻} {θ' : NaturalTransformation A B} @@ -65,13 +66,98 @@ module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : C ; _∘_ = λ {F G H} → NT[_∘_] {F} {G} {H} } + open RawCategory RawFun + open Univalence RawFun + module _ {A B : Functor ℂ 𝔻} where + module A = Functor A + module B = Functor B + module _ (p : A ≡ B) where + omapP : A.omap ≡ B.omap + omapP i = Functor.omap (p i) + + coerceAB : ∀ {X} → 𝔻 [ A.omap X , A.omap X ] ≡ 𝔻 [ A.omap X , B.omap X ] + coerceAB {X} = cong (λ φ → 𝔻 [ A.omap X , φ X ]) omapP + + -- The transformation will be the identity on 𝔻. Such an arrow has the + -- type `A.omap A → A.omap A`. Which we can coerce to have the type + -- `A.omap → B.omap` since `A` and `B` are equal. + coe𝟙 : Transformation A B + coe𝟙 X = coe coerceAB 𝔻.𝟙 + + module _ {a b : ℂ.Object} (f : ℂ [ a , b ]) where + nat' : 𝔻 [ coe𝟙 b ∘ A.fmap f ] ≡ 𝔻 [ B.fmap f ∘ coe𝟙 a ] + nat' = begin + (𝔻 [ coe𝟙 b ∘ A.fmap f ]) ≡⟨ {!!} ⟩ + (𝔻 [ B.fmap f ∘ coe𝟙 a ]) ∎ + + transs : (i : I) → Transformation A (p i) + transs = {!!} + + natt : (i : I) → Natural A (p i) {!!} + natt = {!!} + + t : Natural A B coe𝟙 + t = coe c (identityNatural A) + where + c : Natural A A (identityTrans A) ≡ Natural A B coe𝟙 + c = begin + Natural A A (identityTrans A) ≡⟨ (λ x → {!natt ?!}) ⟩ + Natural A B coe𝟙 ∎ + -- cong (λ φ → {!Natural A A (identityTrans A)!}) {!!} + + k : Natural A A (identityTrans A) → Natural A B coe𝟙 + k n {a} {b} f = res + where + res : (𝔻 [ coe𝟙 b ∘ A.fmap f ]) ≡ (𝔻 [ B.fmap f ∘ coe𝟙 a ]) + res = {!!} + + nat : Natural A B coe𝟙 + nat = nat' + + fromEq : NaturalTransformation A B + fromEq = coe𝟙 , nat + + module _ {A B : Functor ℂ 𝔻} where + obverse : A ≡ B → A ≅ B + obverse p = res + where + ob : Arrow A B + ob = fromEq p + re : Arrow B A + re = fromEq (sym p) + vr : _∘_ {A = A} {B} {A} re ob ≡ 𝟙 {A} + vr = {!!} + rv : _∘_ {A = B} {A} {B} ob re ≡ 𝟙 {B} + rv = {!!} + isInverse : IsInverseOf {A} {B} ob re + isInverse = vr , rv + iso : Isomorphism {A} {B} ob + iso = re , isInverse + res : A ≅ B + res = ob , iso + + reverse : A ≅ B → A ≡ B + reverse iso = {!!} + + ve-re : (y : A ≅ B) → obverse (reverse y) ≡ y + ve-re = {!!} + + re-ve : (x : A ≡ B) → reverse (obverse x) ≡ x + re-ve = {!!} + + done : isEquiv (A ≡ B) (A ≅ B) (id-to-iso (λ { {A} {B} → isIdentity {A} {B}}) A B) + done = {!gradLemma obverse reverse ve-re re-ve!} + + univalent : Univalent (λ{ {A} {B} → isIdentity {A} {B}}) + univalent = done + instance isCategory : IsCategory RawFun isCategory = record { isAssociative = λ {A B C D} → isAssociative {A} {B} {C} {D} ; isIdentity = λ {A B} → isIdentity {A} {B} ; arrowsAreSets = λ {F} {G} → naturalTransformationIsSet {F} {G} - ; univalent = {!!} + ; univalent = univalent } Fun : Category (ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd') (ℓc ⊔ ℓc' ⊔ ℓd') From 6db2a3e5d4100a5227c8833a7cd48f90730ab1b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Tue, 13 Mar 2018 10:40:43 +0100 Subject: [PATCH 91/91] Update changelog and backlog --- BACKLOG.md | 5 ----- CHANGELOG.md | 20 +++++++++++++++++++- 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/BACKLOG.md b/BACKLOG.md index 3eec938..ed1b205 100644 --- a/BACKLOG.md +++ b/BACKLOG.md @@ -1,14 +1,9 @@ Backlog ======= -Prove univalence for various categories - Prove postulates in `Cat.Wishlist` -`propHasLevel` should be in `cubical` `ntypeCommulative` might be there as well. -Define and use Monad≡ - Prove that the opposite category is a category. Prove univalence for the category of diff --git a/CHANGELOG.md b/CHANGELOG.md index a7a3d14..625d640 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,27 @@ Changelog ========= +Version 1.4.0 +------------- +Adds documentation to a number of modules. + +Adds an "equality principle" for categories and monads. + +Prove that `IsMonad` is a mere proposition. + +Provides the yoneda embedding without relying on the existence of a category of +categories. This is acheived by providing some of the data needed to make a ccc +out of the category of categories without actually having such a category. + +Renames functors object map and arrow map to `omap` and `fmap`. + +Prove that kleisli- and monoidal- monads are equivalent! + +[WIP] Started working on the proofs for univalence for the category of sets and +the category of functors. + Version 1.3.0 ------------- - Removed unused modules and streamlined things more: All specific categories are in the namespace `Cat.Categories`.