From Tealeaves Require Export
  Classes.Kleisli.DecoratedFunctor
  Classes.Kleisli.DecoratedMonad
  Classes.Kleisli.TraversableFunctor
  Classes.Kleisli.TraversableMonad
  Classes.Kleisli.DecoratedTraversableFunctor
  Functors.Early.Writer.

Import Monoid.Notations.
Import Product.Notations.
Import Monad.Notations.
Import Comonad.Notations.
Import DecoratedMonad.Notations.
Import TraversableFunctor.Notations.
Import TraversableMonad.Notations.
Import DecoratedTraversableFunctor.Notations.

#[local] Generalizable Variables ϕ U T W G A B C D F M.

Class Binddt
  (W: Type)
  (T: Type → Type)
  (U: Type → Type)
  := binddt:
    ∀ (G: Type → Type)
      `{Map_G: Map G} `{Pure_G: Pure G} `{Mult_G: Mult G}
      (A B: Type),
      (W × A → G (T B)) → U A → G (U B).

#[global] Arguments binddt {W}%type_scope {T} {U}%function_scope {Binddt}
  {G}%function_scope {Map_G Pure_G Mult_G}
  {A B}%type_scope _%function_scope _.

Definition kc7
  {W: Type}
  {T: Type → Type}
  `{Return_T: Return T}
  `{Binddt_WTT: Binddt W T T}
  `{op: Monoid_op W} `{unit: Monoid_unit W}
  {A B C: Type}
  (G1 G2: Type → Type)
  `{Map G1} `{Pure G1} `{Mult G1}
  `{Map G2} `{Pure G2} `{Mult G2}:
  (W × B → G2 (T C)) →
  (W × A → G1 (T B)) →
  (W × A → G1 (G2 (T C))) :=
  fun g f '(w, a) ⇒
    map (F := G1) (A := T B) (B := G2 (T C))
      (binddt (g ⦿ w)) (f (w, a)).

#[local] Infix "⋆7" := (kc7 _ _) (at level 60): tealeaves_scope.

Class DecoratedTraversableRightPreModule
  (W: Type)
  (T U: Type → Type)
  `{op: Monoid_op W}
  `{unit: Monoid_unit W}
  `{Return_T: Return T}
  `{Bindd_T: Binddt W T T}
  `{Bindd_U: Binddt W T U} :=
  { kdtm_binddt1: ∀ (A: Type),
      binddt (G := fun A ⇒ A)
        (ret (T := T) ∘ extract (W := (W ×))) = @id (U A);
    kdtm_binddt2:
    ∀ `{Applicative G1} `{Applicative G2}
      `(g: W × B → G2 (T C))
      `(f: W × A → G1 (T B)),
      map (F := G1) (binddt g) ∘ binddt f =
        binddt (U := U) (G := G1 ∘ G2) (g ⋆7 f);
    kdtm_morph:
    ∀ (G1 G2: Type → Type) `{morph: ApplicativeMorphism G1 G2 ϕ}
      `(f: W × A → G1 (T B)),
      ϕ (U B) ∘ binddt f = binddt (ϕ (T B) ∘ f);
  }.

Class DecoratedTraversableMonad
  (W: Type)
  (T: Type → Type)
  `{op: Monoid_op W}
  `{unit: Monoid_unit W}
  `{Return_inst: Return T}
  `{Bindd_T_inst: Binddt W T T} :=
  { kdtm_monoid :> Monoid W;
    kdtm_binddt0: ∀ `{Applicative G} `(f: W × A → G (T B)),
      binddt f ∘ ret = f ∘ ret (T := (W ×));
    kdtm_premod :> DecoratedTraversableRightPreModule W T T;
  }.

