changeset 72:cbc30519e961

stack overflow solved by moving implicit parameters to module parameters
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Fri, 26 Jul 2013 12:38:54 +0900
parents 709c1bde54dc
children b75b5792bd81
files adj-monad.agda nat.agda
diffstat 2 files changed, 147 insertions(+), 170 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/adj-monad.agda	Fri Jul 26 12:38:54 2013 +0900
@@ -0,0 +1,95 @@
+-- Monad
+-- Category A
+-- A = Category
+-- Functor T : A → A
+--T(a) = t(a)
+--T(f) = tf(f)
+
+open import Category -- https://github.com/konn/category-agda
+open import Level
+--open import Category.HomReasoning
+open import HomReasoning
+open import cat-utility
+open import Category.Cat
+
+module adj-monad where
+
+----
+--
+-- Adjunction to Monad
+--
+----
+
+open Adjunction
+open NTrans
+open Functor
+
+UεF :  {c₁ c₂ ℓ c₁' c₂' ℓ' : Level} (A : Category c₁ c₂ ℓ) (B : Category c₁' c₂' ℓ')
+                 ( U : Functor B A )
+                 ( F : Functor A B )
+                 ( ε : NTrans B B  ( F ○  U ) identityFunctor ) → NTrans A A  (( U ○  F ) ○ ( U ○  F )) ( U ○  F )
+UεF A B U F ε =  lemma11  (
+     Functor*Nat A {B} A U {( F ○ U) ○ F} {identityFunctor ○ F} ( Nat*Functor A {B} B { F ○  U} {identityFunctor} ε F)  ) where
+         lemma11 :   NTrans A A   ( U ○ ((F  ○  U) ○  F )) ( U ○  (identityFunctor ○ F) ) 
+                  →  NTrans A A  (( U ○  F ) ○ ( U ○  F )) ( U ○  F )
+         lemma11  n = record { TMap = \a → TMap n a; isNTrans = record { naturality = IsNTrans.naturality ( isNTrans n ) }}
+
+Adj2Monad : {c₁ c₂ ℓ c₁' c₂' ℓ' : Level} (A : Category c₁ c₂ ℓ) (B : Category c₁' c₂' ℓ')
+                 { U : Functor B A }
+                 { F : Functor A B }
+                 { η : NTrans A A identityFunctor ( U ○  F ) }
+                 { ε : NTrans B B  ( F ○  U ) identityFunctor } →
+      Adjunction A B U F η ε  → Monad A (U ○  F) η (UεF A B U F ε)
+Adj2Monad A B {U} {F} {η} {ε} adj = record {
+         isMonad = record {
+                    assoc = assoc1;
+                    unity1 = unity1;
+                    unity2 = unity2
+              }
+      }  where
+           T : Functor A A
+           T = U  ○ F
+           μ : NTrans A A ( T ○ T ) T
+           μ = UεF A B U F ε
+           lemma-assoc1 : {a b : Obj B} → ( f : Hom B a b) → 
+                 B [ B [ f o TMap ε a ] ≈ B [ TMap ε b o FMap F (FMap U f ) ] ] 
+           lemma-assoc1 f =  IsNTrans.naturality ( isNTrans ε )
+           assoc1 : {a : Obj A} → A [ A [ TMap μ a o TMap μ ( FObj T a ) ] ≈  A [  TMap μ a o FMap T (TMap μ a) ] ]
+           assoc1 {a} = let open ≈-Reasoning (A) in
+             begin
+                TMap μ a o TMap μ ( FObj T a )
+             ≈⟨⟩
+                (FMap U (TMap ε ( FObj F a ))) o (FMap U (TMap ε ( FObj F ( FObj U (FObj F  a )))))
+             ≈⟨ sym (distr U) ⟩
+                FMap U (B [ TMap ε ( FObj F a )  o TMap ε ( FObj F ( FObj U (FObj F a ))) ] )
+             ≈⟨  (IsFunctor.≈-cong (isFunctor U)) (lemma-assoc1 ( TMap ε (FObj F a ))) ⟩
+                FMap U (B [ (TMap ε ( FObj F a )) o FMap F (FMap U (TMap ε ( FObj F a ))) ] )
+             ≈⟨ distr U ⟩
+                (FMap U (TMap ε ( FObj F a ))) o FMap U (FMap F (FMap U (TMap ε ( FObj F a ))))
+             ≈⟨⟩
+                TMap μ a o FMap T (TMap μ a) 
+             ∎
+           unity1 : {a : Obj A} → A [ A [ TMap μ a o TMap η ( FObj T a ) ] ≈ Id {_} {_} {_} {A} (FObj T a) ]
+           unity1 {a} = let open ≈-Reasoning (A) in
+             begin
+               TMap μ a o TMap η ( FObj T a )
+             ≈⟨⟩
+               (FMap U (TMap ε ( FObj F a ))) o TMap η ( FObj U ( FObj F  a ))
+             ≈⟨ IsAdjunction.adjoint1 ( isAdjunction adj ) ⟩
+               id (FObj U ( FObj F a ))
+             ≈⟨⟩
+               id (FObj T a)
+             ∎
+           unity2 : {a : Obj A} → A [ A [ TMap μ a o (FMap T (TMap η a ))] ≈ Id {_} {_} {_} {A} (FObj T a) ]
+           unity2 {a} = let open ≈-Reasoning (A) in
+             begin
+                TMap μ a o (FMap T (TMap η a ))
+             ≈⟨⟩
+                (FMap U (TMap ε ( FObj F a ))) o (FMap U ( FMap F (TMap η a )))
+             ≈⟨ sym (distr U ) ⟩
+                FMap U ( B [  (TMap ε ( FObj F a )) o ( FMap F (TMap η a )) ])
+             ≈⟨ (IsFunctor.≈-cong (isFunctor U)) (IsAdjunction.adjoint2 ( isAdjunction adj )) ⟩
+                FMap U ( id1 B (FObj F a) )
+             ≈⟨ IsFunctor.identity ( isFunctor U ) ⟩
+                id (FObj T a)
+             ∎
--- a/nat.agda	Fri Jul 26 11:42:57 2013 +0900
+++ b/nat.agda	Fri Jul 26 12:38:54 2013 +0900
@@ -1,4 +1,4 @@
-module nat  where 
+
 
 -- Monad
 -- Category A
