Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.globe_over_lem.
Require Import displayed_algebras.constant_display.
Require Import displayed_algebras.displayed_algebra.
Require Import displayed_algebras.total_algebra.
Require Import existence.hit_existence.
Require Import existence.initial_algebra.

Local Open Scope cat.

Definition poly_homot_pathsdirprod_pr1
           {P : poly_code}
           {X Y₁ Y₂ : UU}
           {f₁ f₂ : X → Y₁} {g₁ g₂ : X → Y₂}
           {p : f₁ ~ f₂} {q : g₁ ~ g₂}
           (x : poly_act P X)
  : maponpaths
      (poly_map P pr1)
      (poly_homot
         P
         (λ z,
          pathsdirprod
            (p z)
            (q z))
         x)
    =
    poly_comp _ _ _ _
    @ poly_homot P p x
    @ !(poly_comp _ _ _ _).
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply idpath.
  - exact (maponpaths_pr1_pathsdirprod _ _ @ !(pathscomp0rid _)).
  - induction x as [x | x] ; simpl.
    + etrans.
      {
        apply (maponpathscomp inl (coprodf _ _)).
      }
      unfold funcomp ; cbn.
      etrans.
      {
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        apply maponpaths.
        apply IHP₁.
      }
      etrans.
      {
        etrans.
        {
          apply maponpathscomp0.
        }
        apply maponpaths.
        apply maponpathscomp0.
      }
      do 2 apply maponpaths.
      apply maponpathsinv0.
    + etrans.
      {
        apply (maponpathscomp inr (coprodf _ _)).
      }
      unfold funcomp ; cbn.
      etrans.
      {
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        apply maponpaths.
        apply IHP₂.
      }
      etrans.
      {
        etrans.
        {
          apply maponpathscomp0.
        }
        apply maponpaths.
        apply maponpathscomp0.
      }
      do 2 apply maponpaths.
      apply maponpathsinv0.
  - simpl.
    etrans.
    {
      refine (!_).
      apply maponpaths_pathsdirprod.
    }
    refine (!_).
    etrans.
    {
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply pathsdirprod_inv.
        }
        apply pathsdirprod_concat.
      }
      apply pathsdirprod_concat.
    }
    refine (!_).
    exact (paths_pathsdirprod (IHP₁ _) (IHP₂ _)).
Qed.

Definition poly_homot_pathsdirprod_pr2
           {P : poly_code}
           {X Y₁ Y₂ : UU}
           {f₁ f₂ : X → Y₁} {g₁ g₂ : X → Y₂}
           {p : f₁ ~ f₂} {q : g₁ ~ g₂}
           (x : poly_act P X)
  : maponpaths
      (poly_map P dirprod_pr2)
      (poly_homot
         P
         (λ z,
          pathsdirprod
            (p z)
            (q z))
         x)
    =
    poly_comp _ _ _ _
    @ poly_homot P q x
    @ !(poly_comp _ _ _ _).
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply idpath.
  - exact (maponpaths_pr2_pathsdirprod _ _ @ !(pathscomp0rid _)).
  - induction x as [x | x] ; simpl.
    + etrans.
      {
        apply (maponpathscomp inl (coprodf _ _)).
      }
      unfold funcomp ; cbn.
      etrans.
      {
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        apply maponpaths.
        apply IHP₁.
      }
      etrans.
      {
        etrans.
        {
          apply maponpathscomp0.
        }
        apply maponpaths.
        apply maponpathscomp0.
      }
      do 2 apply maponpaths.
      apply maponpathsinv0.
    + etrans.
      {
        apply (maponpathscomp inr (coprodf _ _)).
      }
      unfold funcomp ; cbn.
      etrans.
      {
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        apply maponpaths.
        apply IHP₂.
      }
      etrans.
      {
        etrans.
        {
          apply maponpathscomp0.
        }
        apply maponpaths.
        apply maponpathscomp0.
      }
      do 2 apply maponpaths.
      apply maponpathsinv0.
  - simpl.
    etrans.
    {
      refine (!_).
      apply maponpaths_pathsdirprod.
    }
    refine (!_).
    etrans.
    {
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply pathsdirprod_inv.
        }
        apply pathsdirprod_concat.
      }
      apply pathsdirprod_concat.
    }
    refine (!_).
    exact (paths_pathsdirprod (IHP₁ _) (IHP₂ _)).
Qed.

Definition poly_pr1_poly_map
           {P : poly_code}
           {X Y Z : one_type}
           (f : X → Y)
           (g : X → Z)
           (x : poly_act P X)
  : poly_map P f x
    =
    poly_pr1
      P
      (poly_map
         P
         (λ z, f z ,, g z)
         x).