Class DecoratedTraversableRightModule
  (W: Type)
  (T U: Type → Type)
  `{op: Monoid_op W}
  `{unit: Monoid_unit W}
  `{Return_inst: Return T}
  `{Bindd_T_inst: Binddt W T T}
  `{Bindd_U_inst: Binddt W T U}
  :=
  { kdtmod_monad :> DecoratedTraversableMonad W T;
    kdtmod_premod :> DecoratedTraversableRightPreModule W T U;
  }.

Class DecoratedTraversableMonadHom
  (T U: Type → Type)
  `{Return T} `{Binddt W T T}
  `{Return U} `{Binddt W U U}
  (ϕ: ∀ (A: Type), T A → U A) :=
  { kmon_hom_ret: ∀ (A: Type),
      ϕ A ∘ @ret T _ A = @ret U _ A;
    kmon_hom_bind:
    ∀ `{Applicative G} `(f: W × A → G (T B)),
      map (F := G) (ϕ B) ∘ @binddt W T T _ G _ _ _ A B f =
        @binddt W U U _ G _ _ _ A B (map (F := G) (ϕ B) ∘ f) ∘ ϕ A;
  }.

Section decorated_monad_kleisli_composition.

  (*
    [local] Set Typeclasses Iterative Deepening. *)

  Context
    `{Return_T: Return T}
    `{Binddt_WTT: Binddt W T T}
    `{op: Monoid_op W}
    `{unit: Monoid_unit W}
    `{! Monoid W}.

  Section incr.

    Context
      `{Applicative G1}
      `{Applicative G2}
      {A B C: Type}.

    Lemma kc7_incr:
      ∀ `(g: W × B → G2 (T C)) `(f: W × A → G1 (T B)) (w: W),
        (g ∘ incr w) ⋆7 (f ∘ incr w) = (g ⋆7 f) ∘ incr w.
    Proof.
      intros. unfold kc7. ext [w' a].
      unfold preincr. reassociate →.
      rewrite incr_incr.
      reflexivity.
    Qed.

    Lemma kc7_preincr:
      ∀ `(g: W × B → G2 (T C)) `(f: W × A → G1 (T B)) (w: W),
        (g ⦿ w) ⋆7 (f ⦿ w) = (g ⋆7 f) ⦿ w.
    Proof.
      intros. unfold preincr. rewrite kc7_incr.
      reflexivity.
    Qed.

  End incr.

  Context
    `{! DecoratedTraversableMonad W T}.

  Context
    `{Applicative G}
    {A B C D: Type}.

  Lemma kc7_id1: ∀ (f: W × A → G (T B)),
      kc7 G (fun A ⇒ A) (ret (T := T) ∘ extract (W := (W ×))) f = f.
  Proof.
    intros.
    unfold kc7.
    ext [w a].
    rewrite preincr_assoc.
    rewrite extract_preincr.
    rewrite kdtm_binddt1.
    rewrite (fun_map_id (F := G)).
    reflexivity.
  Qed.

  Lemma kc7_id2: ∀ (g: W × A → G (T B)),
      kc7 (fun A ⇒ A) G g (ret (T := T) ∘ extract (W := (W ×))) = g.
  Proof.
    intros.
    unfold kc7.
    ext [w a].
    unfold_ops @Map_I.
    change_left ((binddt (T := T) (g ⦿ w) ∘ ret (T := T)) a).
    rewrite kdtm_binddt0.
    change (g (w ● Ƶ, a) = g (w, a)).
    simpl_monoid.
    reflexivity.
  Qed.

  Lemma kc7_assoc
    `{Applicative G3}
    `{Applicative G2}
    `{Applicative G1}:
    ∀ (h: W × C → G3 (T D))
      (g: W × B → G2 (T C))
      (f: W × A → G1 (T B)),
      kc7 (G1 ∘ G2) G3 h (g ⋆7 f) = kc7 G1 (G2 ∘ G3) (h ⋆7 g) f.
  Proof.
    intros.
    unfold kc7 at 1 2.
    ext [w a].
    unfold_ops @Map_compose.
    compose near (f (w, a)) on left.
    rewrite (fun_map_map (F := G1)).
    rewrite kdtm_binddt2.
    rewrite kc7_preincr.
    unfold kc7 at 2.
    reflexivity.
  Qed.

End decorated_monad_kleisli_composition.

Module DerivedOperations.
  Section operations.

    Context
      (W: Type)
      (T: Type → Type)
      (U: Type → Type)
      `{Return_T: Return T}
      `{Bindd_WTU: Binddt W T U}.

    #[export] Instance Map_Binddt: Map U :=
      fun (A B: Type) (f: A → B) ⇒
        binddt (G := fun A ⇒ A)
          (ret (T := T) ∘ f ∘ extract (W := (W ×))).

    #[export] Instance Mapdt_Binddt: Mapdt W U
      := fun G _ _ _ A B f ⇒
           binddt (map (F := G) (ret (T := T)) ∘ f).

    #[export] Instance Bindd_Binddt: Bindd W T U
      := fun A B f ⇒ binddt (G := fun A ⇒ A) f.

    #[export] Instance Bindt_Binddt: Bindt T U
      := fun G _ _ _ A B f ⇒
           binddt (f ∘ extract (W := (W ×))).

    #[export] Instance Bind_Binddt: Bind T U
      := fun A B f ⇒
           binddt (G := fun A ⇒ A)
             (f ∘ extract (W := (W ×))).

    #[export] Instance Mapd_Binddt: Mapd W U
      := fun A B f ⇒
           binddt (G := fun A ⇒ A) (ret (T := T) ∘ f).

    #[export] Instance Traverse_Binddt: Traverse U
      := fun G _ _ _ A B f ⇒
           binddt (map (F := G) ret ∘ f ∘ extract).

  End operations.
End DerivedOperations.

Section decorated_traversable_monad_compat.

  Context
    (W: Type)
    (T: Type → Type)
    (U: Type → Type)
    `{Return_T: Return T}
    `{Binddt_inst: Binddt W T U}
    `{Map_inst: Map U}
    `{Mapd_inst: Mapd W U}
    `{Traverse_inst: Traverse U}
    `{Bind_inst: Bind T U}
    `{Mapdt_inst: Mapdt W U}
    `{Bindd_inst: Bindd W T U}
    `{Bindt_inst: Bindt T U}.

  Class Compat_Map_Binddt: Prop :=
    compat_map_binddt:
      Map_inst =
        @DerivedOperations.Map_Binddt W T U Return_T Binddt_inst.

  Class Compat_Mapd_Binddt: Prop :=
    compat_mapd_binddt:
      Mapd_inst =
        @DerivedOperations.Mapd_Binddt W T U Return_T Binddt_inst.

  Class Compat_Traverse_Binddt: Prop :=
    compat_traverse_binddt:
      ∀ `{Applicative G},
      @Traverse_inst G _ _ _ =
        @DerivedOperations.Traverse_Binddt W T U Return_T Binddt_inst _ _ _ _.

  Class Compat_Bind_Binddt: Prop :=
    compat_bind_binddt:
      Bind_inst =
        @DerivedOperations.Bind_Binddt W T U Binddt_inst.

  Class Compat_Bindd_Binddt: Prop :=
    compat_bindd_binddt:
      Bindd_inst =
        @DerivedOperations.Bindd_Binddt W T U Binddt_inst.

  Class Compat_Bindt_Binddt: Prop :=
    compat_bindt_binddt:
      Bindt_inst =
        @DerivedOperations.Bindt_Binddt W T U Binddt_inst.

  Class Compat_Mapdt_Binddt: Prop :=
    compat_mapdt_binddt:
      ∀ `{Applicative G},
      Mapdt_inst G _ _ _ =
        @DerivedOperations.Mapdt_Binddt W T U Return_T Binddt_inst _ _ _ _.

  Class Compat_Full_Binddt: Prop :=
    { compat_map_binddt_full :> Compat_Map_Binddt;
      compat_mapd_binddt_full :> Compat_Mapd_Binddt;
      compat_traverse_binddt_full :> Compat_Traverse_Binddt;
      compat_bind_binddt_full :> Compat_Bind_Binddt;
      compat_bindd_binddt_full :> Compat_Bindd_Binddt;
      compat_bindt_binddt_full :> Compat_Bindt_Binddt;
      compat_mapdt_binddt_full :> Compat_Mapdt_Binddt;
    }.

End decorated_traversable_monad_compat.

Section decorated_traversable_monad_compat_self.

  Context
    (W: Type)
    (T: Type → Type)
    (U: Type → Type)
    `{Return_T: Return T}
    `{Binddt_WTU: Binddt W T U}.

  #[export] Instance Compat_Map_Binddt_Self:
    Compat_Map_Binddt W T U
      (Map_inst := DerivedOperations.Map_Binddt W T U).
  Proof.
    reflexivity.
  Qed.

  #[export] Instance Compat_Mapd_Binddt_Self:
    Compat_Mapd_Binddt W T U
      (Mapd_inst := DerivedOperations.Mapd_Binddt W T U).
  Proof.
    reflexivity.
  Qed.

  #[export] Instance Compat_Traverse_Binddt_Self:
    Compat_Traverse_Binddt W T U
      (Traverse_inst := DerivedOperations.Traverse_Binddt W T U).
  Proof.
    cbv. intros.
    reflexivity.
  Qed.

  #[export] Instance Compat_Bind_Binddt_Self:
    Compat_Bind_Binddt W T U
      (Bind_inst := DerivedOperations.Bind_Binddt W T U).
  Proof.
    reflexivity.
  Qed.

  #[export] Instance Compat_Bindd_Binddt_Self:
    Compat_Bindd_Binddt W T U
      (Bindd_inst := DerivedOperations.Bindd_Binddt W T U).
  Proof.
    reflexivity.
  Qed.

  #[export] Instance Compat_Bindt_Binddt_Self:
    Compat_Bindt_Binddt W T U
      (Bindt_inst := DerivedOperations.Bindt_Binddt W T U).
  Proof.
    reflexivity.
  Qed.

  #[export] Instance Compat_Mapdt_Binddt_Self:
    Compat_Mapdt_Binddt W T U
      (Mapdt_inst := DerivedOperations.Mapdt_Binddt W T U).
  Proof.
    cbv.
    intros.
    reflexivity.
  Qed.

  Ltac normalize_binddt :=
    repeat (rewrite (compat_map_binddt W T U) ||
              rewrite (compat_mapd_binddt W T U) ||
                rewrite (compat_traverse_binddt W T U) ||
                  rewrite (compat_mapdt_binddt W T U) ||
                    rewrite (compat_bind_binddt W T U) ||
                      rewrite (compat_bindd_binddt W T U) ||
                        rewrite (compat_bindt_binddt W T U)).

  Ltac solve_compat :=
    hnf;
    intros;
    normalize_binddt;
    unfold_ops @DerivedOperations.Map_Bind;
    unfold_ops @DerivedOperations.Map_Traverse;
    unfold_ops @DerivedOperations.Map_Mapd;
    unfold_ops @DerivedOperations.Map_Mapdt;
    unfold_ops @DerivedOperations.Mapd_Mapdt;
    unfold_ops @DerivedOperations.Traverse_Mapdt;
    unfold_ops @DerivedOperations.Map_Bindd;
    unfold_ops @DerivedOperations.Mapd_Bindd;
    unfold_ops @DerivedOperations.Bind_Bindd;
    unfold_ops @DerivedOperations.Map_Bindt;
    unfold_ops @DerivedOperations.Traverse_Bindt;
    unfold_ops @DerivedOperations.Bind_Bindt;
    normalize_binddt;
    reflexivity.

  Context
    `{Map_U: Map U}
    `{Mapd_WU: Mapd W U}
    `{Traverse_U: Traverse U}
    `{Mapdt_WU: Mapdt W U}
    `{Bind_TU: Bind T U}
    `{Bindd_WTU: Bindd W T U}
    `{Bindt_TU: Bindt T U}
    `{! Compat_Map_Binddt W T U}
    `{! Compat_Mapd_Binddt W T U}
    `{! Compat_Traverse_Binddt W T U}
    `{! Compat_Mapdt_Binddt W T U}
    `{! Compat_Bind_Binddt W T U}
    `{! Compat_Bindd_Binddt W T U}
    `{! Compat_Bindt_Binddt W T U}.

  #[export] Instance Compat_Map_Traverse_Binddt:
    Compat_Map_Traverse U := ltac:(solve_compat).

  #[export] Instance Compat_Map_Mapd_Binddt:
    Compat_Map_Mapd W U := ltac:(solve_compat).

  #[export] Instance Compat_Map_Bind_Binddt:
    Compat_Map_Bind T U := ltac:(solve_compat).

  #[export] Instance Compat_Map_Bindd_Binddt:
    Compat_Map_Bindd W T U := ltac:(solve_compat).

  #[export] Instance Compat_Mapd_Bindd_Binddt:
    Compat_Mapd_Bindd W T U := ltac:(solve_compat).

  #[export] Instance Compat_Bind_Bindd_Binddt:
    Compat_Bind_Bindd W T U := ltac:(solve_compat).

  #[export] Instance Compat_Map_Bindt_Bindtt:
    Compat_Map_Bindt T U := ltac:(solve_compat).

  #[export] Instance Compat_Traverse_Bindt_Bindtt:
    Compat_Traverse_Bindt T U := ltac:(solve_compat).

  #[export] Instance Compat_Bind_Bindt_Bindtt:
    Compat_Bind_Bindt T U := ltac:(solve_compat).

  #[export] Instance Compat_Map_Mapdt_Binddt:
    Compat_Map_Mapdt W U := ltac:(solve_compat).

  #[export] Instance Compat_Mapd_Mapdt_Binddt:
    Compat_Mapd_Mapdt W U := ltac:(solve_compat).

  #[export] Instance Compat_Traverse_Mapdt_Binddt:
    Compat_Traverse_Mapdt W U := ltac:(solve_compat).

End decorated_traversable_monad_compat_self.

Section rewriting.

  Context
    `{Return_T: Return T}
    `{Map_U: Map U}
    `{Mapd_WU: Mapd W U}
    `{Traverse_U: Traverse U}
    `{Bind_TU: Bind T U}
    `{Mapdt_WU: Mapdt W U}
    `{Bindd_WTU: Bindd W T U}
    `{Bindt_TU: Bindt T U}
    `{Binddt_WTU: Binddt W T U}.

  Lemma map_to_binddt `{! Compat_Map_Binddt W T U}:
    ∀ `(f: A → B),
      map (F := U) f =
        binddt (G := fun A ⇒ A) (ret (T := T) ∘ f ∘ extract).
  Proof.
    rewrite (compat_map_binddt W T U).
    reflexivity.
  Qed.

  Lemma mapd_to_binddt `{! Compat_Mapd_Binddt W T U}:
    ∀ `(f: W × A → B),
      mapd (T := U) f =
        binddt (G := fun A ⇒ A) (ret (T := T) ∘ f).
  Proof.
    rewrite (compat_mapd_binddt W T U).
    reflexivity.
  Qed.

  Lemma traverse_to_binddt `{! Compat_Traverse_Binddt W T U}
    `{Applicative G}:
    ∀ `(f: A → G B),
      traverse (G := G) (T := U) f =
        binddt (U := U) (map (F := G) (ret (T := T)) ∘ f ∘ extract).
  Proof.
    rewrite (compat_traverse_binddt W T U).
    reflexivity.
  Qed.

  Lemma bind_to_binddt `{! Compat_Bind_Binddt W T U}:
    ∀ `(f: A → T B),
      bind (U := U) f = binddt (U := U) (f ∘ extract).
  Proof.
    rewrite (compat_bind_binddt W T U).
    reflexivity.
  Qed.

  Lemma mapdt_to_binddt `{! Compat_Mapdt_Binddt W T U}:
    ∀ `{Applicative G} `(f: W × A → G B),
      mapdt (G := G) f = binddt (map (ret (T := T)) ∘ f).
  Proof.
    intros.
    rewrite (compat_mapdt_binddt W T U).
    reflexivity.
  Qed.

  Lemma mapdt_to_binddt' `{! Compat_Mapdt_Binddt W T U}:
    ∀ `{Applicative G} (A B: Type),
      mapdt (T := U) (G := G) (A := A) (B := B) =
        binddt ∘ compose (map ret).
  Proof.
    intros.
    ext f.
    rewrite mapdt_to_binddt.
    reflexivity.
  Qed.

  Lemma bindd_to_binddt `{! Compat_Bindd_Binddt W T U}:
    ∀ (A B: Type),
      bindd (T := T) (U := U) (A := A) (B := B) =
        binddt (G := fun A ⇒ A).
  Proof.
    rewrite (compat_bindd_binddt W T U).
    reflexivity.
  Qed.

  Lemma bindt_to_binddt `{! Compat_Bindt_Binddt W T U}
    `{Applicative G} `(f: A → G (T B)):
    bindt (G := G) f = binddt (U := U) (f ∘ extract).
  Proof.
    rewrite (compat_bindt_binddt W T U).
    reflexivity.
  Qed.

  Lemma map_to_bind
    `{! Compat_Map_Binddt W T U}
    `{! Compat_Bind_Binddt W T U}
   : ∀ (A B: Type) (f: A → B),
      map f = bind (ret ∘ f).
  Proof.
    rewrite (compat_map_bind
               (Compat_Map_Bind :=
                  Compat_Map_Bind_Binddt W T U)).
    reflexivity.
  Qed.

  Lemma map_to_bindd
    `{! Compat_Map_Binddt W T U}
    `{! Compat_Bindd_Binddt W T U}
   : ∀ (A B: Type) (f: A → B),
      map (F := U) f = bindd (ret ∘ f ∘ extract).
  Proof.
    intros.
    rewrite (compat_map_bindd W T U
               (Compat_Map_Bindd :=
                  Compat_Map_Bindd_Binddt W T U)).
    reflexivity.
  Qed.

End rewriting.

Section properties.

  Context
    `{DecoratedTraversableRightModule W T U}.

  Lemma binddt_app_id_l:
    ∀ {G: Type → Type} {A B: Type}
           `{Applicative G} (f: W × A → G (T B)),
      @binddt W T U _ ((fun A ⇒ A) ∘ G)
        (Map_compose (fun A ⇒ A) G)
        (Pure_compose (fun A ⇒ A) G)
        (Mult_compose (fun A ⇒ A) G) A B f =
        binddt (T := T) f.
  Proof.
    intros. fequal. now rewrite (Mult_compose_identity2 G).
  Qed.

  Lemma binddt_app_id_r:
    ∀ {G: Type → Type} {A B: Type}
           `{Applicative G} (f: W × A → G (T B)),
      @binddt W T U _ (G ∘ (fun A ⇒ A))
        (Map_compose G (fun A ⇒ A))
        (Pure_compose G (fun A ⇒ A))
        (Mult_compose G (fun A ⇒ A)) A B f =
        binddt f.
  Proof.
    intros. fequal. now rewrite (Mult_compose_identity1 G).
  Qed.

End properties.

Section derived_instances.

  Context
    `{op: Monoid_op W}
    `{unit: Monoid_unit W}
    `{ret_inst: Return T}
    `{Map_T_inst: Map T}
    `{Mapd_T_inst: Mapd W T}
    `{Traverse_T_inst: Traverse T}
    `{Bind_T_inst: Bind T T}
    `{Mapdt_T_inst: Mapdt W T}
    `{Bindd_T_inst: Bindd W T T}
    `{Bindt_T_inst: Bindt T T}
    `{Binddt_T_inst: Binddt W T T}
    `{! Compat_Map_Binddt W T T}
    `{! Compat_Mapd_Binddt W T T}
    `{! Compat_Traverse_Binddt W T T}
    `{! Compat_Bind_Binddt W T T}
    `{! Compat_Mapdt_Binddt W T T}
    `{! Compat_Bindd_Binddt W T T}
    `{! Compat_Bindt_Binddt W T T}
    `{Monad_inst: ! DecoratedTraversableMonad W T}
    `{Map_U_inst: Map U}
    `{Mapd_U_inst: Mapd W U}
    `{Traverse_U_inst: Traverse U}
    `{Bind_U_inst: Bind T U}
    `{Mapdt_U_inst: Mapdt W U}
    `{Bindd_U_inst: Bindd W T U}
    `{Bindt_U_inst: Bindt T U}
    `{Binddt_U_inst: Binddt W T U}
    `{! Compat_Map_Binddt W T U}
    `{! Compat_Mapd_Binddt W T U}
    `{! Compat_Traverse_Binddt W T U}
    `{! Compat_Bind_Binddt W T U}
    `{! Compat_Mapdt_Binddt W T U}
    `{! Compat_Bindd_Binddt W T U}
    `{! Compat_Bindt_Binddt W T U}
    `{Module_inst: ! DecoratedTraversableRightPreModule W T U}.

  #[local] Ltac unfold_map_id :=
    repeat (change (map (F := fun A ⇒ A) ?f) with f).

  #[local] Hint Unfold kc7 kc6 kc5 kc kc3 kc2 kc1: tealeaves_kc_unfold.

  #[local] Ltac setup :=
    intros;
    autounfold with tealeaves_kc_unfold;
    ext [w a];
    unfold_map_id.

  Ltac kdtmf_normalize_T :=
    repeat
      ( rewrite (map_to_binddt (U := T) (T := T)) ||
          rewrite (bind_to_binddt (U := T) (T := T)) ||
            rewrite (traverse_to_binddt (U := T) (T := T)) ||
              rewrite (mapd_to_binddt (U := T) (T := T)) ||
                rewrite (mapdt_to_binddt (U := T) (T := T)) ||
                  rewrite (bindd_to_binddt (U := T) (T := T)) ||
                    rewrite (bindt_to_binddt (U := T) (T := T))).

  Ltac solve_kc7 :=
    setup;
    kdtmf_normalize_T;
    try (reflexivity ||
           rewrite preincr_assoc;
         rewrite extract_preincr;
         reflexivity).

  Section composition.

    Context
      `{Applicative G1}
      `{Applicative G2}.

    Variables (A B C: Type).

    Lemma kc7_33:
      ∀ (g: W × B → G2 C) (f: W × A → G1 B),
        (map (F := G2) (ret (T := T)) ∘ g) ⋆7
          (map (F := G1) (ret (T := T)) ∘ f) =
          map (F := G1 ∘ G2) (ret (T := T)) ∘ (g ⋆3 f).
    Proof.
      intros.
      unfold kc7.
      ext [w a].
      (* LHS *)
      unfold compose at 2.
      compose near (f (w, a)).
      rewrite (fun_map_map (F := G1)).
      rewrite kdtm_binddt0.
      rewrite preincr_ret.
      (* RHS *)
      unfold kc3.
      unfold_ops @Map_compose.
      do 2 reassociate <- on right.
      unfold_compose_in_compose; rewrite (fun_map_map (F := G1)).
      unfold_ops @Cobind_reader; unfold strength.
      unfold compose at 3 4.
      compose near (f (w, a)) on right.
      rewrite (fun_map_map (F := G1)).
      reflexivity.
    Qed.

    Lemma kc7_55:
      ∀ `(g: W × B → T C) `(f: W × A → T B),
        kc7 (fun A ⇒ A) (fun A ⇒ A) g f = g ⋆5 f.
    Proof.
      intros.
      unfold kc5.
      ext [w a].
      rewrite bindd_to_binddt.
      reflexivity.
    Qed.

    Lemma kc7_44:
      ∀ `(g: W × B → C) `(f: W × A → B),
        kc7 (fun A ⇒ A) (fun A ⇒ A)
          (ret (T := T) ∘ g) (ret (T := T) ∘ f) =
          ret (T := T) ∘ (g ⋆1 f).
    Proof.
      intros.
      rewrite kc7_55.
      unfold kc5.
      ext [w a].
      unfold compose at 2.
      compose near (f (w, a)) on left.
      rewrite bindd_to_binddt.
      rewrite (kdtm_binddt0 (G := fun A ⇒ A)).
      rewrite preincr_ret.
      reflexivity.
    Qed.

    Lemma kc7_66:
      ∀ (g: B → G2 (T C)) (f: A → G1 (T B)),
        kc7 G1 G2
          (g ∘ extract (W := (W ×)))
          (f ∘ extract (W := (W ×))) =
          (g ⋆6 f) ∘ extract (W := (W ×)).
    Proof.
      intros.
      unfold kc7.
      ext [w a].
      rewrite preincr_assoc.
      rewrite extract_preincr.
      unfold kc6.
      rewrite bindt_to_binddt.
      reflexivity.
    Qed.

    Lemma kc7_22:
      ∀ (g: B → G2 C) (f: A → G1 B),
        kc7 G1 G2
          (map (F := G2) (ret (T := T)) ∘ g ∘ extract (W := (W ×)))
          (map (F := G1) (ret (T := T)) ∘ f ∘ extract (W := (W ×))) =
          kc2 (G1 := G1 ∘ G2) (ret (T := T))
            ((map (F := G1) g ∘ f)) ∘ extract (W := (W ×)).
    Proof.
      intros.
      unfold kc7.
      ext [w a].
      rewrite preincr_assoc.
      do 2 reassociate →.
      rewrite extract_preincr.
      unfold compose at 1 2 3 4; cbn.
      compose near (f a) on left.
      rewrite fun_map_map.
      rewrite kdtm_binddt0.
      unfold kc2.
      unfold_ops @Map_compose.
      unfold compose; cbn.
      compose near (f a) on right.
      rewrite fun_map_map.
      reflexivity.
    Qed.

    Lemma kc7_11:
      ∀ (g: B → T C) (f: A → T B),
        kc7 (fun A ⇒ A) (fun A ⇒ A)
          (g ∘ extract (W := (W ×)))
          (f ∘ extract (W := (W ×))) =
          (g ⋆ f) ∘ extract (W := (W ×)).
    Proof.
      setup.
      rewrite (bind_to_binddt (T := T)).
      rewrite preincr_assoc.
      rewrite extract_preincr.
      reflexivity.
    Qed.

    Lemma kc7_00:
      ∀ (g: B → C) (f: A → B),
        kc7 (fun A ⇒ A) (fun A ⇒ A)
          (ret (T := T) ∘ g ∘ extract (W := (W ×)))
          (ret (T := T) ∘ f ∘ extract (W := (W ×))) =
          (ret (T := T) ∘ g ∘ f ∘ extract (W := (W ×))).
    Proof.
      setup; unfold compose; cbn.
      compose near (f a) on left.
      unfold_ops @Map_I.
      rewrite (kdtm_binddt0 (T := T) (G := fun A ⇒ A)).
      rewrite preincr_ret.
      reflexivity.
    Qed.

  End composition.

  Section kc7_special_cases.

    Context
      `{Applicative G1}
      `{Applicative G2}
      {A B C D: Type}.

    Lemma kc7_07:
      ∀ (g: B → C) (f: W × A → G1 (T B)),
        ret (T := T) ∘ g ∘ extract (W := (W ×)) ⋆7 f =
          map (F := G1) (map (F := T) g) ∘ f.
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_17:
      ∀ (g: B → T C) (f: W × A → G1 (T B)),
        g ∘ extract (W := (W ×)) ⋆7 f =
          map (F := G1) (bind (U := T) (T := T) g) ∘ f.
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_27:
      ∀ (g: B → G2 C) (f: W × A → G1 (T B)),
        map (F := G2) (ret (T := T)) ∘ g ∘ extract (W := (W ×)) ⋆7 f =
          map (F := G1) (traverse (T := T) (G := G2) g) ∘ f.
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_67:
      ∀ (g: B → G2 (T C)) (f: W × A → G1 (T B)),
        (g ∘ extract (W := (W ×))) ⋆7 f = g ⋆6 f.
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_47:
      ∀ (g: W × B → C) (f: W × A → G1 (T B)),
        kc7 G1 (fun A ⇒ A) (ret (T := T) ∘ g) f =
          (fun '(w, a) ⇒ map (F := G1) (mapd (g ⦿ w)) (f (w, a))).
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_57:
      ∀ (g: W × B → T C) (f: W × A → G1 (T B)),
        kc7 G1 (fun A ⇒ A) g f = g ⋆7 f.
    Proof.
      reflexivity.
    Qed.

    Lemma kc7_37:
      ∀ (g: W × B → G2 C) (f: W × A → G1 (T B)),
        (map (F := G2) (ret (T := T)) ∘ g) ⋆7 f =
          (fun '(w, a) ⇒ map (F := G1) (mapdt (g ⦿ w)) (f (w, a))).
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_73:
      ∀ (g: W × B → G2 (T C)) (f: W × A → G1 B),
        g ⋆7 (map (F := G1) ret ∘ f) = g ⋆3 f.
    Proof.
      intros. unfold kc7, kc3.
      ext [w a].
      unfold compose; cbn.
      compose near (f (w, a)).
      rewrite fun_map_map.
      rewrite fun_map_map.
      rewrite kdtm_binddt0.
      rewrite preincr_ret.
      reflexivity.
    Qed.

    Lemma kc7_75:
      ∀ (g: W × B → G2 (T C)) (f: W × A → T B),
        kc7 (fun A ⇒ A) G2 g f =
          fun '(w, a) ⇒ binddt (g ⦿ w) (f (w, a)).
    Proof.
      reflexivity.
    Qed.

    Lemma kc7_74:
      ∀ (g: W × B → G2 (T C)) (f: W × A → B),
        kc7 (fun A ⇒ A) G2 g (ret (T := T) ∘ f) = g ⋆1 f.
    Proof.
      intros. unfold kc7.
      ext [w a].
      unfold compose at 1.
      compose near (f (w, a)).
      change (map (F := fun A ⇒ A) ?f) with f.
      rewrite kdtm_binddt0.
      rewrite preincr_ret.
      reflexivity.
    Qed.

    Lemma kc7_76:
      ∀ (g: W × B → G2 (T C)) (f: A → G1 (T B)),
        g ⋆7 (f ∘ extract (W := (W ×))) =
          fun '(w, a) ⇒ map (F := G1) (binddt (g ⦿ w)) (f a).
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_72:
      ∀ (g: W × B → G2 (T C)) (f: A → G1 B),
        g ⋆7 (map (F := G1) ret ∘ f ∘ extract (W := (W ×))) =
          fun '(w, a) ⇒ map (F := G1) (g ∘ pair w) (f a).
    Proof.
      setup.
      unfold compose; cbn.
      compose near (f a) on left.
      rewrite fun_map_map.
      rewrite kdtm_binddt0.
      rewrite preincr_ret.
      reflexivity.
    Qed.

    Lemma kc7_71:
      ∀ (g: W × B → G2 (T C)) (f: A → T B),
        kc7 (fun A ⇒ A) G2 g (f ∘ extract (W := (W ×))) =
          fun '(w, a) ⇒ binddt (g ⦿ w) (f a).
    Proof.
      solve_kc7.
    Qed.

    Lemma kc7_70:
      ∀ (g: W × B → G2 (T C)) (f: A → B),
        kc7 (fun A ⇒ A) G2 g (ret (T := T) ∘ f ∘ extract (W := (W ×))) =
          g ∘ map (F := (W ×)) f.
    Proof.
      setup.
      unfold compose; cbn.
      compose near (f a) on left.
      change (map (F := fun A ⇒ A) ?f) with f.
      rewrite kdtm_binddt0.
      rewrite preincr_ret.
      reflexivity.
    Qed.

    Lemma kc7_56:
      ∀ (g: W × B → T C) (f: W × A → G1 B),
        g ⋆7 map (F := G1)(ret (T := T)) ∘ f =
          (fun '(w, a) ⇒ map (F := G1) (g ∘ pair w) (f (w, a))).
    Proof.
      setup.
      unfold compose; cbn.
      compose near (f (w, a)) on left.
      rewrite fun_map_map.
      rewrite (kdtm_binddt0 (G := fun A ⇒ A)).
      rewrite preincr_ret.
      reflexivity.
    Qed.

    Lemma kc7_63:
      ∀ (g: B → G2 (T C)) (f: W × A → G1 B),
        g ∘ extract ⋆7 map ret ∘ f = map g ∘ f.
    Proof.
      setup.
      unfold compose; cbn.
      compose near (f (w, a)) on left.
      rewrite fun_map_map.
      rewrite kdtm_binddt0.
      rewrite preincr_ret.
      reflexivity.
    Qed.

  End kc7_special_cases.

End derived_instances.

Section other_composition_laws.

  Context
    `{op: Monoid_op W}
    `{unit: Monoid_unit W}
    `{ret_inst: Return T}
    `{Map_T_inst: Map T}
    `{Mapd_T_inst: Mapd W T}
    `{Traverse_T_inst: Traverse T}
    `{Bind_T_inst: Bind T T}
    `{Mapdt_T_inst: Mapdt W T}
    `{Bindd_T_inst: Bindd W T T}
    `{Bindt_T_inst: Bindt T T}
    `{Binddt_T_inst: Binddt W T T}
    `{! Compat_Map_Binddt W T T}
    `{! Compat_Mapd_Binddt W T T}
    `{! Compat_Traverse_Binddt W T T}
    `{! Compat_Bind_Binddt W T T}
    `{! Compat_Mapdt_Binddt W T T}
    `{! Compat_Bindd_Binddt W T T}
    `{! Compat_Bindt_Binddt W T T}
    `{Monad_inst: ! DecoratedTraversableMonad W T}
    `{Map_U_inst: Map U}
    `{Mapd_U_inst: Mapd W U}
    `{Traverse_U_inst: Traverse U}
    `{Bind_U_inst: Bind T U}
    `{Mapdt_U_inst: Mapdt W U}
    `{Bindd_U_inst: Bindd W T U}
    `{Bindt_U_inst: Bindt T U}
    `{Binddt_U_inst: Binddt W T U}
    `{! Compat_Map_Binddt W T U}
    `{! Compat_Mapd_Binddt W T U}
    `{! Compat_Traverse_Binddt W T U}
    `{! Compat_Bind_Binddt W T U}
    `{! Compat_Mapdt_Binddt W T U}
    `{! Compat_Bindd_Binddt W T U}
    `{! Compat_Bindt_Binddt W T U}
    `{Module_inst: ! DecoratedTraversableRightPreModule W T U}.

  (*
    Context
    {W: Type}
    {T: Type -> Type}
    `{Return_T: Return T}
    `{Map_T: Map T}
    `{Mapd_T: Mapd W T}
    `{Traverse_T: Traverse T}
    `{Bind_T: Bind T T}
    `{Mapdt_T: Mapdt W T}
    `{Bindd_T: Bindd W T T}
    `{Bindt_T: Bindt T T}
    `{Binddt_T: Binddt W T T}
    `{Monoid_unit_W: Monoid_unit W}
    `{Monoid_op_W: Monoid_op W}
    `{! DecoratedTraversableMonad W T}
    `{! Compat_Full_Binddt W T T}.

    Context
    {U: Type -> Type}
    `{Map_U: Map U}
    `{Mapd_U: Mapd W U}
    `{Traverse_U: Traverse U}
    `{Bind_U: Bind T U}
    `{Mapdt_U: Mapdt W U}
    `{Bindd_U: Bindd W T U}
    `{Bindt_U: Bindt T U}
    `{Binddt_U: Binddt W T U}
    `{! DecoratedTraversableRightModule W T U}
    `{! Compat_Full_Binddt W T U}.
    *)