Mercurial > hg > Members > atton > delta_monad

changeset 111:9fe3d0bd1149

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Prove right-unity-law on DeltaM
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Thu, 29 Jan 2015 11:42:22 +0900
parents cd058dd89864
children 0a3b6cb91a05
files agda/deltaM.agda agda/deltaM/monad.agda
diffstat 2 files changed, 64 insertions(+), 54 deletions(-) [+]
line wrap: on
line diff
--- a/agda/deltaM.agda	Wed Jan 28 22:36:34 2015 +0900
+++ b/agda/deltaM.agda	Thu Jan 29 11:42:22 2015 +0900
@@ -71,6 +71,16 @@
             A -> (DeltaM M {functorM} {monadM} A (S n))
 deltaM-eta {n = n} {monadM = mm} x = deltaM (delta-eta {n = n} (eta mm x))
 
+deltaM-mu : {l : Level} {A : Set l} {n : Nat} 
+                        {M : {l' : Level} -> Set l' -> Set l'}
+                        {functorM : {l' : Level} -> Functor {l'} M}
+                        {monadM   : {l' : Level} -> Monad {l'} M functorM} ->
+                        DeltaM M {functorM} {monadM} (DeltaM M {functorM} {monadM} A (S n)) (S n)  ->
+                        DeltaM M {functorM} {monadM} A (S n)
+deltaM-mu {n = O}   {functorM = fm} {monadM = mm} (deltaM (mono x))    = deltaM (mono (mu mm (fmap fm headDeltaM x)))
+deltaM-mu {n = S n} {functorM = fm} {monadM = mm} (deltaM (delta x d)) = appendDeltaM (deltaM (mono (mu mm (fmap fm headDeltaM x))))
+                                                                                      (deltaM-mu (deltaM-fmap tailDeltaM (deltaM d)))
+                                                  
 
 deltaM-bind : {l : Level} {A B : Set l} 
                           {n : Nat} 
@@ -85,9 +95,3 @@
                                                                                (deltaM-bind (deltaM d) (tailDeltaM ∙ f))
 
 
-deltaM-mu : {l : Level} {A : Set l} {n : Nat}
-                        {M : {l' : Level} -> Set l' -> Set l'}
-                        {functorM : {l' : Level} -> Functor {l'} M}
-                        {monadM   : {l' : Level} -> Monad {l'}  M functorM}
-            -> (DeltaM M (DeltaM M {functorM} {monadM} A (S n)) (S n)) -> DeltaM M {functorM} {monadM} A (S n)
-deltaM-mu d = deltaM-bind d id
--- a/agda/deltaM/monad.agda	Wed Jan 28 22:36:34 2015 +0900
+++ b/agda/deltaM/monad.agda	Thu Jan 29 11:42:22 2015 +0900
@@ -5,6 +5,7 @@
 open import basic
 open import delta
 open import delta.functor
+open import delta.monad
 open import deltaM
 open import deltaM.functor
 open import nat
@@ -16,51 +17,56 @@
 open Monad
 
 
-headDeltaM-commute : {l : Level} {A B : Set l} {n : Nat}
-                                 {M : {l' : Level} -> Set l' -> Set l'} -> 
-                                 {functorM :  {l' : Level}  -> Functor {l'}  M} ->
-                                 {monadM   : {l' : Level} -> Monad {l'} M (functorM ) } ->
-                                 (f : A -> B) -> (x : DeltaM M {functorM} {monadM} A n) -> 
-                    headDeltaM (deltaM-fmap f x) ≡ fmap functorM  f (headDeltaM x)
-headDeltaM-commute f (deltaM (mono x))    = refl
-headDeltaM-commute f (deltaM (delta x d)) = refl
-
-
-{-
-headDeltaM-is-natural-transformation : {l : Level} {A : Set l} {n : Nat}
-                                       {M : {l' : Level} -> Set l' -> Set l'} ->
-                                       {functorM :  {l' : Level} -> Functor {l'} M}
-                                       {monadM   : {l' : Level} -> Monad {l'} M functorM } ->
-                                       NaturalTransformation {l} (\A -> DeltaM M {functorM} {monadM} A n) M
-                                                                 {\f d → deltaM (mono (headDeltaM (deltaM-fmap f d)))}
-                                                                 {fmap functorM} headDeltaM
-
-headDeltaM-is-natural-transformation = record { commute = headDeltaM-commute }
--}
-
 
 deltaM-right-unity-law : {l : Level} {A : Set l} 
                          {M : {l' : Level} -> Set l' -> Set l'}
-                         (functorM : {l' : Level} -> Functor {l'} M)
-                         (monadM   : {l' : Level} -> Monad {l'} M functorM)
-                         (d : DeltaM M {functorM} {monadM} A (S O)) -> 
+                         {functorM : {l' : Level} -> Functor {l'} M}
+                         {monadM   : {l' : Level} -> Monad {l'} M functorM}
+                         {n : Nat}
+                           (d : DeltaM M {functorM} {monadM} A (S n)) ->
                               (deltaM-mu ∙ deltaM-eta) d ≡ id d
-deltaM-right-unity-law {l} {A} {M} functorM monadM (deltaM (mono x))    = begin
-  (deltaM-mu ∙ deltaM-eta) (deltaM (mono x))                ≡⟨ refl ⟩
-  deltaM-mu (deltaM-eta (deltaM (mono x)))                  ≡⟨ refl ⟩
-  deltaM-mu (deltaM (mono (eta monadM (deltaM (mono x)))))  ≡⟨ refl ⟩
-  deltaM (mono (mu monadM (fmap functorM (headDeltaM {l} {A} {S O} {M}) (eta monadM (deltaM (mono x))))))
-  ≡⟨ cong (\de -> deltaM (mono (mu monadM (de)))) (sym (eta-is-nt monadM headDeltaM (deltaM (mono x)))) ⟩
-  deltaM (mono (mu monadM (eta monadM (headDeltaM {l} {A} {S O} {M} {functorM} {monadM} (deltaM (mono x))))))
+deltaM-right-unity-law {l} {A} {M} {fm} {mm} {O} (deltaM (mono x)) = begin
+  deltaM-mu (deltaM-eta (deltaM (mono x)))             ≡⟨ refl ⟩
+  deltaM-mu (deltaM (mono (eta mm (deltaM (mono x))))) ≡⟨ refl ⟩
+  deltaM (mono (mu mm (fmap fm (headDeltaM {M = M})(eta mm (deltaM (mono x))))))
+  ≡⟨ cong (\de -> deltaM (mono (mu mm de))) (sym (eta-is-nt mm headDeltaM (deltaM (mono x)) )) ⟩
+  deltaM (mono (mu mm (eta mm ((headDeltaM {l} {A} {O} {M} {fm} {mm}) (deltaM (mono x)))))) ≡⟨ refl ⟩
+  deltaM (mono (mu mm (eta mm x))) ≡⟨ cong (\de -> deltaM (mono de)) (sym (right-unity-law mm x)) ⟩
+  deltaM (mono x)
+  ∎
+deltaM-right-unity-law {l} {A} {M} {fm} {mm} {S n} (deltaM (delta x d)) = begin
+  deltaM-mu (deltaM-eta (deltaM (delta x d)))
+  ≡⟨ refl ⟩
+  deltaM-mu (deltaM (delta (eta mm (deltaM (delta x d))) (delta-eta (eta mm (deltaM (delta x d))))))
   ≡⟨ refl ⟩
-  deltaM (mono (mu monadM (eta monadM x))) 
-  ≡⟨ cong (\de -> deltaM (mono de)) (sym (right-unity-law monadM x ) )⟩
-  deltaM (mono x)
+  appendDeltaM (deltaM (mono (mu mm (fmap fm (headDeltaM {monadM = mm}) (eta mm (deltaM (delta x d))))))) 
+               (deltaM-mu (deltaM-fmap tailDeltaM (deltaM (delta-eta (eta mm (deltaM (delta x d)))))))
+  ≡⟨ cong (\de -> appendDeltaM (deltaM (mono (mu mm de)))
+                                (deltaM-mu (deltaM-fmap tailDeltaM (deltaM (delta-eta (eta mm (deltaM (delta x d))))))))
+           (sym (eta-is-nt mm headDeltaM (deltaM (delta x d)))) ⟩
+  appendDeltaM (deltaM (mono (mu mm (eta mm ((headDeltaM {monadM = mm}) (deltaM (delta x d)))))))
+               (deltaM-mu (deltaM-fmap tailDeltaM (deltaM (delta-eta (eta mm (deltaM (delta x d)))))))
+  ≡⟨ refl ⟩
+  appendDeltaM (deltaM (mono (mu mm (eta mm x))))
+               (deltaM-mu (deltaM-fmap tailDeltaM (deltaM (delta-eta (eta mm (deltaM (delta x d)))))))
+  ≡⟨ cong (\de -> appendDeltaM (deltaM (mono de)) (deltaM-mu (deltaM-fmap tailDeltaM (deltaM (delta-eta (eta mm (deltaM (delta x d)))))))) 
+           (sym (right-unity-law mm x)) ⟩
+  appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM-fmap tailDeltaM (deltaM (delta-eta (eta mm (deltaM (delta x d)))))))
   ≡⟨ refl ⟩
-  id (deltaM (mono x))
+  appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM (delta-fmap (fmap fm tailDeltaM) (delta-eta (eta mm (deltaM (delta x d)))))))
+  ≡⟨ cong (\de -> appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM de))) (sym (eta-is-nt delta-is-monad (fmap fm tailDeltaM) (eta mm (deltaM (delta x d))))) ⟩
+  appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM (delta-eta (fmap fm tailDeltaM (eta mm (deltaM (delta x d)))))))
+  ≡⟨ cong (\de -> appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM (delta-eta de)))) (sym (eta-is-nt mm tailDeltaM (deltaM (delta x d)))) ⟩
+  appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM (delta-eta (eta mm (tailDeltaM (deltaM (delta x d)))))))
+  ≡⟨ refl ⟩
+  appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM (delta-eta (eta mm (deltaM d)))))
+  ≡⟨ refl ⟩
+  appendDeltaM (deltaM (mono x)) (deltaM-mu (deltaM-eta (deltaM d)))
+  ≡⟨ cong (\de -> appendDeltaM (deltaM (mono x)) de) (deltaM-right-unity-law (deltaM d)) ⟩
+  appendDeltaM (deltaM (mono x)) (deltaM d)
+  ≡⟨ refl ⟩
+  deltaM (delta x d)
   ∎