Proof.
  induction P as [T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply idpath.
  - apply idpath.
  - induction x as [x | x].
    + exact (maponpaths inl (IHP₁ x)).
    + exact (maponpaths inr (IHP₂ x)).
  - exact (pathsdirprod
             (IHP₁ (pr1 x))
             (IHP₂ (pr2 x))).
Defined.

Section ProductAlg.
  Context {Σ : hit_signature}
          (X Y : hit_algebra_one_types Σ).

  Local Notation "'P'" := (alg_carrier X × alg_carrier Y).

  Local Definition prod_point_constr
    : poly_act (point_constr Σ) P → P
    := λ x,
       alg_constr X (poly_map (point_constr Σ) (λ (z : P), pr1 z) x)
       ,,
       alg_constr Y (poly_map (point_constr Σ) (λ (z : P), pr2 z) x).

  Definition prod_prealg
    : hit_prealgebra_one_types Σ.
  Proof.
    use make_hit_prealgebra.
    - exact P.
    - abstract
        (apply isofhleveldirprod
         ; [apply (pr111 X) | apply (pr111 Y)]).
    - exact prod_point_constr.
  Defined.

  Local Definition prod_endpoint_pr1
        {Q R : poly_code}
        (e : endpoint (point_constr Σ) Q R)
        (x : poly_act Q P)
    : sem_endpoint_UU
        e
        (alg_constr X)
        (poly_map Q (λ (z : P), pr1 z) x)
      =
      poly_map
        R
        (λ (z : P), pr1 z)
        (sem_endpoint_UU e prod_point_constr x).
  Proof.
    refine (!(sem_endpoint_UU_natural
                e
                (λ (z : poly_act (point_constr Σ) P), _)
                x)).
    exact (idpath (alg_constr X _)).
  Defined.

  Local Definition prod_endpoint_pr2
        {Q R : poly_code}
        (e : endpoint (point_constr Σ) Q R)
        (x : poly_act Q P)
    : sem_endpoint_UU
        e
        (alg_constr Y)
        (poly_map Q (λ (z : P), pr2 z) x)
      =
      poly_map
        R
        (λ (z : P), pr2 z)
        (sem_endpoint_UU e prod_point_constr x).
  Proof.
    refine (!(sem_endpoint_UU_natural
                e
                (λ (z : poly_act (point_constr Σ) P), _)
                x)).
    exact (idpath _).
  Defined.

  Local Definition prod_path_constr
    :  ∏ (j : path_label Σ)
         (x : poly_act (path_source Σ j) P),
       sem_endpoint_UU (path_left Σ j) prod_point_constr x
       =
       sem_endpoint_UU (path_right Σ j) prod_point_constr x.
  Proof.
    exact (λ j x,
           pathsdirprod
             (!(prod_endpoint_pr1 _ _)
              @ alg_path X j (poly_map _ (λ (z : P), pr1 z) x)
              @ prod_endpoint_pr1 _ _)
             (!(prod_endpoint_pr2 _ _)
              @ alg_path Y j (poly_map _ (λ (z : P), pr2 z) x)
              @ prod_endpoint_pr2 _ _)).
  Defined.

  Definition prod_path_alg
    : hit_path_algebra_one_types Σ.
  Proof.
    use make_hit_path_algebra.
    - exact prod_prealg.
    - exact prod_path_constr.
  Defined.

  Definition prod_homot_endpoint_pr1
             {Q TR T : poly_code}
             {al ar : endpoint (point_constr Σ) Q TR}
             {sl sr : endpoint (point_constr Σ) Q T}
             (h : homot_endpoint (path_left Σ) (path_right Σ) al ar sl sr)
             (x : poly_act Q P)
             (p : sem_endpoint_UU al prod_point_constr x
                  =
                  sem_endpoint_UU ar prod_point_constr x)
    : maponpaths
        (poly_map T pr1)
        (sem_homot_endpoint_one_types
           h
           prod_prealg prod_path_constr
           x p)
      =
      !(prod_endpoint_pr1 _ _)
      @ sem_homot_endpoint_one_types
          h
          _ (alg_path X)
          (poly_map Q pr1 x)
          (prod_endpoint_pr1 _ _
           @ maponpaths (poly_map TR pr1) p
           @ !(prod_endpoint_pr1 _ _))
      @ prod_endpoint_pr1 _ _.
  Proof.
    induction h as [T e | T e₁ e₂ h IHh | T e₁ e₂ e₃ h₁ IHh₁ h₂ IHh₂
                    | T₁ T₂ e₁ e₂ e₃ h IHh
                    | R₁ R₂ T e₁ e₂ e₃ | T e | T e
                    | R₁ R₂ e₁ e₂ | R₁ R₂ e₁ e₂
                    | T₁ T₂ e₁ e₂ e₃ e₄ h₁ IHh₁ h₂ IHh₂
                    | P₁ P₂ P₃ e₁ e₂ e₃
                    | Z z T e | j e | ].
    - exact (!(pathsinv0l _)).
    - simpl.
      etrans.
      {
        apply maponpathsinv0.
      }
      etrans.
      {
        apply maponpaths.
        exact IHh.
      }
      etrans.
      {
        etrans.
        {
          apply pathscomp_inv.
        }
        etrans.
        {
          apply maponpaths.
          apply pathsinv0inv0.
        }
        apply maponpaths_2.
        apply pathscomp_inv.
      }
      exact (!(path_assoc _ _ _)).
    - simpl.
      etrans.
      {
        apply maponpathscomp0.
      }
      etrans.
      {
        apply maponpaths_2.
        exact IHh₁.
      }
      etrans.
      {
        apply maponpaths.
        exact IHh₂.
      }
      clear IHh₁ IHh₂.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (path_assoc _ _ _ @ _ @ (path_assoc _ _ _)).
      apply maponpaths_2.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
    - simpl.
      unfold prod_endpoint_pr1 ; simpl.
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          apply pathsinv0inv0.
        }
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths.
          apply pathscomp_inv.
        }
        do 2 refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply (maponpathsinv0 (sem_endpoint_UU e₃ (alg_constr X))).
        }
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply (maponpathscomp0 (sem_endpoint_UU e₃ (alg_constr X))).
        }
        etrans.
        {
          refine (!_).
          apply (maponpathscomp0 (sem_endpoint_UU e₃ (alg_constr X))).
        }
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        refine (_ @ !IHh).
        apply maponpaths_2.
        refine (!_).
        apply pathsinv0inv0.
      }
      etrans.
      {
        apply maponpaths ; apply maponpaths_2.
        apply maponpathscomp.
      }
      refine (path_assoc _ _ _ @ _).
      use path_inv_rotate_lr.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply (maponpathscomp (sem_endpoint_UU e₃ prod_point_constr) (poly_map T₂ pr1)).
      }
      apply (homotsec_natural' (sem_endpoint_UU_natural e₃ _)).
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr1 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr1.
      apply maponpaths.
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpathscomp0.
      }
      apply maponpaths.
      apply maponpathscomp.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr1 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr1.
      apply maponpaths.
      simpl.
      apply pathscomp0rid.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr1 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr1.
      apply maponpaths.
      apply maponpathsidfun.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr1 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr1.
      apply maponpaths.
      apply maponpaths_pr1_pathsdirprod.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr1 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr1.
      apply maponpaths.
      apply maponpaths_pr2_pathsdirprod.
    - simpl.
      etrans.
      {
        refine (!_).
        apply maponpaths_pathsdirprod.
      }
      refine (paths_pathsdirprod IHh₁ IHh₂ @ _).
      unfold prod_endpoint_pr1.
      rewrite !pathsinv0inv0.
      etrans.
      {
        refine (!_).
        apply pathsdirprod_concat.
      }
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply pathsdirprod_concat.
      }
      simpl.
      do 2 apply maponpaths.
      refine (!_).
      apply pathsdirprod_inv.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr1 (comp e₁ (pair e₂ e₃)) x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr1.
      simpl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        apply maponpaths_prod_path.
      }
      apply pathsdirprod_concat.
    - simpl.
      unfold prod_endpoint_pr1 ; simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply pathsinv0inv0.
        }
        apply maponpaths_for_constant_function.
      }
      apply idpath.
    - simpl.
      unfold prod_path_constr.
      etrans.
      {
        exact (maponpaths_pr1_pathsdirprod _ _).
      }
      unfold prod_endpoint_pr1.
      simpl.
      rewrite !pathsinv0inv0.
      refine (_ @ path_assoc _ _ _).
      apply maponpaths.
      rewrite pathscomp_inv.
      do 2 refine (_ @ !(path_assoc _ _ _)).
      apply maponpaths_2.
      refine (_ @ path_assoc _ _ _).
      refine (homotsec_natural (alg_path X j) (prod_endpoint_pr1 _ _) @ _).
      unfold prod_endpoint_pr1.
      rewrite pathsinv0inv0.
      do 2 apply maponpaths.
      apply maponpathsinv0.
    - simpl.
      refine (!_).
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        refine (path_assoc _ _ _ @ _) ; apply maponpaths_2.
        apply pathsinv0l.
      }
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0l.
      }
      apply pathscomp0rid.
  Qed.

  Definition prod_homot_endpoint_pr2
             {Q TR T : poly_code}
             {al ar : endpoint (point_constr Σ) Q TR}
             {sl sr : endpoint (point_constr Σ) Q T}
             (h : homot_endpoint (path_left Σ) (path_right Σ) al ar sl sr)
             (x : poly_act Q P)
             (p : sem_endpoint_UU al prod_point_constr x
                  =
                  sem_endpoint_UU ar prod_point_constr x)
    : maponpaths
        (poly_map T dirprod_pr2)
        (sem_homot_endpoint_one_types
           h
           prod_prealg prod_path_constr
           x p)
      =
      !(prod_endpoint_pr2 _ _)
      @ sem_homot_endpoint_one_types
          h
          _ (alg_path Y)
          (poly_map Q dirprod_pr2 x)
          (prod_endpoint_pr2 _ _
           @ maponpaths (poly_map TR dirprod_pr2) p
           @ !(prod_endpoint_pr2 _ _))
      @ prod_endpoint_pr2 _ _.
  Proof.
    induction h as [T e | T e₁ e₂ h IHh | T e₁ e₂ e₃ h₁ IHh₁ h₂ IHh₂
                    | T₁ T₂ e₁ e₂ e₃ h IHh
                    | R₁ R₂ T e₁ e₂ e₃ | T e | T e
                    | R₁ R₂ e₁ e₂ | R₁ R₂ e₁ e₂
                    | T₁ T₂ e₁ e₂ e₃ e₄ h₁ IHh₁ h₂ IHh₂
                    | P₁ P₂ P₃ e₁ e₂ e₃
                    | Z z T e | j e | ].
    - exact (!(pathsinv0l _)).
    - simpl.
      etrans.
      {
        apply maponpathsinv0.
      }
      etrans.
      {
        apply maponpaths.
        exact IHh.
      }
      etrans.
      {
        etrans.
        {
          apply pathscomp_inv.
        }
        etrans.
        {
          apply maponpaths.
          apply pathsinv0inv0.
        }
        apply maponpaths_2.
        apply pathscomp_inv.
      }
      exact (!(path_assoc _ _ _)).
    - simpl.
      etrans.
      {
        apply maponpathscomp0.
      }
      etrans.
      {
        apply maponpaths_2.
        exact IHh₁.
      }
      etrans.
      {
        apply maponpaths.
        exact IHh₂.
      }
      clear IHh₁ IHh₂.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (path_assoc _ _ _ @ _ @ (path_assoc _ _ _)).
      apply maponpaths_2.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
    - simpl.
      unfold prod_endpoint_pr1 ; simpl.
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          apply pathsinv0inv0.
        }
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths.
          apply pathscomp_inv.
        }
        do 2 refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply (maponpathsinv0 (sem_endpoint_UU e₃ (alg_constr Y))).
        }
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply (maponpathscomp0 (sem_endpoint_UU e₃ (alg_constr Y))).
        }
        etrans.
        {
          refine (!_).
          apply (maponpathscomp0 (sem_endpoint_UU e₃ (alg_constr Y))).
        }
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        refine (_ @ !IHh).
        apply maponpaths_2.
        refine (!_).
        apply pathsinv0inv0.
      }
      etrans.
      {
        apply maponpaths ; apply maponpaths_2.
        apply maponpathscomp.
      }
      refine (path_assoc _ _ _ @ _).
      use path_inv_rotate_lr.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply (maponpathscomp (sem_endpoint_UU e₃ prod_point_constr) (poly_map T₂ _)).
      }
      apply (homotsec_natural' (sem_endpoint_UU_natural e₃ _)).
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr2 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr2.
      apply maponpaths.
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpathscomp0.
      }
      apply maponpaths.
      apply maponpathscomp.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr2 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr2.
      apply maponpaths.
      simpl.
      apply pathscomp0rid.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr2 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr2.
      apply maponpaths.
      apply maponpathsidfun.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr2 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr2.
      apply maponpaths.
      apply maponpaths_pr1_pathsdirprod.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr2 _ x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr2.
      apply maponpaths.
      apply maponpaths_pr2_pathsdirprod.
    - simpl.
      etrans.
      {
        refine (!_).
        apply maponpaths_pathsdirprod.
      }
      refine (paths_pathsdirprod IHh₁ IHh₂ @ _).
      unfold prod_endpoint_pr2.
      rewrite !pathsinv0inv0.
      etrans.
      {
        refine (!_).
        apply pathsdirprod_concat.
      }
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply pathsdirprod_concat.
      }
      simpl.
      do 2 apply maponpaths.
      refine (!_).
      apply pathsdirprod_inv.
    - simpl.
      refine (!(pathsinv0l (prod_endpoint_pr2 (comp e₁ (pair e₂ e₃)) x)) @ _).
      apply maponpaths.
      unfold prod_endpoint_pr2.
      simpl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        apply maponpaths_prod_path.
      }
      apply pathsdirprod_concat.
    - simpl.
      unfold prod_endpoint_pr2 ; simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply pathsinv0inv0.
        }
        apply maponpaths_for_constant_function.
      }
      apply idpath.
    - simpl.
      unfold prod_path_constr.
      etrans.
      {
        exact (maponpaths_pr2_pathsdirprod _ _).
      }
      unfold prod_endpoint_pr2.
      simpl.
      rewrite !pathsinv0inv0.
      refine (_ @ path_assoc _ _ _).
      apply maponpaths.
      rewrite pathscomp_inv.
      do 2 refine (_ @ !(path_assoc _ _ _)).
      apply maponpaths_2.
      refine (_ @ path_assoc _ _ _).
      refine (homotsec_natural (alg_path Y j) (prod_endpoint_pr2 _ _) @ _).
      unfold prod_endpoint_pr2.
      rewrite pathsinv0inv0.
      do 2 apply maponpaths.
      apply maponpathsinv0.
    - simpl.
      refine (!_).
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        refine (path_assoc _ _ _ @ _) ; apply maponpaths_2.
        apply pathsinv0l.
      }
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0l.
      }
      apply pathscomp0rid.
  Qed.

  Definition prod_is_alg
    : is_hit_algebra_one_types Σ prod_path_alg.
  Proof.
    intros j x p ; simpl in j, x, p ; cbn in p.
    cbn.
    pose (alg_homot
            X j
            (poly_map (homot_point_arg Σ j) (λ (z : P), pr1 z) x)
            (prod_endpoint_pr1 _ _
             @ maponpaths (poly_map _ (λ (z : P), pr1 z)) p
             @ !(prod_endpoint_pr1 _ _))) as q.
    pose (alg_homot
            Y j
            (poly_map (homot_point_arg Σ j) (λ (z : P), pr2 z) x)
            (prod_endpoint_pr2 _ _
             @ maponpaths (poly_map _ (λ (z : P), pr2 z)) p
             @ !(prod_endpoint_pr2 _ _))) as r.
    refine (pathsdirprod_eta _ @ _ @ !(pathsdirprod_eta _)).
    use paths_pathsdirprod.
    - refine (prod_homot_endpoint_pr1 (homot_left_path Σ j) x p @ _).
      refine (_ @ !(prod_homot_endpoint_pr1 (homot_right_path Σ j) x p)).
      apply maponpaths.
      apply maponpaths_2.
      exact q.
    - refine (prod_homot_endpoint_pr2 (homot_left_path Σ j) x p @ _).
      refine (_ @ !(prod_homot_endpoint_pr2 (homot_right_path Σ j) x p)).
      apply maponpaths.
      apply maponpaths_2.
      exact r.
  Qed.

  Definition prod_alg
    : hit_algebra_one_types Σ.
  Proof.
    use make_algebra.
    - exact prod_path_alg.
    - exact prod_is_alg.
  Defined.

  Definition prod_alg_pr1
    : prod_alg --> X.
  Proof.
    use make_algebra_map.
    use make_hit_path_alg_map.
    - use make_hit_prealgebra_mor.
      + exact (λ z, pr1 z).
      + intro ; apply idpath.
    - abstract
        (simpl ;
         intros i x ;
         etrans ;
           [ apply maponpaths_2 ;
             unfold prod_path_constr ;
             exact (maponpaths_pr1_pathsdirprod _ _)
           | unfold prod_endpoint_pr1 ;
             cbn ;
             rewrite pathsinv0inv0 ;
             rewrite <- path_assoc ;
             apply maponpaths ;
             rewrite <- path_assoc ;
             rewrite pathsinv0l ;
             apply pathscomp0rid]).
  Defined.

  Definition prod_alg_pr2
    : prod_alg --> Y.
  Proof.
    use make_algebra_map.
    use make_hit_path_alg_map.
    - use make_hit_prealgebra_mor.
      + exact (λ z, pr2 z).
      + intro ; apply idpath.
    - abstract
        (simpl ;
         intros i x ;
         etrans ;
           [ apply maponpaths_2 ;
             unfold prod_path_constr ;
             exact (maponpaths_pr2_pathsdirprod _ _)
           | unfold prod_endpoint_pr2 ;
             cbn ;
             rewrite pathsinv0inv0 ;
             rewrite <- path_assoc ;
             apply maponpaths ;
             rewrite <- path_assoc ;
             rewrite pathsinv0l ;
             apply pathscomp0rid]).
  Defined.

  Section ProdUMPMap.
    Variable (Z : hit_algebra_one_types Σ)
             (pr1Z : Z --> X)
             (pr2Z : Z --> Y).

    Definition prod_alg_ump_1_constr
               (x : poly_act (point_constr Σ) (prealg_carrier (pr11 Z)))
      : (pr111 pr1Z) (prealg_constr x)
        ,,
        (pr111 pr2Z) (prealg_constr x)
        =
        prod_point_constr
          (poly_map
             (point_constr Σ)
             (λ z : prealg_carrier (pr11 Z), (pr111 pr1Z) z,, (pr111 pr2Z) z)
             x).
    Proof.
      use pathsdirprod.
      - refine (pr1 (pr211 pr1Z) x @ maponpaths (alg_constr X) _) ; cbn.
        exact (!(poly_comp
                   (point_constr Σ)
                   (λ z : prealg_carrier (pr11 Z), (pr111 pr1Z) z,, (pr111 pr2Z) z)
                   (λ z, pr1 z)
                   x)).
      - refine (pr1 (pr211 pr2Z) x @ maponpaths (alg_constr Y) _) ; cbn.
        exact (!(poly_comp
                   (point_constr Σ)
                   (λ z : prealg_carrier (pr11 Z), (pr111 pr1Z) z,, (pr111 pr2Z) z)
                   (λ (z : P), pr2 z)
                   x)).
    Defined.

    Definition maponpaths_pr1_sem_endpoint_UU_natural
               {Q R : poly_code}
               (e : endpoint (point_constr Σ) Q R)
               (x : poly_act Q (path_alg_carrier (pr1 Z)))
      : !(poly_comp _ _ _ _)
        @ maponpaths
            (poly_map R pr1)
            (sem_endpoint_UU_natural e prod_alg_ump_1_constr x)
        =
        sem_endpoint_UU_natural e (pr121 (pr1 pr1Z)) x
        @ maponpaths
            (sem_endpoint_UU e (pr211 X))
            (!(poly_comp
                 Q
                 (λ z : prealg_carrier (pr11 Z), (pr111 pr1Z) z,, (pr111 pr2Z) z)
                 (λ (z : P), pr1 z)
                 x))
        @ prod_endpoint_pr1 _ _.
    Proof.
      induction e as [Q | Q₁ Q₂ Q₃ e₁ IHe₁ e₂ IHe₂
                      | Q R | Q R | Q R | Q R
                      | Q₁ Q₂ Q₃ e₁ IHe₁ e₂ IHe₂
                      | Q T t | C₁ C₂ g | ].
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        apply maponpathsidfun.
      - unfold prod_endpoint_pr1 ; simpl.
        refine (!_).
        etrans.
        {
          refine (!(path_assoc _ _ _) @ _).
          apply maponpaths.
          etrans.
          {
            do 2 apply maponpaths.
            apply pathscomp_inv.
          }
          do 2 refine (path_assoc _ _ _ @ _).
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths.
              refine (!_).
              apply maponpathscomp.
            }
            refine (!_).
            apply maponpathscomp0.
          }
          etrans.
          {
            apply maponpaths.
            refine (!_).
            apply maponpathsinv0.
          }
          etrans.
          {
            refine (!_).
            apply maponpathscomp0.
          }
          apply maponpaths.
          refine (!(path_assoc _ _ _) @ _).
          refine (!_).
          apply IHe₁.
        }
        clear IHe₁.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply (maponpathscomp0 (poly_map Q₃ pr1)).
        }
        refine (path_assoc _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply IHe₂.
        }
        clear IHe₂.
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply maponpathscomp0.
        }
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply (maponpathscomp (poly_map Q₂ pr1) (sem_endpoint_UU e₂ (alg_constr X))).
        }
        etrans.
        {
          apply (homotsec_natural' (prod_endpoint_pr1 e₂)).
        }
        apply maponpaths.
        refine (!_).
        apply maponpathscomp.
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        apply (maponpathsinv0 inl).
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        apply (maponpathsinv0 inr).
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        etrans.
        {
          exact (maponpathsinv0 pr1 (pathsdirprod _ _)).
        }
        apply maponpaths.
        apply maponpaths_pr1_pathsdirprod.
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        etrans.
        {
          exact (maponpathsinv0 dirprod_pr2 (pathsdirprod _ _)).
        }
        apply maponpaths.
        apply maponpaths_pr2_pathsdirprod.
      - unfold prod_endpoint_pr1.
        simpl.
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            apply pathsdirprod_inv.
          }
          etrans.
          {
            apply maponpaths.
            refine (!_).
            apply maponpaths_pathsdirprod.
          }
          apply pathsdirprod_concat.
        }
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths_2.
              apply maponpaths_prod_path.
            }
            etrans.
            {
              apply maponpaths.
              apply pathsdirprod_inv.
            }
            apply pathsdirprod_concat.
          }
          apply pathsdirprod_concat.
        }
        refine (!_).
        exact (paths_pathsdirprod (IHe₁ x) (IHe₂ x)).
      - simpl ; cbn.
        refine (!_).
        refine (pathscomp0rid _ @ _).
        apply maponpaths_for_constant_function.
      - apply idpath.
      - simpl ; cbn.
        etrans.
        {
          apply maponpaths_pr1_pathsdirprod.
        }
        refine (!_).
        apply maponpaths.
        apply pathscomp0rid.
    Qed.

    Definition maponpaths_pr2_sem_endpoint_UU_natural
               {Q R : poly_code}
               (e : endpoint (point_constr Σ) Q R)
               (x : poly_act Q (path_alg_carrier (pr1 Z)))
      : !(poly_comp _ _ _ _)
        @ maponpaths
            (poly_map R dirprod_pr2)
            (sem_endpoint_UU_natural e prod_alg_ump_1_constr x)
        =
        sem_endpoint_UU_natural e (pr121 (pr1 pr2Z)) x
        @ maponpaths
            (sem_endpoint_UU e (pr211 Y))
            (!(poly_comp
                 Q
                 (λ z : prealg_carrier (pr11 Z), (pr111 pr1Z) z,, (pr111 pr2Z) z)
                 (λ (z : P), pr2 z)
                 x))
        @ prod_endpoint_pr2 _ _.
    Proof.
      induction e as [Q | Q₁ Q₂ Q₃ e₁ IHe₁ e₂ IHe₂
                      | Q R | Q R | Q R | Q R
                      | Q₁ Q₂ Q₃ e₁ IHe₁ e₂ IHe₂
                      | Q T t | C₁ C₂ g | ].
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        apply maponpathsidfun.
      - unfold prod_endpoint_pr2 ; simpl.
        refine (!_).
        etrans.
        {
          refine (!(path_assoc _ _ _) @ _).
          apply maponpaths.
          etrans.
          {
            do 2 apply maponpaths.
            apply pathscomp_inv.
          }
          do 2 refine (path_assoc _ _ _ @ _).
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths.
              refine (!_).
              apply maponpathscomp.
            }
            refine (!_).
            apply maponpathscomp0.
          }
          etrans.
          {
            apply maponpaths.
            refine (!_).
            apply maponpathsinv0.
          }
          etrans.
          {
            refine (!_).
            apply maponpathscomp0.
          }
          apply maponpaths.
          refine (!(path_assoc _ _ _) @ _).
          refine (!_).
          apply IHe₁.
        }
        clear IHe₁.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply (maponpathscomp0 (poly_map Q₃ dirprod_pr2)).
        }
        refine (path_assoc _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply IHe₂.
        }
        clear IHe₂.
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply maponpathscomp0.
        }
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply (maponpathscomp
                   (poly_map Q₂ dirprod_pr2)
                   (sem_endpoint_UU e₂ (alg_constr Y))).
        }
        etrans.
        {
          apply (homotsec_natural' (prod_endpoint_pr2 e₂)).
        }
        apply maponpaths.
        refine (!_).
        apply maponpathscomp.
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        apply (maponpathsinv0 inl).
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        apply (maponpathsinv0 inr).
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        etrans.
        {
          exact (maponpathsinv0 pr1 (pathsdirprod _ _)).
        }
        apply maponpaths.
        apply maponpaths_pr1_pathsdirprod.
      - refine (pathscomp0rid _ @ _ @ !(pathscomp0rid _)) ; simpl.
        refine (!_).
        etrans.
        {
          exact (maponpathsinv0 dirprod_pr2 (pathsdirprod _ _)).
        }
        apply maponpaths.
        apply maponpaths_pr2_pathsdirprod.
      - unfold prod_endpoint_pr2.
        simpl.
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            apply pathsdirprod_inv.
          }
          etrans.
          {
            apply maponpaths.
            refine (!_).
            apply maponpaths_pathsdirprod.
          }
          apply pathsdirprod_concat.
        }
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths_2.
              apply maponpaths_prod_path.
            }
            etrans.
            {
              apply maponpaths.
              apply pathsdirprod_inv.
            }
            apply pathsdirprod_concat.
          }
          apply pathsdirprod_concat.
        }
        refine (!_).
        exact (paths_pathsdirprod (IHe₁ x) (IHe₂ x)).
      - simpl ; cbn.
        refine (!_).
        refine (pathscomp0rid _ @ _).
        apply maponpaths_for_constant_function.
      - apply idpath.
      - simpl ; cbn.
        etrans.
        {
          apply maponpaths_pr2_pathsdirprod.
        }
        refine (!_).
        apply maponpaths.
        apply pathscomp0rid.
    Qed.

    Definition prod_alg_ump_1_path
               (i : path_label Σ)
               (x : poly_act (path_source Σ i) (path_alg_carrier (pr1 Z)))
      : maponpaths
          (λ z, (pr111 pr1Z) z,, (pr111 pr2Z) z)
          ((pr21 Z) i x)
        @ sem_endpoint_UU_natural (path_right Σ i) prod_alg_ump_1_constr x
        =
        sem_endpoint_UU_natural (path_left Σ i) prod_alg_ump_1_constr x
        @ prod_path_constr
            i
            (poly_map
               (path_source Σ i)
               (λ z, (pr111 pr1Z) z,, (pr111 pr2Z) z) x).
    Proof.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths_prod_path.
      }
      etrans.
      {
        apply maponpaths.
        apply pathsdirprod_eta.
      }
      etrans.
      {
        exact (pathsdirprod_concat _ _ _ _).
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply pathsdirprod_eta.
      }
      etrans.
      {
        exact (pathsdirprod_concat _ _ _ _).
      }
      use paths_pathsdirprod.
      - simpl.
        unfold prod_endpoint_pr1.
        rewrite pathsinv0inv0.
        pose (eqtohomot (pr21 pr1Z i) x) as m.
        cbn in m.
        unfold homotcomp, homotfun, funhomotsec in m.
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            exact (maponpaths_pr1_sem_endpoint_UU_natural (path_right Σ i) x).
          }
          refine (path_assoc _ _ _ @ _).
          apply maponpaths_2.
          exact m.
        }
        rewrite <- !path_assoc.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          exact (maponpaths_pr1_sem_endpoint_UU_natural (path_left Σ i) x).
        }
        rewrite <- !path_assoc.
        apply maponpaths.
        rewrite !path_assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          rewrite <- path_assoc.
          etrans.
          {
            apply maponpaths.
            apply pathsinv0l.
          }
          apply pathscomp0rid.
        }
        apply (homotsec_natural' (alg_path X i)).
      - simpl.
        unfold prod_endpoint_pr2.
        rewrite pathsinv0inv0.
        pose (eqtohomot (pr21 pr2Z i) x) as m.
        cbn in m.
        unfold homotcomp, homotfun, funhomotsec in m.
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            exact (maponpaths_pr2_sem_endpoint_UU_natural (path_right Σ i) x).
          }
          refine (path_assoc _ _ _ @ _).
          apply maponpaths_2.
          exact m.
        }
        rewrite <- !path_assoc.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          exact (maponpaths_pr2_sem_endpoint_UU_natural (path_left Σ i) x).
        }
        rewrite <- !path_assoc.
        apply maponpaths.
        rewrite !path_assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          rewrite <- path_assoc.
          etrans.
          {
            apply maponpaths.
            apply pathsinv0l.
          }
          apply pathscomp0rid.
        }
        apply (homotsec_natural' (alg_path Y i)).
    Qed.

    Definition prod_alg_ump_1
      : Z --> prod_alg.
    Proof.
      use make_algebra_map.
      use make_hit_path_alg_map.
      - use make_hit_prealgebra_mor.
        + exact (λ z, pr111 pr1Z z ,, pr111 pr2Z z).
        + exact prod_alg_ump_1_constr.
      - exact prod_alg_ump_1_path.
    Defined.

    Definition prod_alg_ump_1_pr1
      : prod_alg_ump_1 · prod_alg_pr1 ==> pr1Z.
    Proof.
      simple refine (((_ ,, _) ,, λ _, tt) ,, tt).
      - exact (λ _, idpath _).
      - abstract
          (use funextsec ;
           intro z ; cbn ;
           unfold homotcomp, funhomotsec, homotfun ;
           cbn ;
           rewrite !pathscomp0rid ;
           refine (!_) ;
           refine (maponpaths
                     (λ z, (z @ _) @ _)
                     (maponpaths_pr1_pathsdirprod _ _)
                     @ _) ;
           rewrite <- !path_assoc ;
           etrans ;
           [ apply maponpaths ;
             rewrite path_assoc ;
             apply maponpaths_2 ;
             etrans ;
             [ refine (!_) ;
               apply (maponpathscomp0 (alg_constr X))
             | apply maponpaths ;
               apply pathsinv0l ]
           | simpl ;
             etrans ;
             [ do 2 apply maponpaths ;
               apply (eqtohomot (psfunctor_id2 (⟦ point_constr Σ ⟧) (pr111 pr1Z)))
             | apply pathscomp0rid ]]).
    Defined.

    Definition prod_alg_ump_1_pr2
      : prod_alg_ump_1 · prod_alg_pr2 ==> pr2Z.
    Proof.
      simple refine (((_ ,, _) ,, λ _, tt) ,, tt).
      - exact (λ _, idpath _).
      - abstract
          (use funextsec ;
           intro z ; cbn ;
           unfold homotcomp, funhomotsec, homotfun ;
           cbn ;
           rewrite !pathscomp0rid ;
           refine (!_) ;
           refine (maponpaths
                     (λ z, (z @ _) @ _)
                     (maponpaths_pr2_pathsdirprod _ _)
                     @ _) ;
           rewrite <- !path_assoc ;
           etrans ;
           [ apply maponpaths ;
             rewrite path_assoc ;
             apply maponpaths_2 ;
             etrans ;
             [ refine (!_) ;
               apply (maponpathscomp0 (alg_constr Y))
             | apply maponpaths ;
               apply pathsinv0l ]
           | simpl ;
             etrans ;
             [ do 2 apply maponpaths ;
               apply (eqtohomot (psfunctor_id2 (⟦ point_constr Σ ⟧) (pr111 pr2Z)))
             | apply pathscomp0rid ]]).
    Defined.
  End ProdUMPMap.

  Section ProdUMPCell.
    Context {Z : hit_algebra_one_types Σ}
            {pr1Z : Z --> X}
            {pr2Z : Z --> Y}
            (φ ψ : Z --> prod_alg)
            (φpr1 : φ · prod_alg_pr1 ==> pr1Z)
            (φpr2 : φ · prod_alg_pr2 ==> pr2Z)
            (ψpr1 : ψ · prod_alg_pr1 ==> pr1Z)
            (ψpr2 : ψ · prod_alg_pr2 ==> pr2Z).

    Local Definition prod_alg_ump_2_comp
      : alg_map_carrier φ ~ alg_map_carrier ψ.
    Proof.
      intro x.
      use pathsdirprod.
      - exact (pr111 φpr1 x @ !(pr111 ψpr1 x)).
      - exact (pr111 φpr2 x @ !(pr111 ψpr2 x)).
    Defined.

    Local Definition prod_alg_ump_2_is_alg_2cell
      : is_algebra_2cell prod_alg_ump_2_comp.
    Proof.
      intro x.
      cbn ; unfold  prod_alg_ump_2_comp, alg_map_commute.
      refine (_ @ !(pathsdirprod_eta _)).
      etrans.
      {
        apply maponpaths.
        apply pathsdirprod_eta.
      }
      etrans.
      {
        apply pathsdirprod_concat.
      }
      use paths_pathsdirprod.
      - pose (eqtohomot (pr211 φpr1) x) as p.
        cbn in p.
        unfold homotcomp, homotfun, funhomotsec in p.
        cbn in p.
        rewrite !pathscomp0rid in p.
        pose (maponpaths (λ z, !z) (eqtohomot (pr211 ψpr1) x)) as q.
        cbn in q.
        unfold homotcomp, homotfun, funhomotsec in q.
        cbn in q.
        rewrite !pathscomp0rid in q.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              etrans.
              {
                exact (!(pathscomp0rid _)).
              }
              apply maponpaths.
              exact (!(pathsinv0r (alg_map_commute pr1Z x))).
            }
            refine (path_assoc _ _ _ @ _).
            apply maponpaths_2.
            exact p.
          }
          refine (!(path_assoc _ _ _) @ _).
          apply maponpaths.
          etrans.
          {
            exact (!(pathscomp_inv _ _)).
          }
          etrans.
          {
            exact q.
          }
          etrans.
          {
            apply pathscomp_inv.
          }
          apply maponpaths.
          apply pathscomp_inv.
        }
        do 3 refine (!(path_assoc _ _ _) @ _).
        refine (!_).
        etrans.
        {
          exact (maponpathscomp0
                   pr1
                   (alg_map_commute φ x)
                   (maponpaths
                      prod_point_constr
                      (poly_homot _ _ _))).
        }
        apply maponpaths.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          refine (!(path_assoc _ _ _) @ _) ; apply maponpaths.
          refine (!(path_assoc _ _ _) @ _).
          etrans.
          {
            apply maponpaths.
            apply pathsinv0l.
          }
          apply pathscomp0rid.
        }
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                refine (!_).
                apply maponpathsinv0.
              }
              etrans.
              {
                apply maponpaths_2.
                refine (!_).
                apply maponpathsinv0.
              }
              refine (!_).
              apply maponpathscomp0.
            }
            refine (!_).
            apply maponpathscomp0.
          }
          refine (!_).
          apply (maponpathscomp0 (alg_constr X)).
        }
        refine (!_).
        etrans.
        {
          apply maponpathscomp.
        }
        unfold funcomp ; cbn.
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        apply maponpaths.
        etrans.
        {
          apply poly_homot_pathsdirprod_pr1.
        }
        apply maponpaths.
        refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        etrans.
        {
          pose (eqtohomot
                  (psfunctor_vcomp
                     (⟦ point_constr Σ ⟧)
                     (pr111 φpr1)
                     (invhomot (pr111 ψpr1)))
                  x)
            as r.
          cbn in r ; unfold homotcomp, invhomot in r.
          exact r.
        }
        apply maponpaths.
        apply poly_homot_inv.
      - pose (eqtohomot (pr211 φpr2) x) as p.
        cbn in p.
        unfold homotcomp, homotfun, funhomotsec in p.
        cbn in p.
        rewrite !pathscomp0rid in p.
        pose (maponpaths (λ z, !z) (eqtohomot (pr211 ψpr2) x)) as q.
        cbn in q.
        unfold homotcomp, homotfun, funhomotsec in q.
        cbn in q.
        rewrite !pathscomp0rid in q.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              etrans.
              {
                exact (!(pathscomp0rid _)).
              }
              apply maponpaths.
              exact (!(pathsinv0r (alg_map_commute pr2Z x))).
            }
            refine (path_assoc _ _ _ @ _).
            apply maponpaths_2.
            exact p.
          }
          refine (!(path_assoc _ _ _) @ _).
          apply maponpaths.
          etrans.
          {
            exact (!(pathscomp_inv _ _)).
          }
          etrans.
          {
            exact q.
          }
          etrans.
          {
            apply pathscomp_inv.
          }
          apply maponpaths.
          apply pathscomp_inv.
        }
        do 3 refine (!(path_assoc _ _ _) @ _).
        refine (!_).
        etrans.
        {
          exact (maponpathscomp0
                   dirprod_pr2
                   (alg_map_commute φ x)
                   (maponpaths
                      prod_point_constr
                      (poly_homot _ _ _))).
        }
        apply maponpaths.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          refine (!(path_assoc _ _ _) @ _) ; apply maponpaths.
          refine (!(path_assoc _ _ _) @ _).
          etrans.
          {
            apply maponpaths.
            apply pathsinv0l.
          }
          apply pathscomp0rid.
        }
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                refine (!_).
                apply maponpathsinv0.
              }
              etrans.
              {
                apply maponpaths_2.
                refine (!_).
                apply maponpathsinv0.
              }
              refine (!_).
              apply maponpathscomp0.
            }
            refine (!_).
            apply maponpathscomp0.
          }
          refine (!_).
          apply (maponpathscomp0 (alg_constr Y)).
        }
        refine (!_).
        etrans.
        {
          apply maponpathscomp.
        }
        unfold funcomp ; cbn.
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        apply maponpaths.
        etrans.
        {
          apply poly_homot_pathsdirprod_pr2.
        }
        apply maponpaths.
        refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        etrans.
        {
          pose (eqtohomot
                  (psfunctor_vcomp
                     (⟦ point_constr Σ ⟧)
                     (pr111 φpr2)
                     (invhomot (pr111 ψpr2)))
                  x)
            as r.
          cbn in r ; unfold homotcomp, invhomot in r.
          exact r.
        }
        apply maponpaths.
        apply poly_homot_inv.
    Qed.

    Definition prod_alg_ump_2
      : φ ==> ψ.
    Proof.
      use make_algebra_2cell.
      - exact prod_alg_ump_2_comp.
      - exact prod_alg_ump_2_is_alg_2cell.
    Defined.

    Definition prod_alg_ump_2_pr1
      : (prod_alg_ump_2 ▹ prod_alg_pr1) • ψpr1 = φpr1.
    Proof.
      use subtypePath.
      { intro ; apply isapropunit. }
      use subtypePath.
      { intro ; use impred ; intro ; apply isapropunit. }
      use subtypePath.
      { intro ; apply one_types. }
      simpl ; cbn ; unfold homotcomp, homotfun.
      use funextsec.
      intro x ; cbn.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths_pr1_pathsdirprod.
      }
      rewrite <- path_assoc.
      rewrite pathsinv0l.
      apply pathscomp0rid.
    Qed.

    Definition prod_alg_ump_2_pr2
      : (prod_alg_ump_2 ▹ prod_alg_pr2) • ψpr2 = φpr2.
    Proof.
      use subtypePath.
      { intro ; apply isapropunit. }
      use subtypePath.
      { intro ; use impred ; intro ; apply isapropunit. }
      use subtypePath.
      { intro ; apply one_types. }
      simpl ; cbn ; unfold homotcomp, homotfun.
      use funextsec.
      intro x ; cbn.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths_pr2_pathsdirprod.
      }
      rewrite <- path_assoc.
      rewrite pathsinv0l.
      apply pathscomp0rid.
    Qed.
  End ProdUMPCell.

  Section ProdUMPEq.
    Context {Z : hit_algebra_one_types Σ}
            {pr1Z : Z --> X}
            {pr2Z : Z --> Y}
            {φ ψ : Z --> prod_alg}
            {φpr1 : φ · prod_alg_pr1 ==> pr1Z}
            {φpr2 : φ · prod_alg_pr2 ==> pr2Z}
            {ψpr1 : ψ · prod_alg_pr1 ==> pr1Z}
            {ψpr2 : ψ · prod_alg_pr2 ==> pr2Z}
            (τ θ : φ ==> ψ)
            (τpr1 : (τ ▹ prod_alg_pr1) • ψpr1 = φpr1)
            (τpr2 : (τ ▹ prod_alg_pr2) • ψpr2 = φpr2)
            (θpr1 : (θ ▹ prod_alg_pr1) • ψpr1 = φpr1)
            (θpr2 : (θ ▹ prod_alg_pr2) • ψpr2 = φpr2).

    Definition prod_ump_eq
      : τ = θ.
    Proof.
      use subtypePath.
      { intro ; apply isapropunit. }
      use subtypePath.
      { intro ; use impred ; intro ; apply isapropunit. }
      use subtypePath.
      { intro ; apply one_types. }
      simpl ; cbn ; unfold homotcomp, homotfun.
      use funextsec.
      intro x ; cbn.
      refine (pathsdirprod_eta _ @ _ @ !(pathsdirprod_eta _)).
      apply paths_pathsdirprod.
      - refine (!(maponpaths _ (pathsinv0r _) @ pathscomp0rid _) @ path_assoc _ _ _
                @ maponpaths
                    (λ z, z @ !(pr111 ψpr1 x))
                    (eqtohomot (maponpaths (λ z, pr111 z) τpr1) x)
                @ maponpaths
                    (λ z, z @ !(pr111 ψpr1 x))
                    (!(eqtohomot (maponpaths (λ z, pr111 z) θpr1) x))
                @ _).
        cbn ; unfold homotcomp, homotfun.
        exact (!(path_assoc _ _ _) @ maponpaths _ (pathsinv0r _) @ pathscomp0rid _).
      - refine (!(maponpaths _ (pathsinv0r _) @ pathscomp0rid _) @ path_assoc _ _ _
                @ maponpaths
                    (λ z, z @ !(pr111 ψpr2 x))
                    (eqtohomot (maponpaths (λ z, pr111 z) τpr2) x)
                @ maponpaths
                    (λ z, z @ !(pr111 ψpr2 x))
                    (!(eqtohomot (maponpaths (λ z, pr111 z) θpr2) x))
                @ _).
        cbn ; unfold homotcomp, homotfun.
        exact (!(path_assoc _ _ _) @ maponpaths _ (pathsinv0r _) @ pathscomp0rid _).
    Qed.
  End ProdUMPEq.