@@ -12,6 +12,15 @@
 --open import Category.HomReasoning
 open import HomReasoning
 open import cat-utility
+open import Category.Cat
+
+module nat { c₁ c₂ ℓ : Level} { A : Category c₁ c₂ ℓ }
+                 { T : Functor A A }
+                 { η : NTrans A A identityFunctor T }
+                 { μ : NTrans A A (T ○ T) T }
+                 { M : Monad A T η μ } 
+                 { K : Kleisli A T η μ M } where
+
 
 --T(g f) = T(g) T(f)
 
@@ -27,8 +36,6 @@
       → A [ A [  FMap G f o TMap μ a ]  ≈ A [ TMap μ b o  FMap F f ] ]
 Lemma2 = \n → IsNTrans.naturality ( isNTrans  n  )
 
-open import Category.Cat
-
 -- η :   1_A → T
 -- μ :   TT → T
 -- μ(a)η(T(a)) = a
@@ -111,49 +118,36 @@

 
 -- f ○ η(a) = f
-Lemma8 : {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ)
-                 ( T : Functor A A )
-                 ( η : NTrans A A identityFunctor T )
-                 { μ : NTrans A A (T ○ T) T }
-                 ( a  : Obj A )  ( b : Obj A )
+Lemma8 : ( a  : Obj A )  ( b : Obj A )
                  ( f : Hom A a ( FObj T b) )
-                 ( m : Monad A T η μ )
-                 ( k : Kleisli A T η μ m) 
-                      → A  [ join k f (TMap η a)  ≈ f ]
-Lemma8 c T η a b f m k = 
+                      → A  [ join K f (TMap η a)  ≈ f ]
+Lemma8 a b f = 
   begin
-     join k f (TMap η a) 
+     join K f (TMap η a) 
   ≈⟨ refl-hom ⟩
-     c [ TMap μ b  o c [  FMap T f o (TMap η a) ] ]  
+     A [ TMap μ b  o A [  FMap T f o (TMap η a) ] ]  
   ≈⟨ cdr  ( nat η ) ⟩
