module nat  where 

-- 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 Functor

--T(g f) = T(g) T(f)

Lemma1 : {c₁ c₂ l : Level} {A : Category c₁ c₂ l} (T : Functor A A) →  {a b c : Obj A} {g : Hom A b c} { f : Hom A a b }
     → A [ ( FMap T (A [ g o f ] ))  ≈ (A [ FMap T g o FMap T f ]) ]
Lemma1 = \t → IsFunctor.distr ( isFunctor t )

--        F(f)
--   F(a) ---→ F(b)
--    |          |
--    |t(a)      |t(b)    G(f)t(a) = t(b)F(f)
--    |          |
--    v          v
--   G(a) ---→ G(b)
--        G(f)

record IsNTrans {c₁ c₂ ℓ c₁′ c₂′ ℓ′ : Level} (D : Category c₁ c₂ ℓ) (C : Category c₁′ c₂′ ℓ′)
                 ( F G : Functor D C )
                 (Trans : (A : Obj D) → Hom C (FObj F A) (FObj G A))
                 : Set (suc (c₁ ⊔ c₂ ⊔ ℓ ⊔ c₁′ ⊔ c₂′ ⊔ ℓ′)) where
  field
    naturality : {a b : Obj D} {f : Hom D a b} 
      → C [ C [ (  FMap G f ) o  ( Trans a ) ]  ≈ C [ (Trans b ) o  (FMap F f)  ] ]
--    uniqness : {d : Obj D} 
--      →  C [ Trans d  ≈ Trans d ]


record NTrans {c₁ c₂ ℓ c₁′ c₂′ ℓ′ : Level} (domain : Category c₁ c₂ ℓ) (codomain : Category c₁′ c₂′ ℓ′) (F G : Functor domain codomain )
       : Set (suc (c₁ ⊔ c₂ ⊔ ℓ ⊔ c₁′ ⊔ c₂′ ⊔ ℓ′)) where
  field
    Trans :  (A : Obj domain) → Hom codomain (FObj F A) (FObj G A)
    isNTrans : IsNTrans domain codomain F G Trans

open NTrans
Lemma2 : {c₁ c₂ l : Level} {A : Category c₁ c₂ l} {F G : Functor A A} 
      → (μ : NTrans A A F G) → {a b : Obj A} { f : Hom A a b }
      → A [ A [  FMap G f o Trans μ a ]  ≈ A [ Trans μ b o  FMap F f ] ]
Lemma2 = \n → IsNTrans.naturality ( isNTrans  n  )

open import Category.Cat

-- η :   1_A → T
-- μ :   TT → T
-- μ(a)η(T(a)) = a
-- μ(a)T(η(a)) = a
-- μ(a)(μ(T(a))) = μ(a)T(μ(a))

record IsMonad {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) 
                 ( T : Functor A A )
                 ( η : NTrans A A identityFunctor T )
                 ( μ : NTrans A A (T ○ T) T)
                 : Set (suc (c₁ ⊔ c₂ ⊔ ℓ )) where
   field
      assoc  : {a : Obj A} → A [ A [ Trans μ a o Trans μ ( FObj T a ) ] ≈  A [  Trans μ a o FMap T (Trans μ a) ] ]
      unity1 : {a : Obj A} → A [ A [ Trans μ a o Trans η ( FObj T a ) ] ≈ Id {_} {_} {_} {A} (FObj T a) ]
      unity2 : {a : Obj A} → A [ A [ Trans μ a o (FMap T (Trans η a ))] ≈ Id {_} {_} {_} {A} (FObj T a) ]

record Monad {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) (T : Functor A A) (η : NTrans A A identityFunctor T) (μ : NTrans A A (T ○ T) T)
       : Set (suc (c₁ ⊔ c₂ ⊔ ℓ )) where
  eta : NTrans A A identityFunctor T
  eta = η
  mu : NTrans A A (T ○ T) T
  mu = μ
  field
    isMonad : IsMonad A T η μ

open Monad
Lemma3 : {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 } →
                 ( M : Monad A T η μ )
    → A [ A [  Trans μ a o Trans μ ( FObj T a ) ] ≈  A [  Trans μ a o FMap T (Trans μ a) ] ]
Lemma3 = \m → IsMonad.assoc ( isMonad m )


Lemma4 : {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) {a b : Obj A } { f : Hom A a b}
    → A [ A [ Id {_} {_} {_} {A} b o f ] ≈ f ]
Lemma4 = \a → IsCategory.identityL ( Category.isCategory a )