End ProductAlg.


(** * Some useful tactics *)

(** Here are the tactic definitions from HW1. *)

Ltac elimer e := try exact e; let H := fresh "H" in (generalize e; intro H).

Ltac true_i := elimer I.

Ltac false_e Hfalse := destruct Hfalse.

Ltac imp_i := intro.
Ltac imp_e Himp Hant := elimer (Himp Hant).

Ltac and_i := split.
Ltac and_e1 Hand := elimer (proj1 Hand).
Ltac and_e2 Hand := elimer (proj2 Hand).

Ltac or_i1 := left.
Ltac or_i2 := right.
Ltac or_e Hor := destruct Hor.

Ltac not_i := intro.
Ltac not_e Hno Hyes := destruct (Hno Hyes).

Ltac forall_i := intro.
Ltac forall_e Hall x := elimer (Hall x).

Ltac exists_i x := exists x.
Ltac exists_e Hex := destruct Hex.

(** Plus the predefined tactics [assumption], [assert], [reflexivity], and
  [rewrite] *)

(** * Some propositional logic theorems *)

Theorem True_and_True : True /\ True.
  and_i.
  true_i.
  true_i.
Qed.

Section propositional.
  Variables A B C : Prop.

  Theorem p1 : A -> A.
    imp_i.
    assumption.
  Qed.

  Theorem p2 : (A -> B) -> A -> B.
    imp_i.
    imp_i.
    imp_e H H0.
  Qed.

  Theorem p3 : (A -> B) -> (B -> C) -> (A -> C).
    imp_i.
    imp_i.
    imp_i.
    imp_e H H1.
    imp_e H0 H2.
  Qed.

  Theorem p4 : A \/ A -> A.
    imp_i.
    or_e H.
    assumption.
    assumption.
  Qed.

  Theorem p5 : (A -> C) -> (B -> C) -> A \/ B -> C.
    imp_i.
    imp_i.
    imp_i.
    or_e H1.
    imp_e H H1.
    imp_e H0 H1.
  Qed.

  Theorem p6 : ~False.
    not_i.
    assumption.
  Qed.

  Theorem p7 : ~~True.
    not_i.
    assert True.
    true_i.
    not_e H H0.
  Qed.

  Theorem p8 : ~(A \/ B) -> ~A /\ ~B.
    imp_i.
    and_i.
    not_i.
    assert (A \/ B).
    or_i1.
    assumption.
    not_e H H1.
    not_i.
    assert (A \/ B).
    or_i2.
    assumption.
    not_e H H1.
  Qed.