-     c [ TMap μ b  o c [ (TMap η ( FObj T b)) o f ] ] 
-  ≈⟨ IsCategory.associative (Category.isCategory c) ⟩
-     c [ c [ TMap μ b  o (TMap η ( FObj T b)) ] o f ] 
-  ≈⟨ car ( IsMonad.unity1 ( isMonad ( monad k )) ) ⟩
-     c [ id (FObj T b)  o f ]
-  ≈⟨  IsCategory.identityL (Category.isCategory c)  ⟩
+     A [ TMap μ b  o A [ (TMap η ( FObj T b)) o f ] ] 
+  ≈⟨ IsCategory.associative (Category.isCategory A) ⟩
+     A [ A [ TMap μ b  o (TMap η ( FObj T b)) ] o f ] 
+  ≈⟨ car ( IsMonad.unity1 ( isMonad ( monad K )) ) ⟩
+     A [ id (FObj T b)  o f ]
+  ≈⟨  IsCategory.identityL (Category.isCategory A)  ⟩
      f
   ∎  where 
-      open ≈-Reasoning (c) 
-      μ = mu ( monad k )
+      open ≈-Reasoning (A) 
 
 -- h ○ (g ○ f) = (h ○ g) ○ f
-Lemma9 : {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ)
-                 { T : Functor A A }
-                 { η : NTrans A A identityFunctor T }
-                 { μ : NTrans A A (T ○ T) T }
-                 { a b c d : Obj A }
+Lemma9 : { a b c d : Obj A }
                  ( f : Hom A a ( FObj T b) )
                  ( g : Hom A b ( FObj T c) ) 
                  ( h : Hom A c ( FObj T d) )
-                 ( m : Monad A T η μ )
-                 { k : Kleisli A T η μ m}
-                      → A  [ join k h (join k g f)  ≈ join k ( join k h g) f ]
-Lemma9 A {T} {η} {μ} {a} {b} {c} {d} f g h m {k} = 
+                      → A  [ join K h (join K g f)  ≈ join K ( join K h g) f ]
+Lemma9 {a} {b} {c} {d} f g h = 
   begin 
-     join k h (join k g f)  
+     join K h (join K g f)  
    ≈⟨⟩
-     join k h (                  ( TMap μ c o ( FMap T g o f ) ) )
+     join K h (                  ( TMap μ c o ( FMap T g o f ) ) )
    ≈⟨ refl-hom ⟩
      ( TMap μ d  o ( FMap T h  o  ( TMap μ c o ( FMap T g  o f ) ) ) )
    ≈⟨ cdr ( cdr ( assoc )) ⟩
@@ -186,7 +180,7 @@
    ≈⟨ car ( car (
       begin
          ( TMap μ d o TMap μ (FObj T d) )
-      ≈⟨ IsMonad.assoc ( isMonad m) ⟩
+      ≈⟨ IsMonad.assoc ( isMonad M) ⟩
          ( TMap μ d o FMap T (TMap μ d) )

    )) ⟩
@@ -198,176 +192,64 @@
    ≈⟨ cdr ( car ( sym ( distr T )))   ⟩
      ( TMap μ d  o ( FMap T ( ( ( TMap μ d )   o ( FMap T h  o g ) ) ) o f ) )
    ≈⟨ refl-hom ⟩
-     join k ( ( TMap μ d  o ( FMap T h  o g ) ) ) f
+     join K ( ( TMap μ d  o ( FMap T h  o g ) ) ) f
    ≈⟨ refl-hom ⟩
-     join k ( join k h g) f 
+     join K ( join K h g) f 
   ∎ where open ≈-Reasoning (A) 
 
-KHom1 : {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) → ( T : Functor A A )  (a : Obj A) → (b : Obj A)  -> Set (c₂ ⊔ c₁)
+KHom1 :  (a : Obj A) → (b : Obj A)  -> Set (c₂ ⊔ c₁)
 KHom1 = {!!}
 