Lemma5 : {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 } →
                 ( M : Monad A T η μ )
    →  A [ A [ Trans μ a o Trans η ( FObj T a )  ] ≈ Id {_} {_} {_} {A} (FObj T a) ]
Lemma5 = \m → IsMonad.unity1 ( isMonad m )

Lemma6 : {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 } →
                 ( M : Monad A T η μ )
    →  A [ A [ Trans μ a o (FMap T (Trans η a )) ] ≈ Id {_} {_} {_} {A} (FObj T a) ]
Lemma6 = \m → IsMonad.unity2 ( isMonad m )

-- T = M x A
-- nat of η
-- g ○ f = μ(c) T(g) f
-- η(b) ○ f = f
-- f ○ η(a) = f
-- h ○ (g ○ f) = (h ○ g) ○ f

record Kleisli  { 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 η μ ) : Set (suc (c₁ ⊔ c₂ ⊔ ℓ )) where
     monad : Monad A T η μ 
     monad = M
     -- g ○ f = μ(c) T(g) f
     join : { 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 )
     join c g f = A [ Trans μ c  o A [ FMap T g  o f ] ]



module ≈-Reasoning {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) where
  open import Relation.Binary.Core renaming ( Trans to Trasn1 )

  refl-hom :   {a b : Obj A } { x : Hom A a b }  →
        A [ x ≈ x ]
  refl-hom =  IsEquivalence.refl (IsCategory.isEquivalence  ( Category.isCategory A ))

  trans-hom :   {a b : Obj A } 
                { x y z : Hom A a b }  →
        A [ x ≈ y ] → A [ y ≈ z ] → A [ x ≈ z ]
  trans-hom b c = ( IsEquivalence.trans (IsCategory.isEquivalence  ( Category.isCategory A ))) b c

  -- some short cuts

  car-eq : {a b c : Obj A } {x y : Hom A a b } ( f : Hom A c a ) →
         A [ x ≈ y ] → A [ A [ x o f ] ≈ A [ y  o f ] ]
  car-eq f eq = ( IsCategory.o-resp-≈ ( Category.isCategory A )) ( refl-hom  ) eq

  cdr-eq : {a b c : Obj A } {x y : Hom A a b } ( f : Hom A b c ) →
         A [ x ≈ y ] → A [ A [ f o x ] ≈ A [ f  o y ] ]
  cdr-eq f eq = ( IsCategory.o-resp-≈ ( Category.isCategory A )) eq (refl-hom  ) 

  id :  (a  : Obj A ) →  Hom A a a
  id a =  (Id {_} {_} {_} {A} a) 

  idL :  {a b : Obj A } { f : Hom A b a } → A [ A [ id a o f ] ≈ f ]
  idL =  IsCategory.identityL (Category.isCategory A)

  idR :  {a b : Obj A } { f : Hom A a b } → A [ A [ f o id a ] ≈ f ]
  idR =  IsCategory.identityR (Category.isCategory A)

  sym :  {a b : Obj A } { f g : Hom A a b } -> A [ f ≈ g ] -> A [ g ≈ f ]
  sym   =  IsEquivalence.sym (IsCategory.isEquivalence (Category.isCategory A))

  assoc :   {a b c d : Obj A }  {f : Hom A c d}  {g : Hom A b c} {h : Hom A a b}
                                  → A [ A [ f o A [ g o h ] ]  ≈ A [ A [ f o g ] o h ] ]
  assoc =  IsCategory.associative (Category.isCategory A)

  distr :  (T : Functor A A) →  {a b c : Obj A} {g : Hom A b c} { f : Hom A a b }
     → A [ ( FMap T (A [ g o f ] ))  ≈ (A [ FMap T g o FMap T f ]) ]
  distr T = IsFunctor.distr ( isFunctor T )

  nat : { c₁′ c₂′ ℓ′ : Level}  (D : Category c₁′ c₂′ ℓ′) {a b : Obj D} {f : Hom D a b}  {F G : Functor D A }
      →  (η : NTrans D A F G )
      → A [ A [ (  FMap G f ) o  ( Trans η a ) ]  ≈ A [ (Trans η b ) o  (FMap F f)  ] ]
  nat _ η  =  IsNTrans.naturality ( isNTrans η  )

  infixr  2 _∎
  infixr 2 _≈⟨_⟩_ 
  infix  1 begin_