End propositional.

(** * Some first-order theorems *)

Section firstorder.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A.
  Variable P : A -> Prop.
  Variable Q : A -> A -> Prop.
  Variable R : Prop.

  Theorem f1 : (forall x : A, P x)
    -> P e.
    imp_i.
    forall_e H e.
  Qed.

  Theorem f2 : (forall x : A, P (f x))
    -> (P (f e) -> R)
    -> R.
    imp_i.
    imp_i.
    forall_e H e.
    imp_e H0 H1.
  Qed.

  Theorem f3 : P e
    -> (exists x : A, P x).
    imp_i.
    exists_i e.
    assumption.
  Qed.

  Theorem f4 : (exists x : A, P (f x))
    -> (forall x : A, P x -> R)
    -> R.
    imp_i.
    imp_i.
    exists_e H.
    forall_e H0 (f x).
    imp_e H1 H.
  Qed.

  Theorem f5 : (forall x : A, x = e -> R)
    -> R.
    imp_i.
    forall_e H e.
    assert (e = e).
    reflexivity.
    imp_e H0 H1.
  Qed.

  Theorem f6 : forall x : A, forall y : A, forall z : A,
    x = y
    -> y = z
    -> x = z.
    forall_i.
    forall_i.
    forall_i.
    imp_i.
    imp_i.
    rewrite H.
    assumption.
  Qed.

  Theorem f7 : (forall x : A, forall y : A, forall z : A, Q x y -> Q y z -> Q x z)
    -> (forall x : A, Q x (f x))
    -> (exists x : A, Q e (f (f x))).
    imp_i.
    imp_i.
    exists_i e.
    forall_e H e.
    forall_e H1 (f e).
    forall_e H2 (f (f e)).
    forall_e H0 e.
    forall_e H0 (f e).
    imp_e H3 H4.
    imp_e H6 H5.
  Qed.

  Theorem f8 :
    e = f e
    -> (forall x, P (f x))
    -> P e.
    imp_i.
    imp_i.
    forall_e H0 e.
    rewrite H.
    assumption.
  Qed.
