Mercurial > hg > Members > kono > Proof > category

changeset 742:20f2700a481c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
nat-ε
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Tue, 05 Dec 2017 01:57:41 +0900
parents dfeb296b36d3
children e33e9ae1514b
files monad→monoidal.agda
diffstat 1 files changed, 43 insertions(+), 7 deletions(-) [+]
line wrap: on
line diff
--- a/monad→monoidal.agda	Tue Dec 05 00:47:01 2017 +0900
+++ b/monad→monoidal.agda	Tue Dec 05 01:57:41 2017 +0900
@@ -13,27 +13,31 @@
 open NTrans
 
 open import monoidal 
-open import Category.Sets 
+open import Category.Cat
 
 Monad→MonoidalFunctor : {c₁ c₂ ℓ : Level} (C : Category c₁ c₂ ℓ) ( m : Monad C ) ( monoidal : Monoidal C )
-     → ( ε  : (x : Obj C ) → Hom C ( FObj ( Monad.T m ) x ) x )   -- assuming C = kleisli
+     → ( ε  : NTrans C C (Monad.T m ) identityFunctor ) -- assuming C = kleisli
      → MonoidalFunctor monoidal monoidal    
-Monad→MonoidalFunctor C M Mono ε  = record {
+Monad→MonoidalFunctor C M Mono ε-nat  = record {
       MF = Monad.T M
     ; ψ  = NTrans.TMap (Monad.η M )  ( Monoidal.m-i Mono )
     ; isMonodailFunctor = record {
              φab  = record { TMap = φab 
-               ;  isNTrans = record { commute = {!!}
+               ;  isNTrans = record { commute = commute
                } } 
          ;   associativity  = {!!}
          ;   unitarity-idr = {!!}
          ;   unitarity-idl = {!!}
       }
   } where
-     open import Category.Cat
      T = Monad.T M
      μ = TMap ( Monad.μ M )
      η = TMap ( Monad.η M )
+     -- ε-nat'  : NTrans C C (Monad.T M ) identityFunctor  
+     -- ε-nat'  = record {
+     --    TMap = λ x → {!!}
+     --  ; isNTrans = record { commute = {!!} } }
+     ε = TMap ε-nat
      _⊗_ : (x y : Obj C ) → Obj C
      _⊗_ x y =  (IsMonoidal._□_ (Monoidal.isMonoidal Mono) ) x y
      _□_ : {a b c d : Obj C } ( f : Hom C a c ) ( g : Hom C b d ) → Hom C ( a ⊗ b ) ( c ⊗ d )
@@ -41,7 +45,40 @@
      --                                                        ( T x , T y ) → T ( x , y )
      φab  : (a : Obj (C × C)) → Hom C (FObj (Functor● C C Mono (Monad.T M)) a) (FObj (Functor⊗ C C Mono (Monad.T M)) a)
      φab (x , y) =  C [ FMap T ( ε x  □ ε y) o  η ( FObj T x ⊗ FObj T y) ]  
+     commute :  {a b : Obj (C × C)} {f : Hom (C × C) a b} →
+        C [ C [ FMap (Functor⊗ C C Mono (Monad.T M)) f o φab a ] ≈ C [ φab b o FMap (Functor● C C Mono (Monad.T M)) f ] ]
+     commute {a} {b} {f} =  begin
+                 FMap (Functor⊗ C C Mono (Monad.T M)) f o φab a 
+             ≈⟨⟩
+                 FMap T (proj₁ f □  proj₂ f) o (  FMap T (ε (proj₁ a)  □ ε (proj₂ a)) o (η ( FObj T (proj₁ a) ⊗ FObj T (proj₂ a))))
+             ≈⟨ assoc  ⟩
+                 ( FMap T (proj₁ f □  proj₂ f) o  FMap T (ε (proj₁ a)  □ ε (proj₂ a))) o η ( FObj T (proj₁ a) ⊗ FObj T (proj₂ a))
+             ≈↑⟨ car (distr T ) ⟩
+                 FMap T ( (proj₁ f □  proj₂ f) o (ε (proj₁ a)  □ ε (proj₂ a))) o η ( FObj T (proj₁ a) ⊗ FObj T (proj₂ a))
+             ≈↑⟨ car ( fcong T ( distr (Monoidal.m-bi Mono) ))  ⟩
+                 FMap T ( FMap  (Monoidal.m-bi Mono)  ((C × C) [ proj₁ f , proj₂ f o ε (proj₁ a) , ε (proj₂ a) ]) ) o η ( FObj T (proj₁ a) ⊗ FObj T (proj₂ a))
+             ≈⟨⟩
+                 FMap T ( ( proj₁ f o  ε (proj₁ a) ) □ ( proj₂ f o ε (proj₂ a)  )) o η ( FObj T (proj₁ a) ⊗ FObj T (proj₂ a))
+             ≈⟨ car ( fcong T ( fcong (Monoidal.m-bi Mono) ( nat ε-nat ,  nat ε-nat ))) ⟩
+                FMap T  ( (ε (proj₁ b) o (FMap T (proj₁ f)) ) □ (  ε (proj₂ b)  o (FMap T (proj₂ f))))  o η (FObj T (proj₁ a) ⊗ FObj T (proj₂ a))
+             ≈⟨⟩
+                FMap T  (FMap (Monoidal.m-bi Mono) ((C × C) [ ε (proj₁ b) , ε (proj₂ b) o FMap T (proj₁ f) , FMap T (proj₂ f) ]))  o η (FObj T (proj₁ a) ⊗ FObj T (proj₂ a))
+             ≈⟨   car ( fcong T ( distr (Monoidal.m-bi Mono) ))    ⟩
+                FMap T (C [ ε (proj₁ b) □ ε (proj₂ b) o FMap T (proj₁ f) □ FMap T (proj₂ f) ]) o η (FObj T (proj₁ a) ⊗ FObj T (proj₂ a))
+             ≈⟨ car ( distr T )  ⟩
+                 ( FMap T (ε (proj₁ b) □ ε (proj₂ b)) o  FMap T ((FMap T (proj₁ f) □ FMap T (proj₂ f)))) o η (FObj T (proj₁ a) ⊗  FObj T (proj₂ a))
+             ≈↑⟨ assoc ⟩
+                 FMap T (ε (proj₁ b) □ ε (proj₂ b)) o ( FMap T ((FMap T (proj₁ f) □ FMap T (proj₂ f))) o η (FObj T (proj₁ a) ⊗  FObj T (proj₂ a)))
+             ≈⟨ cdr ( nat ( Monad.η M ))  ⟩
+                 FMap T (ε (proj₁ b) □ ε (proj₂ b)) o ( η (FObj T (proj₁ b) ⊗ FObj T (proj₂ b)) o FMap T (proj₁ f)  □ FMap T (proj₂ f ))
+             ≈⟨ assoc ⟩
+                 ( FMap T (ε (proj₁ b) □ ε (proj₂ b)) o  η (FObj T (proj₁ b) ⊗ FObj T (proj₂ b))) o (FMap T (proj₁ f)  □ FMap T (proj₂ f ))
+             ≈⟨⟩
+                 φab b o FMap (Functor● C C Mono (Monad.T M)) f
+             ∎ 
+             where open ≈-Reasoning C
 
+open import Category.Sets
 import Relation.Binary.PropositionalEquality
 
 Monad→HaskellMonoidalFunctor : {l : Level } (m : Monad (Sets {l} ) ) → HaskellMonoidalFunctor ( Monad.T m )
@@ -108,8 +145,7 @@
                   μ  (Σ c (λ x₁ → d)) (FMap F (λ f₁ → FMap F (λ g₁ → f₁ , g₁) (FMap F g y)) (FMap F f x))
              ≡⟨⟩
                   φ (FMap F f x , FMap F g y)
-             ∎ 
-             where
+             ∎ where
                   open Relation.Binary.PropositionalEquality
                   open Relation.Binary.PropositionalEquality.≡-Reasoning
           assocφ : { x y z : Obj Sets } { a : FObj F x } { b : FObj F y }{ c : FObj F z }