------ If we have this, for example, as an axiom of a category, we can use ≡-Reasoning directly
--  ≈-to-≡ : {a b : Obj A } { x y : Hom A a b }  -> A [ x ≈  y ] -> x ≡ y
--  ≈-to-≡ refl-hom = refl

  data _IsRelatedTo_ { a b : Obj A } ( x y : Hom A a b ) :
                     Set (suc (c₁ ⊔ c₂ ⊔ ℓ ))  where
    relTo : (x≈y : A [ x ≈ y ] ) → x IsRelatedTo y

  begin_ : { a b : Obj A } { x y : Hom A a b } →
           x IsRelatedTo y → A [ x ≈ y ]
  begin relTo x≈y = x≈y

  _≈⟨_⟩_ : { a b : Obj A } ( x : Hom A a b ) → { y z : Hom A a b } → 
           A [ x ≈ y ] → y IsRelatedTo z → x IsRelatedTo z
  _ ≈⟨ x≈y ⟩ relTo y≈z = relTo (trans-hom x≈y y≈z)

  _∎ : { a b : Obj A } ( x : Hom A a b ) → x IsRelatedTo x
  _∎ _ = relTo refl-hom

lemma12 :  {c₁ c₂ ℓ : Level} (L : Category c₁ c₂ ℓ) { a b c : Obj L } → 
       ( x : Hom L c a ) → ( y : Hom L b c ) → L [ L [ x o y ] ≈ L [ x o y ] ]
lemma12 L x y =  
   let open ≈-Reasoning ( L )  in 
      begin  L [ x o y ]  ∎

Lemma61 : {c₁ c₂ ℓ : Level} (A : Category c₁ c₂ ℓ) →
                 { a : Obj A } ( b : Obj A ) →
                 ( f : Hom A a b )
                      →  A [ A [ (Id {_} {_} {_} {A} b) o f ]  ≈ f ]
Lemma61 c b g = -- IsCategory.identityL (Category.isCategory c) 
  let open ≈-Reasoning (c) in 
     begin  
          c [ Id {_} {_} {_} {c} b o g ]
     ≈⟨ IsCategory.identityL (Category.isCategory c) ⟩
          g
     ∎

open Kleisli
-- η(b) ○ f = f
Lemma7 : {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 ) 
                 ( f : Hom A a ( FObj T b) )
                 ( m : Monad A T η μ )
                 ( k : Kleisli A T η μ m) 
                      → A  [ join k b (Trans η b) f  ≈ f ]
Lemma7 c T η b f m k = 
  let open ≈-Reasoning (c) 
      μ = mu ( monad k )
  in 
     begin  
         join k b (Trans η b) f 
     ≈⟨ refl-hom ⟩
         c [ Trans μ b  o c [ FMap T ((Trans η b)) o f ] ]  
     ≈⟨ IsCategory.associative (Category.isCategory c) ⟩
        c [ c [ Trans μ b  o  FMap T ((Trans η b)) ] o f ]
     ≈⟨ car-eq f ( IsMonad.unity2 ( isMonad ( monad k )) )  ⟩
        c [  id (FObj T b)   o f ]
     ≈⟨ IsCategory.identityL (Category.isCategory c) ⟩
        f
     ∎

-- 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 )
                 ( f : Hom A a ( FObj T b) )
                 ( m : Monad A T η μ )
                 ( k : Kleisli A T η μ m) 
                      → A  [ join k b f (Trans η a)  ≈ f ]
Lemma8 c T η a b f m k = 
  begin
     join k b f (Trans η a) 
  ≈⟨ refl-hom ⟩
     c [ Trans μ b  o c [  FMap T f o (Trans η a) ] ]  
  ≈⟨ cdr-eq (Trans μ b) ( IsNTrans.naturality ( isNTrans η  )) ⟩
     c [ Trans μ b  o c [ (Trans η ( FObj T b)) o f ] ] 
  ≈⟨ IsCategory.associative (Category.isCategory c) ⟩
     c [ c [ Trans μ b  o (Trans η ( FObj T b)) ] o f ] 
  ≈⟨ car-eq f ( IsMonad.unity1 ( isMonad ( monad k )) ) ⟩
     c [ id (FObj T b)  o f ]
  ≈⟨  IsCategory.identityL (Category.isCategory c)  ⟩
     f
  ∎  where 
      open ≈-Reasoning (c) 
      μ = mu ( monad k )

-- 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 )
                 ( 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 d h (join k c g f)  ≈ join k d ( join k d h g) f ]