End firstorder.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable eT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable eF_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_3_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_parallelsymmetric_1 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_parallelflip_2 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_triangletoparallelogram_10 : (forall A C D E F : Universe, (exists X : Universe, ((par_ D C E F /\ col_ E F A) -> (pG_ A X C D /\ col_ E F X)))).
Variable lemma_PGrotate_11 : (forall A B C D : Universe, (pG_ A B C D -> pG_ B C D A)).
Variable lemma_collinearorder_12 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_parallelNC_13 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable lemma_NCdistinct_14 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_inequalitysymmetric_15 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_16 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable proposition_35_17 : (forall A B C D E F : Universe, ((pG_ A B C D /\ (pG_ E B C F /\ (col_ A D E /\ col_ A D F))) -> eF_ A B C D E B C F)).
Variable proposition_34_18 : (forall A B C D : Universe, (pG_ A C D B -> (cong_ A B C D /\ (cong_ A C B D /\ (congA_ C A B B D C /\ (congA_ A B D D C A /\ cong_3_ C A B B D C)))))).
Variable lemma_diagonalsmeet_19 : (forall A B C D : Universe, (exists X : Universe, (pG_ A B C D -> (betS_ A X C /\ betS_ B X D)))).
Variable defparallelogram_20 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_21 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_NCorder_22 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable defoppositeside_23 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_24 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_oppositesidesymmetric_25 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).
Variable axiom_congruentequal_26 : (forall A B C Ca Cb Cc : Universe, (cong_3_ A B C Ca Cb Cc -> eT_ A B C Ca Cb Cc)).
Variable axiom_ETpermutation_27 : (forall A B C Ca Cb Cc : Universe, (eT_ A B C Ca Cb Cc -> (eT_ A B C Cb Cc Ca /\ (eT_ A B C Ca Cc Cb /\ (eT_ A B C Cb Ca Cc /\ (eT_ A B C Cc Cb Ca /\ eT_ A B C Cc Ca Cb)))))).
Variable axiom_ETsymmetric_28 : (forall A B C Ca Cb Cc : Universe, (eT_ A B C Ca Cb Cc -> eT_ Ca Cb Cc A B C)).
Variable axiom_EFpermutation_29 : (forall A B C D Ca Cb Cc Cd : Universe, (eF_ A B C D Ca Cb Cc Cd -> (eF_ A B C D Cb Cc Cd Ca /\ (eF_ A B C D Cd Cc Cb Ca /\ (eF_ A B C D Cc Cd Ca Cb /\ (eF_ A B C D Cb Ca Cd Cc /\ (eF_ A B C D Cd Ca Cb Cc /\ (eF_ A B C D Cc Cb Ca Cd /\ eF_ A B C D Ca Cd Cc Cb)))))))).
Variable axiom_EFsymmetric_30 : (forall A B C D Ca Cb Cc Cd : Universe, (eF_ A B C D Ca Cb Cc Cd -> eF_ Ca Cb Cc Cd A B C D)).
Variable axiom_halvesofequals_31 : (forall A B C D Ca Cb Cc Cd : Universe, ((eT_ A B C B C D /\ (tS_ A B C D /\ (eT_ Ca Cb Cc Cb Cc Cd /\ (tS_ Ca Cb Cc Cd /\ eF_ A B D C Ca Cb Cd Cc)))) -> eT_ A B C Ca Cb Cc)).

