From Tealeaves Require Export
  Tactics.Prelude
  Classes.Functor
  Misc.Product
  Misc.Strength
  Functors.Identity
  Functors.Compose.

Import Product.Notations.

#[local] Generalizable Variables ϕ F G A B C.

Class Pure (F: Type → Type) :=
  pure: ∀ {A}, A → F A.
Class Mult (F: Type → Type) :=
  mult: ∀ {A B: Type}, F A × F B → F (A × B).

#[local] Notation "x ⊗ y" :=
  (mult (x, y)) (at level 50, left associativity).

Class Applicative (G: Type → Type)
  `{Map_G: Map G} `{Pure_G: Pure G} `{Mult_G: Mult G} :=
  { app_functor :> Functor G;
    app_pure_natural: ∀ (A B: Type) (f: A → B) (x: A),
      map f (pure x) = pure (f x);
    app_mult_natural:
    ∀ (A B C D: Type) (f: A → C) (g: B → D) (x: G A) (y: G B),
      map f x ⊗ map g y = map (map_tensor f g) (x ⊗ y);
    app_assoc: ∀ (A B C: Type) (x: G A) (y: G B) (z: G C),
      map α ((x ⊗ y) ⊗ z) = x ⊗ (y ⊗ z);
    app_unital_l: ∀ (A: Type) (x: G A),
      map left_unitor (pure tt ⊗ x) = x;
    app_unital_r: ∀ (A: Type) (x: G A),
      map right_unitor (x ⊗ pure tt) = x;
    app_mult_pure: ∀ (A B: Type) (a: A) (b: B),
      pure a ⊗ pure b = pure (a, b);
  }.

#[global] Instance Pure_Natural `{Applicative G}: Natural (@pure G _).
Proof.
  constructor; try typeclasses eauto.
  - intros. unfold compose. ext a.
    now rewrite app_pure_natural.
Qed.

Class ApplicativeMorphism (F G: Type → Type)
  `{Map F} `{Mult F} `{Pure F}
  `{Map G} `{Mult G} `{Pure G}
  (ϕ: ∀ {A}, F A → G A) :=
  { appmor_app_F: Applicative F;
    appmor_app_G: Applicative G;
    appmor_natural: ∀ (A B: Type) (f: A → B) (x: F A),
      ϕ (map f x) = map f (ϕ x);
    appmor_pure: ∀ (A: Type) (a: A),
      ϕ (pure a) = pure a;
    appmor_mult: ∀ (A B: Type) (x: F A) (y: F B),
      ϕ (x ⊗ y) = ϕ x ⊗ ϕ y;
  }.

Section pointfree.

  Context `{ApplicativeMorphism F G ϕ}.

  Lemma appmor_natural_pf: ∀ (A B: Type) (f: A → B),
      ϕ B ∘ map f = map f ∘ ϕ A.
  Proof.
    intros. ext x. apply appmor_natural.
  Qed.

  Lemma appmor_pure_pf: ∀ (A: Type),
      ϕ A ∘ pure = pure.
  Proof.
    intros. ext x. apply appmor_pure.
  Qed.

End pointfree.

#[export] Instance Natural_ApplicativeMorphism
  `{morphism: ApplicativeMorphism F G ϕ}: Natural ϕ.
Proof.
  inversion morphism.
  constructor.
  - typeclasses eauto.
  - typeclasses eauto.
  - intros. ext fa. unfold compose.
    rewrite appmor_natural0.
    reflexivity.
Qed.

Ltac infer_applicative_instances :=
  match goal with
  | H: ApplicativeMorphism ?G1 ?G2 ?ϕ |- _ ⇒
      let app1 := fresh "app1"
      in assert (app1: Applicative G1) by now inversion H
  end; match goal with
       | H: ApplicativeMorphism ?G1 ?G2 ?ϕ |- _ ⇒
           let app2 := fresh "app2"
           in assert (app2: Applicative G2) by now inversion H
       end.

#[export] Instance ApplicativeMorphism_id `{Applicative F}:
  ApplicativeMorphism F F (fun A ⇒ @id (F A)).
Proof.
  constructor; now try typeclasses eauto.
Qed.