Lemma9 A T η μ a b c d f g h m k = 
  begin 
     join k d h (join k c g f)  
  ≈⟨ refl-hom ⟩
     join k d h ( A [ Trans μ c o A [ FMap T g o f ] ] )
  ≈⟨ refl-hom ⟩
     A [ Trans μ d  o A [ FMap T h  o  A [ Trans μ c o A [ FMap T g  o f ] ] ] ]
   ≈⟨ cdr-eq ( Trans μ d ) ( cdr-eq ( FMap T h ) ( assoc )) ⟩
     A [ Trans μ d  o A [ FMap T h  o  A [ A [ Trans μ c o  FMap T g ]  o f ] ] ]
   ≈⟨ assoc  ⟩    ---   A [ f  o  A [ g  o  h ] ] = A [ A [ f  o  g ]  o  h ]
     A [     A [ Trans μ d o  FMap T h ] o  A [ A [ Trans μ c o  FMap T g ]  o f ] ]
   ≈⟨ assoc  ⟩
     A [ A [ A [ Trans μ d o      FMap T h ] o  A [ Trans μ c  o  FMap T g ] ] o f ]
   ≈⟨ car-eq f (sym assoc) ⟩
     A [ A [ Trans μ d o  A [ FMap T h     o  A [ Trans μ c    o  FMap T g ] ] ] o f ]
   ≈⟨ car-eq f ( cdr-eq ( Trans μ d ) (assoc) ) ⟩
     A [ A [ Trans μ d o  A [ A [ FMap T h o      Trans μ c ]  o  FMap T g ]   ] o f ]
   ≈⟨ car-eq f assoc ⟩
     A [ A [ A [ Trans μ d o  A [ FMap T h   o  Trans μ c ] ]  o  FMap T g ] o f ]
   ≈⟨ car-eq f (car-eq ( FMap T g) ( cdr-eq  ( Trans μ d ) ( begin 
           A [ FMap T h o Trans μ c ]
       ≈⟨ nat A μ ⟩
           A [ Trans μ (FObj T d) o FMap T (FMap T h) ]
        ∎ 
   )))  ⟩
      A [ A [ A [ Trans μ d  o  A [ Trans μ ( FObj T d)    o  FMap T (  FMap T h ) ] ]  o FMap T g ]  o f ]
   ≈⟨ car-eq f (sym assoc) ⟩
     A [ A [ Trans μ d  o  A [ A [ Trans μ ( FObj T d)     o FMap T (  FMap T h ) ]   o FMap T g ] ]   o f ]
   ≈⟨ car-eq f ( cdr-eq ( Trans μ d ) (sym assoc) ) ⟩
     A [ A [ Trans μ d  o  A [ Trans μ ( FObj T d)     o A [ FMap T (  FMap T h ) o FMap T g ] ] ]   o f ]
   ≈⟨ car-eq f ( cdr-eq ( Trans μ d) (cdr-eq  (Trans μ ( FObj T d) ) (sym (distr T )))) ⟩
     A [ A [ Trans μ d  o  A [ Trans μ ( FObj T d)     o FMap T ( A [ FMap T h  o g ] ) ] ]   o f ]
   ≈⟨ car-eq f assoc ⟩
     A [ A [ A [ Trans μ d  o  Trans μ ( FObj T d)   ]  o FMap T ( A [ FMap T h  o g ] ) ]    o f ]
   ≈⟨ car-eq f ( car-eq  (FMap T ( A [ FMap T h  o g ] )) ( 
      begin
         A [ Trans μ d o Trans μ (FObj T d) ]
      ≈⟨ IsMonad.assoc ( isMonad m) ⟩
         A [ Trans μ d o FMap T (Trans μ d) ]
      ∎
   )) ⟩
     A [ A [ A [ Trans μ d  o    FMap T ( Trans μ d) ]  o FMap T ( A [ FMap T h  o g ] ) ]    o f ]
   ≈⟨ car-eq f (sym assoc) ⟩
     A [ A [ Trans μ d  o  A   [ FMap T ( Trans μ d )   o FMap T ( A [ FMap T h  o g ] ) ] ]  o f ]
   ≈⟨ sym assoc ⟩
     A [ Trans μ d  o  A [ A [ FMap T ( Trans μ d )  o FMap T ( A [ FMap T h  o g ] ) ]  o f ] ]
   ≈⟨ cdr-eq ( Trans μ d ) ( car-eq f ( sym ( distr T )))   ⟩
     A [ Trans μ d  o A [ FMap T ( A [ ( Trans μ d ) o A [ FMap T h  o g ] ] ) o f ] ]
   ≈⟨ refl-hom ⟩
     join k d ( A [ Trans μ d  o A [ FMap T h  o g ] ] ) f
   ≈⟨ refl-hom ⟩
     join k d ( join k d h g) f 
  ∎ where open ≈-Reasoning (A) 



-- 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
--                                        }
--                  }