Theorem proposition_37_32 : (forall A B C D : Universe, (par_ A D B C -> eT_ A B C D B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coq Require Export
     List.
Export ListNotations.

Fixpoint repeat_list {A} (n : nat) (l : list A) : list A :=
  match n with
  | O    => []
  | S n' => l ++ repeat_list n' l
  end.


Require Import FunctionalExtensionality.
Require Import Program.

Set Implicit Arguments.
Set Automatic Coercions Import.

(* Tactics.  FIXME: move it! *)

Ltac inv H := inversion H; subst; clear H.
Ltac simplify := repeat (autounfold in *; unfold id in *; simpl in *).

(* Categories *)

Class FunctorData (F : Type -> Type) : Type
  := { map: forall T1 T2 (f: forall (x1:T1), T2) (fx1:F T1), F T2; }.

Class FunctorProp F `{FunctorData F} : Prop
  := {
      MAP_ID T:
        map (@id T) = id;
      MAP_COMPOSE T1 T2 T3
                  (f12: forall (x1:T1), T2)
                  (f23: forall (x2:T2), T3)
                  x1:
        map f23 (map f12 x1) = map (f23 ∘ f12) x1;
    }.
Arguments FunctorProp F {H}.

Class SFunctorData F `{FunctorData F} : Type
  := {
      mem: forall X, F X -> X -> Prop;
      tag: forall {X} (x : F X), F (sigT (mem x));
      rel: forall X Y (rel: X -> Y -> Prop) (fx:F X) (fy:F Y), Prop;
      (* TAG: forall X (x: F X), map (@projT1 X _) (tag x) = x; *)
    }.
Arguments SFunctorData F {H}.

Class SFunctorProp F `{H : FunctorData F} `{@SFunctorData _ H} `{@FunctorProp _ H}
  : Prop
  := {
      MAP_MEM: forall X Y (f: X -> Y) (fx: F X) (x: X) (MEM: mem fx x), mem (map f fx) (f x);
    }.
Arguments SFunctorProp F {H} {H0} {H1}.

Structure NatTrans (F G : Type -> Type) `{FunctorData F} `{FunctorData G} : Type :=
  {
    NT :> forall {X:Type} (fx:F X), G X;
    MAP_COMMUTE: forall T1 T2 (f:T1 -> T2) x, NT (map f x) = (map f) (NT x);
  }.
Arguments NatTrans F G {H} {H0}.

Class SNatTransProp F G `{H : FunctorData F} `{H0 : FunctorData G}
      `{@SFunctorData F H} `{@SFunctorData G H0} `{H1 : @NatTrans F G _ _}
  : Prop := {
             MEM_COMMUTE: forall X fx (x:X), mem fx x <-> mem (H1 _ fx) x;
             REL_COMMUTE: forall T1 T2 (rel': forall (x1:T1) (x2:T2), Prop) fx1 fx2,
                 rel rel' fx1 fx2 <-> rel rel' (H1 _ fx1) (H1 _ fx2);
           }.

(* instances *)

Definition Ident (X : Type) := X.

Instance id_functorData : FunctorData Ident := Build_FunctorData _ (fun _ _ => id).

Program Instance id_sFunctorData : SFunctorData Ident
  := Build_SFunctorData _
                        (fun _ fx x => fx = x)
                        (fun _ x => existT _ x eq_refl)
                        (fun _ _ rel fx fy => rel fx fy).
Hint Resolve id_functorData id_sFunctorData.

Definition Const (T : Type) (X : Type) := T.

Instance const_functorData T : FunctorData (Const T)
  := Build_FunctorData (fun X => T) (fun _ _ _ x => x).

Program Instance const_sFunctorData T : SFunctorData (Const T)
  := Build_SFunctorData _
                        (fun _ _ _ => False)
                        (fun _ x => x)
                        (fun _ _ _ => eq).

Hint Resolve const_functorData const_sFunctorData.

Definition Expn (D : Type) (F : Type -> Type) := (fun X => D -> F X).

Definition function_map D F `{FunctorData F} T1 T2 (f: T1 -> T2)
           (fx1: D -> F T1) :=
  (map f) ∘ fx1.
Hint Unfold function_map.

Inductive function_mem D F `{SFunctorData F} T (fx: D -> F T) x: Prop :=
| Function_mem d (MEM: mem (fx d) x).
Hint Constructors function_mem.

Definition function_tag D F `{SFunctorData F} T (fx: D -> F T) : D -> F (sigT (function_mem fx)) :=
  fun d =>
    map (fun x => match x with
                    existT _ x m => existT (function_mem fx) x (Function_mem fx x d m)
                  end)
        (tag (fx d)).

Definition function_rel D F `{SFunctorData F} T1 T2
           f (fx1:D -> F T1) (fx2:D -> F T2): Prop :=
  forall d, rel f (fx1 d) (fx2 d).
Hint Unfold function_rel.

Instance function_functorData D F `{FunctorData F}
  : FunctorData (Expn D F) := Build_FunctorData _ (@function_map D F _).

Program Instance function_sFunctorData D F `{SFunctorData F}
  : SFunctorData (Expn D F)
  := Build_SFunctorData _
                        (@function_mem _ _ _ _)
                        (@function_tag _ _ _ _)
                        (@function_rel _ _ _ _).
Hint Resolve function_functorData function_sFunctorData.

Definition Coprod (F1 F2: Type -> Type) T := (F1 T + F2 T)%type.

Definition coproduct_map F1 F2 `{FunctorData F1} `{FunctorData F2} T1 T2
           (f:T1 -> T2) (fx: F1 T1 + F2 T1) :=
  match fx with
  | inl fx => inl (map f fx)
  | inr fx => inr (map f fx)
  end.

Hint Unfold coproduct_map.

Definition coproduct_mem F1 F2 `{SFunctorData F1} `{SFunctorData F2} T
           (fx: F1 T + F2 T) x :=
  match fx with
  | inl fx => mem fx x
  | inr fx => mem fx x
  end.

Hint Unfold coproduct_mem.

Inductive coproduct_rel F1 F2 `{SFunctorData F1} `{SFunctorData F2} T1 T2 f:
  forall (fx1:Coprod F1 F2 T1) (fx2:Coprod F1 F2 T2), Prop :=
| coproduct_rel_inl fx1 fx2 (REL: rel f fx1 fx2):
    coproduct_rel f (inl fx1) (inl fx2)
| coproduct_rel_inr fx1 fx2 (REL: rel f fx1 fx2):
    coproduct_rel f (inr fx1) (inr fx2)
.

Hint Constructors coproduct_rel.

Program Instance coproduct_functorData  F1 F2 `{FunctorData F1} `{FunctorData F2}
  : FunctorData (Coprod F1 F2)
  := Build_FunctorData _ (@coproduct_map _ _ _ _).

Program Instance coproduct_sFunctorData F1 F2 `{SFunctorData F1} `{SFunctorData F2}
  : SFunctorData (Coprod F1 F2)
  := Build_SFunctorData _
                        (@coproduct_mem _ _ _ _ _ _)
                        (fun _ x => match x with
                                    | inl x' => inl (tag x')
                                    | inr x' => inr (tag x')
                                    end)
                        (@coproduct_rel _ _ _ _ _ _) .
Hint Resolve coproduct_functorData coproduct_sFunctorData.

Definition map_dep F `{SFunctorData F} X Y (fx : F X) (f : forall x (MEM: mem fx x), Y)
  : F Y := map (fun x =>match x with existT _ _ m => f _ m end) (tag fx).


Require Export GeoCoq.Elements.OriginalProofs.proposition_34.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.

Section Euclid.

Context `{Ax1:euclidean_euclidean}.

Lemma lemma_35helper :
   forall A B C D E F,
   PG A B C D -> PG E B C F -> BetS A D F -> Col A E F ->
   BetS A E F.
Proof.
intros.
assert ((Par A B C D /\ Par A D B C)) by (conclude_def PG ).
assert ((Par E B C F /\ Par E F B C)) by (conclude_def PG ).
assert (Par A B D C) by (forward_using lemma_parallelflip).
assert (Par E B F C) by (forward_using lemma_parallelflip).
assert (Cong A D B C) by (forward_using proposition_34).
assert (Cong E F B C) by (forward_using proposition_34).
assert (Cong B C E F) by (conclude lemma_congruencesymmetric).
assert (Cong A D E F) by (conclude lemma_congruencetransitive).
assert (Col A D F) by (conclude_def Col ).
assert (Col F A E) by (forward_using lemma_collinearorder).
assert (Col F A D) by (forward_using lemma_collinearorder).
assert (neq A F) by (forward_using lemma_betweennotequal).
assert (neq F A) by (conclude lemma_inequalitysymmetric).
assert (Col A E D) by (conclude lemma_collinear4).
let Tf:=fresh in
assert (Tf:exists M, (BetS A M C /\ BetS B M D)) by (conclude lemma_diagonalsmeet);destruct Tf as [M];spliter.
assert (BetS D M B) by (conclude axiom_betweennesssymmetry).
assert (BetS C M A) by (conclude axiom_betweennesssymmetry).
assert (BetS B M D) by (conclude axiom_betweennesssymmetry).
let Tf:=fresh in
assert (Tf:exists m, (BetS E m C /\ BetS B m F)) by (conclude lemma_diagonalsmeet);destruct Tf as [m];spliter.
assert (BetS F m B) by (conclude axiom_betweennesssymmetry).
assert (BetS B m F) by (conclude axiom_betweennesssymmetry).
assert (nCol A D B) by (forward_using lemma_parallelNC).
assert (Col A D F) by (conclude_def Col ).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col A D A) by (conclude_def Col ).
assert (nCol A F B) by (conclude lemma_NChelper).
let Tf:=fresh in
assert (Tf:exists Q, (BetS B Q F /\ BetS A M Q)) by (conclude postulate_Pasch_outer);destruct Tf as [Q];spliter.
assert (Col A M Q) by (conclude_def Col ).
assert (Col A M C) by (conclude_def Col ).
assert (Col M A Q) by (forward_using lemma_collinearorder).
assert (Col M A C) by (forward_using lemma_collinearorder).
assert (neq A M) by (forward_using lemma_betweennotequal).
assert (neq M A) by (conclude lemma_inequalitysymmetric).
assert (Col A Q C) by (conclude lemma_collinear4).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col F A A) by (conclude_def Col ).
assert (Col C C B) by (conclude_def Col ).
assert (neq A F) by (forward_using lemma_betweennotequal).
assert (neq F A) by (conclude lemma_inequalitysymmetric).
assert (neq B C) by (conclude_def Par ).
assert (neq C B) by (conclude lemma_inequalitysymmetric).
assert (~ Meet F A C B).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists p, (neq F A /\ neq C B /\ Col F A p /\ Col C B p)) by (conclude_def Meet );destruct Tf as [p];spliter.
 assert (Col A D F) by (conclude_def Col ).
 assert (Col F A D) by (forward_using lemma_collinearorder).
 assert (neq A D) by (forward_using lemma_betweennotequal).
 assert (Col A D p) by (conclude lemma_collinear4).
 assert (Col B C p) by (forward_using lemma_collinearorder).
 assert (Meet A D B C) by (conclude_def Meet ).
 assert (~ Meet A D B C) by (conclude_def Par ).
 contradict.
 }