-record KHom  {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ)  ( T : Functor A A )  (a : Obj A)  (b : Obj A)
+record KHom (a : Obj A)  (b : Obj A)
      : Set (suc (c₂ ⊔ c₁)) where
    field
        KMap :  Hom A a ( FObj T b )
 
-K-id : {c₁ c₂ ℓ : Level} {A : Category c₁ c₂ ℓ} { T : Functor A A } {η : NTrans A A identityFunctor T} {a : Obj A} → KHom A T a a
-K-id {_} {_} {_} {A} {T} {η} {a = a} = record { KMap =  TMap η a } 
+K-id :  {a : Obj A} → KHom a a
+K-id {a = a} = record { KMap =  TMap η a } 
 
 open import Relation.Binary.Core
 
-_⋍_ :  ∀{c₁ c₂ ℓ} {A : Category c₁ c₂ ℓ} { T : Functor A A }
-    { a : Obj A } { b : Obj A } (f g  : KHom A T a b ) -> Set (suc ((c₂ ⊔ c₁) ⊔ ℓ))
+_⋍_ : 
+    { a : Obj A } { b : Obj A } (f g  : KHom a b ) -> Set (suc ((c₂ ⊔ c₁) ⊔ ℓ))
 _⋍_ = {!!}
 
+open KHom
 
-_*_ :  { c₁ c₂ ℓ : Level} { A : Category c₁ c₂ ℓ }
-                 { T : Functor A A }
-                 { η : NTrans A A identityFunctor T }
-                 { μ : NTrans A A (T ○ T) T }
-                 { M : Monad A T η μ } →
-                 { K : Kleisli A T η μ M } →
-       { a b : Obj A } → { c : Obj A } →
-                      ( Hom A b ( FObj T c )) → (  Hom A a ( FObj T b)) → Hom A a ( FObj T c )
-_*_ {_} {_} {_} {_} {_} {_} {_} {_} {K} {a} {b} {c} g f = join K {a} {b} {c} g f
+_*_ : { a b : Obj A } → { c : Obj A } →
+                      ( KHom b c) → (  KHom a b) → KHom a c 
+_*_ {a} {b} {c} g f = record { KMap = join K {a} {b} {c} (KMap g) (KMap f) }
 