-deltaM-right-unity-law functorM monadM (deltaM (delta x ()))
--- cannot apply (mu ∙ eta) for over 2 version delta.
 
 
 {-
@@ -86,17 +92,17 @@
                               {M : {l' : Level} -> Set l' -> Set l'}
                               (functorM : {l' : Level}  -> Functor {l'} M)
                               (monadM   : {l' : Level}-> Monad {l'}  M functorM) ->
-               Monad {l} (\A -> DeltaM M {functorM} {monadM} A n) deltaM-is-functor
+               Monad {l} (\A -> DeltaM M {functorM} {monadM} A (S n)) deltaM-is-functor
 deltaM-is-monad functorM monadM = record
-                                    { mu = deltaM-mu;
-                                      eta = deltaM-eta;
-                                    return = {!!};
-                                    bind = {!!};
-                                    association-law = {!!};
-                                    left-unity-law = {!!};
-                                    right-unity-law = {!!};
-                                    eta-is-nt = {!!}
-                                    }
+                                    { mu     = deltaM-mu;
+                                      eta    = deltaM-eta;
+                                      return = deltaM-eta;
+                                      bind   = deltaM-bind;
+                                      association-law = {!!};
+                                      left-unity-law = {!!};
+                                      right-unity-law = (\x -> (sym (deltaM-right-unity-law x))) ;
+                                      eta-is-nt = {!!} 
+                                     }