assert (BetS F Q B) by (conclude axiom_betweennesssymmetry).
assert (~ Meet A D B C) by (conclude_def Par ).
assert (Col A C Q) by (forward_using lemma_collinearorder).
assert (BetS A Q C) by (conclude lemma_collinearbetween).
assert (BetS C Q A) by (conclude axiom_betweennesssymmetry).
assert (~ eq A E).
 {
 intro.
 assert (Cong A F A F) by (conclude cn_congruencereflexive).
 assert (Cong A F E F) by (conclude cn_equalitysub).
 assert (Cong E F A D) by (conclude lemma_congruencesymmetric).
 assert (Cong A F A D) by (conclude lemma_congruencetransitive).
 assert (Cong A D A F) by (conclude lemma_congruencesymmetric).
 assert (Cong A D A D) by (conclude cn_congruencereflexive).
 assert (Lt A D A F) by (conclude_def Lt ).
 assert (Lt A F A F) by (conclude lemma_lessthancongruence2).
 assert (~ Lt A F A F) by (conclude lemma_trichotomy2).
 contradict.
 }
assert (~ BetS A F E).
 {
 intro.
 assert (BetS E F A) by (conclude axiom_betweennesssymmetry).
 assert (nCol A D C) by (forward_using lemma_parallelNC).
 assert (Col A D E) by (forward_using lemma_collinearorder).
 assert (nCol A E C) by (conclude lemma_NChelper).
 assert (nCol C A E) by (forward_using lemma_NCorder).
 let Tf:=fresh in
 assert (Tf:exists r, (BetS C r F /\ BetS E r Q)) by (conclude postulate_Pasch_inner);destruct Tf as [r];spliter.
 assert (BetS Q r E) by (conclude axiom_betweennesssymmetry).
 assert (nCol E B F) by (forward_using lemma_parallelNC).
 assert (nCol F B E) by (forward_using lemma_NCorder).
 rename_H H;let Tf:=fresh in
 assert (Tf:exists H, (BetS E H B /\ BetS F r H)) by (conclude postulate_Pasch_outer);destruct Tf as [H];spliter.
 assert (Col E H B) by (conclude_def Col ).
 assert (Col F r H) by (conclude_def Col ).
 assert (Col E B H) by (forward_using lemma_collinearorder).
 assert (Col C r F) by (conclude_def Col ).
 assert (Col r F C) by (forward_using lemma_collinearorder).
 assert (Col r F H) by (forward_using lemma_collinearorder).
 assert (neq r F) by (forward_using lemma_betweennotequal).
 assert (Col F C H) by (conclude lemma_collinear4).
 assert (neq B E) by (forward_using lemma_NCdistinct).
 assert (neq E B) by (conclude lemma_inequalitysymmetric).
 assert (neq F C) by (conclude_def Par ).
 assert (Meet E B F C) by (conclude_def Meet ).
 assert (~ Meet E B F C) by (conclude_def Par ).
 contradict.
 }