-isKleisliCategory : {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ)
-                 { T : Functor A A }
-                 { η : NTrans A A identityFunctor T }
-                 { μ : NTrans A A (T ○ T) T }
-                 ( m : Monad A T η μ )
-                 { k : Kleisli A T η μ m} →
-         IsCategory ( Obj A ) ( KHom A T ) _⋍_ _*_ K-id 
-isKleisliCategory A {T} {η} m = record  { isEquivalence =  isEquivalence A T
+isKleisliCategory : IsCategory ( Obj A ) KHom _⋍_ _*_ K-id 
+isKleisliCategory  = record  { isEquivalence =  isEquivalence 
                     ; identityL =   KidL
                     ; identityR =   KidR
                     ; o-resp-≈ =    Ko-resp
                     ; associative = Kassoc
                     }
      where
-         isEquivalence : {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) → ( T : Functor A A ) -> { a b : Obj A } ->
-               IsEquivalence {_} {_} {KHom A T a b} _⋍_
-         isEquivalence A T {C} {D} =
+         isEquivalence :  { a b : Obj A } ->
+               IsEquivalence {_} {_} {KHom a b} _⋍_
+         isEquivalence {C} {D} =
            record { refl  = λ {F} → ⋍-refl {F}
              ; sym   = λ {F} {G} → ⋍-sym {F} {G}
              ; trans = λ {F} {G} {H} → ⋍-trans {F} {G} {H}
              } where
-                  ⋍-refl : {F : KHom A T C D} → F ⋍ F
+                  ⋍-refl : {F : KHom C D} → F ⋍ F
                   ⋍-refl = {!!}
-                  ⋍-sym : {F G : KHom A T C D} → F ⋍ G → G ⋍ F
+                  ⋍-sym : {F G : KHom C D} → F ⋍ G → G ⋍ F
                   ⋍-sym = {!!}
-                  ⋍-trans : {F G H : KHom A T C D} → F ⋍ G → G ⋍ H → F ⋍ H
+                  ⋍-trans : {F G H : KHom C D} → F ⋍ G → G ⋍ H → F ⋍ H
                   ⋍-trans = {!!}
-         KidL : {c₁ c₂ ℓ : Level} { A : Category c₁ c₂ ℓ} { T : Functor A A }
-                 { η : NTrans A A identityFunctor T }
-                 { μ : NTrans A A (T ○ T) T } { m : Monad A T η μ } → {C D : Obj A} -> {f : KHom A T C D} → (K-id * f) ⋍ f
+         KidL : {C D : Obj A} -> {f : KHom C D} → (K-id * f) ⋍ f
          KidL = {!!}
-         KidR : {c₁ c₂ ℓ : Level} { A : Category c₁ c₂ ℓ} { T : Functor A A }
-                 { η : NTrans A A identityFunctor T }
-                 { μ : NTrans A A (T ○ T) T } { m : Monad A T η μ } → {C D : Obj A} -> {f : KHom A T C D} → (f * K-id) ⋍ f
+         KidR : {C D : Obj A} -> {f : KHom C D} → (f * K-id) ⋍ f
          KidR = {!!}
-         Ko-resp : {c₁ c₂ ℓ : Level} { A : Category c₁ c₂ ℓ} { T : Functor A A }
-                 { η : NTrans A A identityFunctor T }
-                 { μ : NTrans A A (T ○ T) T } { m : Monad A T η μ } → {a b c : Obj A} -> {f g : KHom A T a b } → {h i : KHom A T b c } → 
+         Ko-resp :  {a b c : Obj A} -> {f g : KHom a b } → {h i : KHom  b c } → 
                           f ⋍ g → h ⋍ i → (h * f) ⋍ (i * g)
          Ko-resp = {!!}
-         Kassoc :  {c₁ c₂ ℓ : Level} { A : Category c₁ c₂ ℓ} { T : Functor A A }
-                 { η : NTrans A A identityFunctor T }
-                 { μ : NTrans A A (T ○ T) T } { m : Monad A T η μ } → {a b c : Obj A} -> {f g : KHom A T a b } → {h i : KHom A T b c } →
+         Kassoc :   {a b c d : Obj A} -> {f : KHom c d } → {g : KHom b c } → {h : KHom a b } →
                           (f * (g * h)) ⋍ ((f * g) * h)
          Kassoc = {!!}
 
--- Kleisli :
--- Kleisli = record { Hom = 
---                 ; Hom = _⟶_
---                  ; Id = IdProd
---                  ; _o_ = _∘_
---                  ; _≈_ = _≈_
---                  ; isCategory = record { isEquivalence = record { refl  = λ {φ} → ≈-refl {φ = φ}
---                                                                 ; sym   = λ {φ ψ} → ≈-symm {φ = φ} {ψ}
---                                                                 ; trans = λ {φ ψ σ} → ≈-trans {φ = φ} {ψ} {σ}
---                                                                 }
---                                        ; identityL = identityL
---                                        ; identityR = identityR
---                                        ; o-resp-≈ = o-resp-≈
---                                        ; associative = associative
---                                        }
---                  }
 
-----
---
--- Adjunction to Monad
---
-----
-
-open Adjunction
-
-UεF :  {c₁ c₂ ℓ c₁' c₂' ℓ' : Level} (A : Category c₁ c₂ ℓ) (B : Category c₁' c₂' ℓ')
-                 ( U : Functor B A )
-                 ( F : Functor A B )
-                 ( ε : NTrans B B  ( F ○  U ) identityFunctor ) → NTrans A A  (( U ○  F ) ○ ( U ○  F )) ( U ○  F )
-UεF A B U F ε =  lemma11  (
-     Functor*Nat A {B} A U {( F ○ U) ○ F} {identityFunctor ○ F} ( Nat*Functor A {B} B { F ○  U} {identityFunctor} ε F)  ) where
-         lemma11 :   NTrans A A   ( U ○ ((F  ○  U) ○  F )) ( U ○  (identityFunctor ○ F) ) 
-                  →  NTrans A A  (( U ○  F ) ○ ( U ○  F )) ( U ○  F )
-         lemma11  n = record { TMap = \a → TMap n a; isNTrans = record { naturality = IsNTrans.naturality ( isNTrans n ) }}
-
-Adj2Monad : {c₁ c₂ ℓ c₁' c₂' ℓ' : Level} (A : Category c₁ c₂ ℓ) (B : Category c₁' c₂' ℓ')
-                 { U : Functor B A }
-                 { F : Functor A B }
-                 { η : NTrans A A identityFunctor ( U ○  F ) }
-                 { ε : NTrans B B  ( F ○  U ) identityFunctor } →
-      Adjunction A B U F η ε  → Monad A (U ○  F) η (UεF A B U F ε)
-Adj2Monad A B {U} {F} {η} {ε} adj = record {
-         isMonad = record {
-                    assoc = assoc1;
-                    unity1 = unity1;
-                    unity2 = unity2
-              }
-      }  where
-           T : Functor A A
-           T = U  ○ F
-           μ : NTrans A A ( T ○ T ) T
-           μ = UεF A B U F ε
-           lemma-assoc1 : {a b : Obj B} → ( f : Hom B a b) → 
-                 B [ B [ f o TMap ε a ] ≈ B [ TMap ε b o FMap F (FMap U f ) ] ] 
-           lemma-assoc1 f =  IsNTrans.naturality ( isNTrans ε )
-           assoc1 : {a : Obj A} → A [ A [ TMap μ a o TMap μ ( FObj T a ) ] ≈  A [  TMap μ a o FMap T (TMap μ a) ] ]
-           assoc1 {a} = let open ≈-Reasoning (A) in
-             begin
-                TMap μ a o TMap μ ( FObj T a )
-             ≈⟨⟩
-                (FMap U (TMap ε ( FObj F a ))) o (FMap U (TMap ε ( FObj F ( FObj U (FObj F  a )))))
-             ≈⟨ sym (distr U) ⟩
-                FMap U (B [ TMap ε ( FObj F a )  o TMap ε ( FObj F ( FObj U (FObj F a ))) ] )
-             ≈⟨  (IsFunctor.≈-cong (isFunctor U)) (lemma-assoc1 ( TMap ε (FObj F a ))) ⟩
-                FMap U (B [ (TMap ε ( FObj F a )) o FMap F (FMap U (TMap ε ( FObj F a ))) ] )
-             ≈⟨ distr U ⟩
-                (FMap U (TMap ε ( FObj F a ))) o FMap U (FMap F (FMap U (TMap ε ( FObj F a ))))
-             ≈⟨⟩
-                TMap μ a o FMap T (TMap μ a) 
-             ∎
-           unity1 : {a : Obj A} → A [ A [ TMap μ a o TMap η ( FObj T a ) ] ≈ Id {_} {_} {_} {A} (FObj T a) ]
-           unity1 {a} = let open ≈-Reasoning (A) in
-             begin
-               TMap μ a o TMap η ( FObj T a )
-             ≈⟨⟩
-               (FMap U (TMap ε ( FObj F a ))) o TMap η ( FObj U ( FObj F  a ))
-             ≈⟨ IsAdjunction.adjoint1 ( isAdjunction adj ) ⟩
-               id (FObj U ( FObj F a ))
-             ≈⟨⟩
-               id (FObj T a)
-             ∎
-           unity2 : {a : Obj A} → A [ A [ TMap μ a o (FMap T (TMap η a ))] ≈ Id {_} {_} {_} {A} (FObj T a) ]
-           unity2 {a} = let open ≈-Reasoning (A) in
-             begin
-                TMap μ a o (FMap T (TMap η a ))
-             ≈⟨⟩
-                (FMap U (TMap ε ( FObj F a ))) o (FMap U ( FMap F (TMap η a )))
-             ≈⟨ sym (distr U ) ⟩
-                FMap U ( B [  (TMap ε ( FObj F a )) o ( FMap F (TMap η a )) ])
-             ≈⟨ (IsFunctor.≈-cong (isFunctor U)) (IsAdjunction.adjoint2 ( isAdjunction adj )) ⟩
-                FMap U ( id1 B (FObj F a) )
-             ≈⟨ IsFunctor.identity ( isFunctor U ) ⟩
-                id (FObj T a)
-             ∎