Section basics.

  Context
    `{Applicative F}.

  Lemma triangle_1: ∀ (A: Type) (t: F A),
      pure tt ⊗ t = map left_unitor_inv t.
  Proof.
    intros.
    rewrite <- (app_unital_l A t) at 2.
    compose near (pure tt ⊗ t).
    rewrite fun_map_map.
    rewrite unitors_1.
    rewrite fun_map_id.
    reflexivity.
  Qed.

  Lemma triangle_2: ∀ (A: Type) (t: F A),
      t ⊗ pure tt = map right_unitor_inv t.
  Proof.
    intros.
    rewrite <- (app_unital_r A t) at 2.
    compose near (t ⊗ pure tt).
    rewrite fun_map_map.
    rewrite unitors_3.
    rewrite fun_map_id.
    reflexivity.
  Qed.

  Lemma triangle_3: ∀ (A B: Type) (a: A) (t: F B),
      pure a ⊗ t = strength (a, t).
  Proof.
    intros.
    unfold strength.
    rewrite <- (app_unital_l B t) at 2.
    compose near (pure tt ⊗ t).
    rewrite fun_map_map.
    replace (pair a ∘ left_unitor) with
      (map_fst (X := unit) (Y := B) (const a)) by
      (now ext [[] ?]).
    unfold map_fst.
    rewrite <- app_mult_natural.
    rewrite app_pure_natural.
    rewrite fun_map_id.
    reflexivity.
  Qed.

  Lemma triangle_4: ∀ (A B: Type) (a: A) (t: F B),
      t ⊗ pure a = map (fun b ⇒ (b, a)) t.
  Proof.
    intros.
    rewrite <- (app_unital_r B t) at 2.
    compose near (t ⊗ pure tt).
    rewrite (fun_map_map).
    replace ((fun b ⇒ (b, a)) ∘ right_unitor) with
      (map_snd (X := B) (Y := unit) (const a))
      by (now ext [? []]).
    unfold map_snd.
    rewrite <- app_mult_natural.
    rewrite app_pure_natural.
    rewrite fun_map_id.
    reflexivity.
  Qed.

  Lemma weird_1: ∀ (A: Type),
      map left_unitor ∘ mult ∘ pair (pure tt) = @id (F A).
  Proof.
    intros. ext t.
    unfold compose.
    rewrite triangle_1.
    compose near t on left.
    rewrite fun_map_map.
    rewrite unitors_2.
    rewrite fun_map_id.
    reflexivity.
  Qed.

  Lemma weird_2: ∀ A,
      map right_unitor ∘ mult ∘
        (fun b: F A ⇒ (b, pure tt)) = @id (F A).
  Proof.
    intros. ext t.
    unfold compose.
    rewrite triangle_2.
    compose near t on left.
    rewrite fun_map_map.
    rewrite unitors_4.
    rewrite fun_map_id.
    reflexivity.
  Qed.

End basics.

Section Applicative_corollaries.

  Context
    (F: Type → Type)
    `{Applicative F}.

  Lemma app_mult_natural_l:
    ∀ {A B C: Type} (f: A → C) (x: F A) (y: F B),
      map f x ⊗ y = map (map_fst f) (x ⊗ y).
  Proof.
    intros.
    replace y with (map id y) at 1
      by (now rewrite fun_map_id).
    rewrite app_mult_natural.
    reflexivity.
  Qed.

  Lemma app_mult_natural_r:
    ∀ {A B D: Type} (g: B → D) (x: F A) (y: F B),
      x ⊗ map g y = map (map_snd g) (x ⊗ y).
  Proof.
    intros.
    replace x with (map id x) at 1
      by (now rewrite fun_map_id).
    rewrite app_mult_natural.
    reflexivity.
  Qed.

  Corollary app_mult_natural_1:
    ∀ {A B C E: Type}
      (f: A → C) (h: C × B → E) (x: F A) (y: F B),
      map h (map f x ⊗ y) = map (h ∘ map_fst f) (x ⊗ y).
  Proof.
    intros.
    rewrite app_mult_natural_l.
    compose near (x ⊗ y) on left.
    rewrite (fun_map_map).
    reflexivity.
  Qed.

  Corollary app_mult_natural_2:
    ∀ {A B D E: Type}
      (g: B → D) (h: A × D → E) (x: F A) (y: F B),
      map h (x ⊗ map g y) = map (h ∘ map_snd g) (x ⊗ y).
  Proof.
    intros.
    rewrite app_mult_natural_r.
    compose near (x ⊗ y) on left.
    rewrite fun_map_map.
    reflexivity.
  Qed.

  Lemma app_assoc_inv:
    ∀ (A B C: Type) (x: F A) (y: F B) (z: F C),
      map α^-1 (x ⊗ (y ⊗ z)) = (x ⊗ y ⊗ z).
  Proof.
    intros.
    rewrite <- app_assoc.
    compose near (x ⊗ y ⊗ z).
    rewrite fun_map_map.
    rewrite associator_iso_1.
    rewrite fun_map_id.
    reflexivity.
  Qed.