assert (Col A F E) by (forward_using lemma_collinearorder).
assert ((eq A F \/ eq A E \/ eq F E \/ BetS F A E \/ BetS A F E \/ BetS A E F)) by (conclude_def Col ).
assert (BetS A E F).
by cases on (eq A F \/ eq A E \/ eq F E \/ BetS F A E \/ BetS A F E \/ BetS A E F).
{
 assert (~ ~ BetS A E F).
  {
  intro.
  assert (BetS A D A) by (conclude cn_equalitysub).
  assert (~ BetS A D A) by (conclude axiom_betweennessidentity).
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS A E F).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS A E F).
  {
  intro.
  assert (eq E F) by (conclude lemma_equalitysymmetric).
  assert (Col B E F) by (conclude_def Col ).
  assert (Col E B F) by (forward_using lemma_collinearorder).
  assert (eq F F) by (conclude cn_equalityreflexive).
  assert (Col F C F) by (conclude_def Col ).
  assert (neq E B) by (conclude_def Par ).
  assert (neq F C) by (conclude_def Par ).
  assert (Meet E B F C) by (conclude_def Meet ).
  assert (~ Meet E B F C) by (conclude_def Par ).
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS A E F).
  {
  intro.
  assert (BetS F D A) by (conclude axiom_betweennesssymmetry).
  assert (BetS D A E) by (conclude lemma_3_6a).
  assert (Cong D A D A) by (conclude cn_congruencereflexive).
  assert (Lt D A D E) by (conclude_def Lt ).
  assert (Cong D A A D) by (conclude cn_equalityreverse).
  assert (Lt A D D E) by (conclude lemma_lessthancongruence2).
  assert (Cong D E E D) by (conclude cn_equalityreverse).
  assert (Lt A D E D) by (conclude lemma_lessthancongruence).
  assert (Cong A D A D) by (conclude cn_congruencereflexive).
  assert (Lt A D A F) by (conclude_def Lt ).
  assert (Cong A D D A) by (conclude cn_equalityreverse).
  assert (Lt D A A F) by (conclude lemma_lessthancongruence2).
  assert (Cong A F F A) by (conclude cn_equalityreverse).
  assert (Lt D A F A) by (conclude lemma_lessthancongruence).
  assert (Cong F A F A) by (conclude cn_congruencereflexive).
  assert (Lt F A F E) by (conclude_def Lt ).
  assert (Lt D A F E) by (conclude lemma_lessthantransitive).
  assert (Cong D A F E) by (forward_using lemma_congruenceflip).
  assert (Lt F E F E) by (conclude lemma_lessthancongruence2).
  assert (~ Lt F E F E) by (conclude lemma_trichotomy2).
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS A E F).
  {
  intro.
  contradict.
  }
 close.
 }
{
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


From VFA Require Import Perm.
From VFA Require Import Sort.
From Coq Require Import Recdef. (* needed for Function feature *)

Fixpoint split {X:Type} (l:list X) : (list X * list X) :=
  match l with
  | []          => ([],[])
  | [x]         => ([x],[])
  | x1::x2::l'  =>
    let (l1,l2) := split l' in (x1::l1, x2::l2)
  end.

Definition list_ind2_principle:=
    forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a: A), P [a]) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall (l : list A), P l.

Fixpoint my_ind_foo (A : Type) (P : list A -> Prop)
  (Pnil: P [])
  (Pone: forall (a: A), P [a])
  (Ptwo: forall (a b : A) (l : list A), P l -> P (a :: b :: l))
  (l : list A) :=
    match l with
    | nil => Pnil
    | [a] => Pone a
    | a :: b :: tail => Ptwo a b tail (my_ind_foo A P Pnil Pone Ptwo tail)
    end.

Definition list_ind2 :
  forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a: A), P [a]) ->
      (forall (a b: A) (l: list A), P l -> P (a :: b :: l)) ->
      forall (l : list A), P l :=
  fun (A : Type)
      (P : list A -> Prop)
      (H : P [])
      (H0 : forall (a: A), P [a])
      (H1 : forall (a b: A) (l: list A), P l -> P (a :: b :: l)) =>
    fix IH (l : list A) : P l :=
    match l with
    | []           => H
    | [x]          => H0 x
    | x :: y :: l' => H1 x y l' (IH l')
    end.

Lemma split_len': list_ind2_principle ->
    forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  unfold list_ind2_principle; intro IP.
  induction l using IP; intros.
  - inv H. lia.
  - inv H. simpl; lia.
  - inv H. destruct (split l) as [l1' l2']. inv H1.
    simpl.
    destruct (IHl l1' l2') as [P1 P2]; auto; lia.
Qed.

Lemma split_len: forall {X} (l: list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
(*  apply (@split_len' my_ind_foo). *)
 apply (@split_len' list_ind2).
Qed.

Lemma split_perm : forall {X:Type} (l l1 l2: list X),
    split l = (l1,l2) -> Permutation l (l1 ++ l2).
Proof.
  induction l as [| x | x1 x2 l1' IHl'] using list_ind2; intros.
  - simpl in H. injection H as H1' H2'. subst. simpl.
    constructor.
  - simpl in H. injection H as H1' H2'. subst. simpl.
    constructor.
    constructor.
  - simpl in H.
    destruct (split l1') eqn:E.
    injection H as H1' H2'. subst. simpl.
    assert (G: Permutation l1' (l ++ l0)). { apply IHl'. reflexivity. }
    change (x1 :: l ++ x2 :: l0) with ([x1] ++ l ++ x2 :: l0).
    apply perm_trans with ([x1] ++ x2 :: l0 ++ l).
    + simpl.
      apply perm_skip.
      apply perm_skip.
      apply perm_trans with (l ++ l0).
        apply G.
        apply Permutation_app_comm.
    + apply Permutation_app_head.
      change (x2 :: l0 ++ l) with ((x2 :: l0) ++ l).
      apply (Permutation_app_comm).
Qed.

Fixpoint merge l1 l2 {struct l1} :=
  let fix merge_aux l2 :=
    match l1, l2 with
    | [], _ => l2
    | _, [] => l1
    | a1::l1', a2::l2' => if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
    end
  in merge_aux l2.

Print merge.

Lemma merge2 : forall (x1 x2:nat) r1 r2,
    x1 <= x2 ->
    merge (x1::r1) (x2::r2) = x1 :: merge r1 (x2::r2).
Proof.
  intros.
  simpl. (* This blows up in an unpleasant way, but we can
      still make some sense of it.  Look at the
      (fix merge_aux ...) term. It represents the
      the local function merge_aux after the value of the
      free variable l1 has been substituted by x1::r1,
      the match over l1 has been simplified to its
      second arm (the non-empty case) and x1 and r1 have
      been substituted for the pattern variables a1 and l1'.
      The entire fix is applied to r2, but Coq won't attempt
      any further simplification until the structure of r2
      is known. *)
  bdestruct (x1 <=? x2).
  - auto.
  - (* Since H and H0 are contradictory, this case follows by lia.
       But (ignoring that for the moment), note that we can get further
       simplification to occur if we give some structure to l2: *)
    simpl. (* does nothing *)
    destruct r2; simpl. (* makes some progress *)
    + lia.
    + lia.
Qed.

Lemma merge_nil_l : forall l, merge [] l = l.
Proof.
  intros. simpl.
  (* Once again, we see a version of merge_aux specialized to
  the value l1 = nil. Now we see only the first arm (the
  empty case) of the match expression, which simply returns l2;
  in other words, here the fix is just the identity function.
  And once again, the fix is applied to l.  Irritatingly,
  Coq _still_ refuses to perform the application unless l
  is destructured first (even though the answer is always l). *)
  destruct l.
  - auto.
  - auto.
Qed.

Function mergesort (l: list nat) {measure length l} : list nat :=
  match l with
  | []  => []
  | [x] => [x]
  | _   => let (l1,l2) := split l in
         merge (mergesort l1) (mergesort l2)
  end.
Proof.
  - (* recursive call on l1 *)
    intros.
    simpl in *. destruct (split l1) as [l1' l2'] eqn:E. inv teq1. simpl.
    destruct (split_len _ _ _ E).
    lia.
  - (* recursive call on l2 *)
    intros.
    simpl in *. destruct (split l1) as [l1' l2'] eqn:E. inv teq1. simpl.
    destruct (split_len _ _ _ E).
    lia.
Defined.

Check mergesort_equation. (* use it for undold *)
Check mergesort_ind.

Lemma sorted_merge1 : forall x x1 l1 x2 l2,
    x <= x1 -> x <= x2 ->
    sorted (merge (x1 :: l1) (x2 :: l2)) ->
    sorted (x :: merge (x1 :: l1) (x2 :: l2)).
Proof.
  intros x x1 l1 x2 l2 Hx1 Hx2 Hsorted.
  simpl in *.
  bdestruct (x2 >=? x1).
  - constructor. lia. apply Hsorted.
  - constructor. lia. apply Hsorted.
Qed.

Print sorted.
Lemma sorted_merge : forall l1, sorted l1 ->
                     forall l2, sorted l2 ->
                     sorted (merge l1 l2).
Proof.
  intros l1.
  induction l1.
  - intros _ l2 HSorted2. rewrite merge_nil_l. apply HSorted2.
  - intros HSorted1 l2.
    induction l2.
    + intros _.
      simpl. apply HSorted1.
    + intros HSorted2.
      simpl.
      bdestruct (a0 >=? a).
      * destruct l1 eqn:El1.
        ** simpl. constructor. apply H. apply HSorted2.
        ** apply sorted_merge1.
           inversion HSorted1; subst. lia. lia.
           apply IHl1. inversion HSorted1; subst. apply H4. apply HSorted2.
      * destruct l2 eqn:El2.
        ** constructor. lia. apply HSorted1.
        ** assert (G: sorted (a0 :: merge (a :: l1) (n :: l))). {
             apply sorted_merge1.
             - lia.
             - inversion HSorted2; subst. lia.
             - apply IHl2.
               inversion HSorted2; subst. apply H4.
           }
           apply G.
Qed.

Lemma mergesort_sorts: forall l, sorted (mergesort l).
Proof.
  apply mergesort_ind; intros.
  - constructor.
  - constructor.
  - apply sorted_merge.
    + apply H.
    + apply H0.
Qed.

Search Permutation.
Search (?l ++ []).

Lemma merge_perm: forall (l1 l2: list nat),
    Permutation (l1 ++ l2) (merge l1 l2).
Proof.
  intros l1.
  induction l1.
  - intro l2. rewrite merge_nil_l with l2. simpl. apply Permutation_refl.
  - intro l2.
    induction l2.
    + rewrite app_nil_r. simpl. apply Permutation_refl.
    + simpl.
      bdestruct (a0 >=? a).
      * apply perm_skip.
        apply IHl1.
      * apply perm_trans with (a0 :: (a :: l1 ++ l2)).
        ** change (a :: l1 ++ a0 :: l2) with ((a :: l1) ++ [a0] ++ l2).
           apply perm_trans with ([a0] ++ (a :: l1) ++ l2).
            apply Permutation_app_swap_app.
            simpl. apply Permutation_refl.
        ** apply perm_skip.
           apply IHl2.
Qed.

Lemma mergesort_perm: forall l, Permutation l (mergesort l).
Proof.
  apply mergesort_ind; intros.
  - apply Permutation_refl.
  - apply Permutation_refl.
  - subst.
    apply perm_trans with ((mergesort l1) ++ (mergesort l2)).
    + apply split_perm in e0.
      apply perm_trans with (l1 ++ l2).
      * apply e0.
      * apply Permutation_app.
          apply H.
          apply H0.
    + apply merge_perm.
Qed.

Theorem mergesort_correct:
  is_a_sorting_algorithm mergesort.
Proof.
  split.
  apply mergesort_perm.
  apply mergesort_sorts.
Qed.