End Applicative_corollaries.

#[export] Instance Pure_I: Pure (fun A ⇒ A) := @id.

#[export] Instance Mult_I: Mult (fun A ⇒ A) := fun A B (p: A × B) ⇒ p.

#[export, program] Instance Applicative_I: Applicative (fun A ⇒ A).

Section pure_as_applicative_transformation.

  Context
    `{Applicative G}.

  Lemma pure_appmor_1: ∀ (A B: Type) (f: A → B) (t: A),
      pure (map (F := fun A ⇒ A) f t) = map f (pure t).
  Proof.
    intros.
    rewrite app_pure_natural.
    reflexivity.
  Qed.

  Lemma pure_appmor_2: ∀ (A: Type) (a: A),
      pure (F := G) (pure (F := fun A ⇒ A) a) = pure a.
  Proof.
    reflexivity.
  Qed.

  Lemma pure_appmor_3: ∀ (A B: Type) (a: A) (b: B),
      pure (mult (F := fun A ⇒ A) (a, b)) = pure a ⊗ pure b.
  Proof.
    intros.
    unfold transparent tcs.
    rewrite app_mult_pure.
    reflexivity.
  Qed.

  #[export] Instance ApplicativeMorphism_pure:
    ApplicativeMorphism (fun A ⇒ A) G (@pure G _) :=
    {| appmor_natural := pure_appmor_1;
       appmor_pure := pure_appmor_2;
       appmor_mult := pure_appmor_3;
    |}.

End pure_as_applicative_transformation.

Section applicative_compose.

  Context
    (G2 G1: Type → Type)
    `{Applicative G1}
    `{Applicative G2}.

  #[export] Instance Pure_compose: Pure (G2 ∘ G1) :=
    fun (A: Type) (a: A) ⇒ pure (F := G2) (pure (F := G1) a).

  #[export] Instance Mult_compose: Mult (G2 ∘ G1) :=
    fun (A B: Type) (p: G2 (G1 A) × G2 (G1 B)) ⇒
      map (F := G2) (mult (F := G1))
        (mult (F := G2) (fst p, snd p)): G2 (G1 (A × B)).

  Lemma app_pure_nat_compose: ∀ (A B: Type) (f: A → B) (x: A),
      map (F := G2 ∘ G1) f (pure (F := G2 ∘ G1) x) = pure (f x).
  Proof.
    intros.
    unfold transparent tcs.
    rewrite 2(app_pure_natural _).
    reflexivity.
  Qed.

  Lemma app_mult_nat_compose:
    ∀ (A B C D: Type) (f: A → C) (g: B → D)
           (x: G2 (G1 A)) (y: G2 (G1 B)),
      map f x ⊗ map g y = map (map_tensor f g) (x ⊗ y).
  Proof.
    intros. unfold transparent tcs. cbn [fst snd].
    rewrite (app_mult_natural).
    compose near (mult (x, y)) on left.
    rewrite (fun_map_map).
    compose near (mult (x, y)) on right.
    rewrite (fun_map_map).
    fequal. ext [fa fb].
    unfold compose.
    rewrite <- (app_mult_natural).
    reflexivity.
  Qed.

  Theorem app_asc_compose:
    ∀ (A B C: Type) (x: G2 (G1 A)) (y: G2 (G1 B)) (z: G2 (G1 C)),
      map (F := G2 ∘ G1) α (x ⊗ y ⊗ z) = x ⊗ (y ⊗ z).
  Proof.
    intros.
    unfold transparent tcs. cbn.
    replace (map (F := G2) (mult (F := G1)) (x ⊗ y) ⊗ z) with
      (map (F := G2)
         (map_tensor (mult (F := G1)) id) ((x ⊗ y) ⊗ z)).
    2: { rewrite <- (app_mult_natural (G := G2)).
         now rewrite fun_map_id. }
    compose near (x ⊗ y ⊗ z) on left.
    rewrite fun_map_map.
    compose near (x ⊗ y ⊗ z) on left.
    rewrite fun_map_map.
    replace (x ⊗ map mult (y ⊗ z)) with
      (map (map_tensor id mult) (x ⊗ (y ⊗ z))).
    2: { rewrite <- app_mult_natural.
         rewrite fun_map_id.
         reflexivity. }
    compose near (x ⊗ (y ⊗ z)).
    rewrite fun_map_map.
    rewrite <- app_assoc.
    compose near (x ⊗ y ⊗ z) on right.
    rewrite fun_map_map.
    - fequal. ext [[ga gb] gc].
      unfold compose, id; cbn.
      rewrite app_assoc.
      reflexivity.
  Qed.

  Theorem app_unital_l_compose: ∀ A (x: G2 (G1 A)),
      map (F := G2 ∘ G1) left_unitor
        (pure (F := G2 ∘ G1) tt ⊗ x) = x.
  Proof.
    intros. unfold transparent tcs. cbn.
    compose near (pure (F := G2) (pure (F := G1) tt) ⊗ x).
    rewrite fun_map_map.
    rewrite triangle_3.
    unfold strength.
    compose near x on left.
    rewrite (fun_map_map).
    rewrite weird_1.
    rewrite (fun_map_id).
    reflexivity.
  Qed.

  Theorem app_unital_r_compose: ∀ (A: Type) (x: (G2 ∘ G1) A),
      map (F := G2 ∘ G1) right_unitor
        (x ⊗ pure (F := G2 ∘ G1) tt) = x.
  Proof.
    intros. unfold compose in ×.
    unfold transparent tcs. cbn.
    compose near (x ⊗ pure (F := G2) (pure (F := G1) tt)).
    rewrite fun_map_map.
    rewrite triangle_4.
    compose near x on left.
    rewrite fun_map_map.
    rewrite weird_2.
    rewrite (fun_map_id).
    reflexivity.
  Qed.

  Lemma app_mult_pure_compose: ∀ (A B: Type) (a: A) (b: B),
      pure (F := G2 ∘ G1) a ⊗ pure (F := G2 ∘ G1) b =
        pure (F := G2 ∘ G1) (a, b).
  Proof.
    intros.
    unfold transparent tcs. cbn.
    assert (square: ∀ (p: G1 A × G1 B),
               map mult (pure (F := G2) p) = pure (F := G2) (mult p)).
    { intros.
      rewrite app_pure_natural.
      reflexivity. }
    rewrite <- (app_mult_pure (G := G1)). (* top triangle *)
    rewrite <- square. (* bottom right square *)
    rewrite <- (app_mult_pure (G := G2)). (* bottom left triangle *)
    reflexivity.
  Qed.

  #[export, program] Instance Applicative_compose:
    Applicative (G2 ∘ G1) :=
    {| app_pure_natural := app_pure_nat_compose;
       app_mult_natural := app_mult_nat_compose;
       app_assoc := app_asc_compose;
       app_unital_l := app_unital_l_compose;
       app_unital_r := app_unital_r_compose;
       app_mult_pure := app_mult_pure_compose;
    |}.

End applicative_compose.

Section applicative_compose_laws.

  Context
    (G: Type → Type)
    `{Applicative G}.

  Theorem Pure_compose_identity1:
    Pure_compose G (fun A ⇒ A) = @pure G _.
  Proof.
    easy.
  Qed.

  Theorem Pure_compose_identity2:
    Pure_compose (fun A ⇒ A) G = @pure G _.
  Proof.
    easy.
  Qed.

  Theorem Mult_compose_identity1:
    Mult_compose G (fun A ⇒ A) = @mult G _.
  Proof.
    ext A B [x y]. cbv in x, y. unfold Mult_compose.
    rewrite (fun_map_id). reflexivity.
  Qed.

  Theorem Mult_compose_identity2:
    Mult_compose (fun A ⇒ A) G = @mult G _.
  Proof.
    ext A B [x y]. cbv in x, y. unfold Mult_compose.
    reflexivity.
  Qed.

End applicative_compose_laws.

Section applicative_compose_laws.

  #[export] Instance ApplicativeMorphism_parallel
    (F1 F2 G1 G2: Type → Type)
    `{Applicative G1}
    `{Applicative G2}
    `{Applicative F1}
    `{Applicative F2}
    `{! ApplicativeMorphism F1 G1 ϕ1}
    `{! ApplicativeMorphism F2 G2 ϕ2}:
  ApplicativeMorphism (F1 ∘ F2) (G1 ∘ G2)
    (fun A ⇒ ϕ1 (G2 A) ∘ map (F := F1) (ϕ2 A)).
  Proof.
    inversion ApplicativeMorphism0.
    inversion ApplicativeMorphism1.
    constructor; try typeclasses eauto.
    - intros.
      unfold_ops @Map_compose. unfold compose.
      compose near x.
      rewrite (fun_map_map (F := F1)).
      assert (appmor_natural1':
               ∀ (A B: Type) (f: A → B),
                 ϕ2 B ∘ map (F := F2) f = map (F := G2) f ∘ ϕ2 A).
      { intros. ext f2a. apply appmor_natural1. }
      rewrite appmor_natural1'.
      rewrite <- (fun_map_map (F := F1)).
      unfold compose.
      rewrite appmor_natural0.
      reflexivity.
    - intros.
      unfold_ops @Pure_compose.
      unfold compose.
      rewrite (app_pure_natural (G := F1)).
      rewrite appmor_pure0.
      rewrite appmor_pure1.
      reflexivity.
    - intros.
      unfold_ops @Mult_compose. unfold compose in ×.
      cbn.
      compose near (x ⊗ y).
      rewrite (fun_map_map (F := F1)).
      assert (appmor_mult1':
               ∀ (A B: Type),
                 ϕ2 (A × B) ∘ mult (F := F2) =
                   mult (F := G2) ∘ map_tensor (ϕ2 A) (ϕ2 B)).
      { intros. ext [x' y'].
        unfold compose; cbn. rewrite appmor_mult1. reflexivity. }
      rewrite appmor_mult1'.
      rewrite appmor_natural0.
      rewrite <- (fun_map_map (F := G1)).
      rewrite appmor_mult0.
      unfold compose; cbn.
      (* rhs *)
      rewrite appmor_natural0.
      rewrite appmor_natural0.
      rewrite (app_mult_natural (G := G1)).
      reflexivity.
  Qed.

  #[export] Instance ApplicativeMorphism_parallel_left
    (F1 F2 G1: Type → Type)
    `{Applicative G1}
    `{Applicative F1}
    `{Applicative F2}
    `{! ApplicativeMorphism F1 G1 ϕ1}:
    ApplicativeMorphism (F1 ∘ F2) (G1 ∘ F2) (fun A ⇒ ϕ1 (F2 A)).
  Proof.
    replace (ϕ1 ○ F2) with
      (fun A ⇒ ϕ1 (F2 A) ∘ map (F := F1) (@id (F2 A))).
    - apply (ApplicativeMorphism_parallel F1 F2 G1 F2).
    - ext A. now rewrite (fun_map_id (F := F1)).
  Qed.

  #[export] Instance ApplicativeMorphism_parallel_right
    (F1 F2 G2: Type → Type)
    `{Applicative G2}
    `{Applicative F1}
    `{Applicative F2}
    `{! ApplicativeMorphism F2 G2 ϕ2}:
    ApplicativeMorphism (F1 ∘ F2) (F1 ∘ G2)
      (fun A ⇒ map (F := F1) (ϕ2 A)).
  Proof.
    change (fun A ⇒ map (ϕ2 A)) with
      ((fun A: Type ⇒ (fun X ⇒ @id (F1 X)) (G2 A) ∘ map (ϕ2 A))).
    apply (ApplicativeMorphism_parallel F1 F2 F1 G2).
  Qed.

  #[export] Instance ApplicativeMorphism_parallel_left_id
    (F2 G1: Type → Type)
    `{Applicative G1}
    `{Applicative F2}
    `{! ApplicativeMorphism (fun A ⇒ A) G1 ϕ1}:
    ApplicativeMorphism F2 (G1 ∘ F2) (fun A ⇒ ϕ1 (F2 A)).
  Proof.
    change F2 with ((fun A ⇒ A) ∘ F2) at 1.
    change Map_G0 with (Map_compose (fun X ⇒ X) F2) at 1.
    change Mult_G0 with (@mult F2 _) at 1.
    rewrite <- (Mult_compose_identity2 F2).
    change Pure_G0 with (@pure F2 _) at 1.
    rewrite <- (Pure_compose_identity2 F2).
    apply (ApplicativeMorphism_parallel_left
             (fun X ⇒ X) F2 G1).
  Qed.

  #[export] Instance ApplicativeMorphism_parallel_right_id
    (F1 G2: Type → Type)
    `{Applicative G2}
    `{Applicative F1}
    `{! ApplicativeMorphism (fun A ⇒ A) G2 ϕ2}:
    ApplicativeMorphism F1 (F1 ∘ G2) (fun A ⇒ map (F := F1) (ϕ2 A)).
  Proof.
    Set Printing Implicit.
    change F1 with (F1 ∘ (fun A ⇒ A)) at 1.
    change Map_G0 with (Map_compose F1 (fun X ⇒ X)) at 1.
    change Mult_G0 with (@mult F1 _) at 1.
    rewrite <- (Mult_compose_identity1 F1).
    change Pure_G0 with (@pure F1 _) at 1.
    rewrite <- (Pure_compose_identity1 F1).
    apply (ApplicativeMorphism_parallel_right
             F1 (fun X ⇒ X) G2).
  Qed.

End applicative_compose_laws.

Definition ap (G: Type → Type) `{Map G} `{Mult G} {A B: Type}:
  G (A → B) → G A → G B
  := fun Gf Ga ⇒ map (fun '(f, a) ⇒ f a) (Gf ⊗ Ga).

#[local] Notation "Gf <⋆> Ga" :=
  (ap _ Gf Ga) (at level 50, left associativity).

Section ApplicativeFunctor_ap.

  Context
    `{Applicative G}.

  Theorem map_to_ap: ∀ `(f: A → B) (t: G A),
      map f t = pure f <⋆> t.
  Proof.
    intros. unfold ap; cbn.
    rewrite triangle_3. unfold strength.
    compose near t on right. rewrite (fun_map_map).
    reflexivity.
  Qed.

  Theorem ap_morphism_1:
    ∀ `{ApplicativeMorphism G G2} {A B}
           (x: G (A → B)) (y: G A),
      ϕ B (x <⋆> y) = (ϕ (A → B) x) <⋆> ϕ A y.
  Proof.
    intros. unfold ap.
    rewrite appmor_natural.
    rewrite appmor_mult.
    reflexivity.
  Qed.

  Theorem ap1:
    ∀ `(t: G A),
      pure id <⋆> t = t.
  Proof.
    intros. rewrite <- map_to_ap.
    now rewrite (fun_map_id).
  Qed.

  Theorem ap2:
    ∀ `(f: A → B) (a: A),
      pure f <⋆> pure a = pure (f a).
  Proof.
    intros. unfold ap.
    rewrite app_mult_pure.
    now rewrite app_pure_natural.
  Qed.

  Theorem ap3:
    ∀ `(f: G (A → B)) (a: A),
      f <⋆> pure a = pure (evalAt a) <⋆> f.
  Proof.
    intros. unfold ap. rewrite triangle_3, triangle_4.
    unfold strength. compose near f.
    now do 2 rewrite (fun_map_map).
  Qed.

  Theorem ap4:
    ∀ {A B C: Type} (f: G (B → C)) (g: G (A → B)) (a: G A),
      (pure compose) <⋆> f <⋆> g <⋆> a =
        f <⋆> (g <⋆> a).
  Proof.
    intros. unfold ap; cbn.
    rewrite (app_mult_natural_1 G).
    rewrite (app_mult_natural_2 G).
    rewrite triangle_3. unfold strength.
    compose near f on left. rewrite (fun_map_map).
    rewrite <- (app_assoc).
    compose near (f ⊗ g ⊗ a).
    rewrite (fun_map_map).
    rewrite <- (app_assoc_inv G).
    rewrite (app_mult_natural_1 G).
    rewrite <- (app_assoc).
    compose near (f ⊗ g ⊗ a) on left.
    rewrite (fun_map_map).
    compose near (f ⊗ g ⊗ a) on left.
    repeat rewrite (fun_map_map).
    fequal. now ext [[x y] z].
  Qed.

End ApplicativeFunctor_ap.

Section ApplicativeFunctor_ap_utility.

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

(*ap5*)
  Corollary pure_ap_map: ∀ (f: A → B) (g: B → C) (a: G A),
      pure g <⋆> map f a = map (g ∘ f) a.
  Proof.
    intros.
    do 2 rewrite map_to_ap.
    rewrite <- ap4.
    do 2 rewrite ap2.
    reflexivity.
  Qed.

  Corollary map_ap: ∀ (f: G (A → B)) (g: B → C) (a: G A),
      map g (f <⋆> a) = map (compose g) f <⋆> a.
  Proof.
    intros.
    do 2 rewrite map_to_ap.
    rewrite <- ap4.
    rewrite ap2.
    reflexivity.
  Qed.

  Theorem map_ap2: ∀ (g: B → C),
      compose (map g) ∘ ap G (A := A) = ap G ∘ map (compose g).
  Proof.
    intros. ext f a. unfold compose.
    rewrite map_ap. reflexivity.
  Qed.

  Corollary ap_map: ∀ {A B C} (x: G (A → B)) (y: G C) (f: C → A),
      (map (precompose f) x <⋆> y) = x <⋆> map f y.
  Proof.
    intros. do 2 rewrite map_to_ap.
    rewrite <- ap4.
    rewrite ap3.
    rewrite <- ap4.
    do 2 rewrite ap2.
    reflexivity.
  Qed.

  Corollary ap_curry: ∀ (a: G A) (b: G B) (f: A → B → C),
      map (uncurry f) (a ⊗ b) = pure f <⋆> a <⋆> b.
  Proof.
    intros. unfold ap.
    rewrite (app_mult_natural_l G).
    compose near (pure f ⊗ a ⊗ b).
    rewrite (fun_map_map).
    rewrite <- (app_assoc_inv G).
    compose near ((pure f ⊗ (a ⊗ b))).
    rewrite (fun_map_map).
    rewrite triangle_3. unfold strength.
    compose near (a ⊗ b) on right.
    rewrite (fun_map_map).
    fequal. ext [a' b']. reflexivity.
  Qed.

End ApplicativeFunctor_ap_utility.

Section ap_compose.

  Context
    (G1 G2: Type → Type)
    `{Applicative G1}
    `{Applicative G2}
    {A B: Type}.

  Theorem ap_compose1: ∀ (f: G2 (G1 (A → B))) (a: G2 (G1 A)),
      ap (G2 ∘ G1) f a =
        pure (ap G1) <⋆> f <⋆> a.
  Proof.
    intros. unfold ap at 1.
    unfold_ops @Map_compose.
    unfold_ops @Mult_compose.
    cbn. rewrite <- map_to_ap.
    compose near (f ⊗ a).
    rewrite (fun_map_map).
    unfold ap at 1.
    rewrite (app_mult_natural_l G2).
    compose near (f ⊗ a) on right.
    rewrite (fun_map_map).
    fequal. now ext [G1f G1a].
  Qed.

  Theorem ap_compose2: ∀ (f: G2 (G1 (A → B))) (a: G2 (G1 A)),
      ap (G2 ∘ G1) f a =
        map (ap G1) f <⋆> a.
  Proof.
    intros. rewrite ap_compose1.
    now rewrite map_to_ap.
  Qed.

(*
  Theorem ap_compose3:
  ap (G2 ∘ G1) (A := A) (B := B) =
  ap G2 ∘ map G2 (ap G1).
  Proof.
  intros. ext f a.
  rewrite (ap_compose1).
  now rewrite <- map_to_ap.
  Qed.

  Theorem ap_compose_new: forall `{Applicative G1} `{Applicative G2},
  forall (A B: Type) (x: G1 (G2 A))(f: A -> B),
  P (G1 ∘ G2) f <⋆> x =
  P G1 (ap G2 (P G2 f)) <⋆> x.
  Proof.
  intros. rewrite (ap_compose1 G2 G1).
  unfold_ops @Pure_compose.
  rewrite ap2.
  reflexivity.
  Qed.
 *)

End ap_compose.

From Tealeaves Require Import
  Classes.Monoid.

Import Monoid.Notations.

Section with_monoid.

  Context
    (G: Type → Type)
    (M: Type)
    `{Applicative G}
    `{Monoid M}.

  #[export] Instance Monoid_op_applicative: Monoid_op (G M) :=
    fun m1 m2 ⇒ map (F := G) (uncurry monoid_op) (m1 ⊗ m2).

  #[export] Instance Monoid_unit_applicative: Monoid_unit (G M) :=
    pure (F := G) Ƶ.

  #[export] Instance Monoid_applicative: Monoid (G M).
  Proof.
    constructor.
    - intros. cbn. unfold_ops @Monoid_op_applicative.
      rewrite (app_mult_natural_l G).
      compose near (x ⊗ y ⊗ z) on left.
      rewrite (fun_map_map).
      rewrite (app_mult_natural_r G).
      rewrite <- (app_assoc).
      compose near (x ⊗ y ⊗ z) on right.
      rewrite (fun_map_map).
      compose near (x ⊗ y ⊗ z) on right.
      rewrite (fun_map_map).
      fequal. ext [[m1 m2] m3].
      cbn. simpl_monoid.
      reflexivity.
    - intros. unfold_ops @Monoid_op_applicative.
      unfold_ops @Monoid_unit_applicative.
      rewrite ap_curry.
      rewrite <- map_to_ap.
      rewrite ap3. unfold evalAt.
      rewrite pure_ap_map.
      change x with (id x) at 2. rewrite <- (fun_map_id).
      fequal. ext m.
      unfold compose. now rewrite monoid_id_r.
    - intros. unfold_ops @Monoid_op_applicative.
      unfold_ops @Monoid_unit_applicative.
      rewrite ap_curry.
      rewrite ap2.
      rewrite <- map_to_ap.
      change x with (id x) at 2. rewrite <- (fun_map_id).
      fequal. ext m.
      unfold compose. now rewrite monoid_id_l.
  Qed.

End with_monoid.

Section with_hom.

  Context
    `{Applicative G}
    (M1 M2: Type)
    `{morphism: Monoid_Morphism M1 M2 ϕ}.

  #[export] Instance Monoid_hom_applicative:
    Monoid_Morphism (G M1) (G M2) (map (F := G) ϕ).
  Proof.
    inversion morphism.
    constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - unfold_ops @Monoid_unit_applicative.
      rewrite (app_pure_natural).
      now rewrite monmor_unit.
    - intros. unfold_ops @Monoid_op_applicative.
      compose near (a1 ⊗ a2).
      rewrite (fun_map_map).
      rewrite (app_mult_natural).
      compose near (a1 ⊗ a2) on right.
      rewrite (fun_map_map).
      fequal. ext [m1 m2].
      unfold compose. cbn. rewrite monmor_op.
      reflexivity.
  Qed.

End with_hom.

Module Notations.
  Notation "x ⊗ y" :=
    (mult (x, y)) (at level 50, left associativity): tealeaves_scope.
  Notation "Gf <⋆> Ga" :=
    (ap _ Gf Ga) (at level 50, left associativity): tealeaves_scope.
End Notations.