(** Here we define the signature for the circle *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Colimits.Initial.
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.displayed_algebra.

Local Open Scope cat.

Definition poly_id_comp
           (P : poly_code)
           {X Y : UU}
           (f : X → Y)
           (x : poly_act P X)
  : poly_id P Y (poly_map P f x) @ poly_comp P f (λ z, z) x
    =
    poly_homot P (λ z, idpath _) x.
Proof.
  induction P as [ T | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - apply idpath.
  - induction x as [x | x] ; simpl.
    + exact (!(maponpathscomp0 _ _ _) @ maponpaths (maponpaths inl) (IHP₁ _)).
    + exact (!(maponpathscomp0 _ _ _) @ maponpaths (maponpaths inr) (IHP₂ _)).
  - exact (pathsdirprod_concat _ _ _ _ @ paths_pathsdirprod (IHP₁ _) (IHP₂ _)).
Defined.

(**
Lemmata on carriers of 2-cells.
In certain cases, unfolding the definitions is slow.
For this reason, we make separate lemmas, which are faster to use.
 *)
Definition alg_2cell_vcomp
           {Σ : hit_signature}
           {X Y : hit_algebra_one_types Σ}
           {f g h : X --> Y}
           (τ : f ==> g)
           (θ : g ==> h)
  : alg_2cell_carrier (τ • θ)
    =
    homotcomp
      (alg_2cell_carrier τ)
      (alg_2cell_carrier θ)
  := idpath _.

Definition alg_2cell_rwhisker
           {Σ : hit_signature}
           {X Y Z : hit_algebra_one_types Σ}
           {f g : X --> Y}
           (τ : f ==> g)
           (h : Y --> Z)
  : alg_2cell_carrier (τ ▹ h)
    =
    λ z, maponpaths (alg_map_carrier h) (alg_2cell_carrier τ z)
  := idpath _.

Definition alg_2cell_inv
           {Σ : hit_signature}
           {X Y : hit_algebra_one_types Σ}
           {f g : X --> Y}
           (τ : f ==> g)
  : alg_2cell_carrier
      ((hit_alg_is_invertible_2cell_one_type Σ τ)^-1)
    =
    invhomot (alg_2cell_carrier τ)
  := idpath _.

(** Free `Σ'-algebra generated by `A` *)
Section FreeAlg.
  Variable (Σ : hit_signature)
           (A : one_type).

  Definition free_alg_signature_point_constr
    : poly_code
    := point_constr Σ + C A.

  Definition to_free_alg_endpoint
             {P Q : poly_code}
             (e : endpoint (point_constr Σ) P Q)
    : endpoint free_alg_signature_point_constr P Q.
  Proof.
    induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                    | P Q | P Q | P Q | P Q
                    | P Q R e₁ IHe₁ e₂ IHe₂
                    | P T t | C₁ C₂ g | ].
    - (* identity *)
      exact (id_e _ _).
    - (* composition *)
      exact (comp IHe₁ IHe₂).
    - (* left inclusion *)
      exact (ι₁ _ _).
    - (* right inclusion *)
      exact (ι₂ _ _).
    - (* left projection *)
      exact (π₁ _ _).
    - (* right projection *)
      exact (π₂ _ _).
    - (* pair *)
      exact (pair IHe₁ IHe₂).
    - (* constant element *)
      exact (c _ t).
    - (* constant map *)
      exact (fmap g).
    - (* constructor *)
      exact (comp (ι₁ _ _) constr).
  Defined.

  Definition free_alg_signature_path_left
             (j : path_label Σ)
    : endpoint free_alg_signature_point_constr (path_source Σ j) I
    := to_free_alg_endpoint (path_left Σ j).

  Definition free_alg_signature_path_right
             (j : path_label Σ)
    : endpoint free_alg_signature_point_constr (path_source Σ j) I
    := to_free_alg_endpoint (path_right Σ j).

  Definition free_alg_signature_path_arg_left
             (j : homot_label Σ)
    : endpoint
        free_alg_signature_point_constr
        (homot_point_arg Σ j)
        (homot_path_arg_target Σ j)
    := to_free_alg_endpoint (homot_path_arg_left Σ j).

  Definition free_alg_signature_path_arg_right
             (j : homot_label Σ)
    : endpoint
        free_alg_signature_point_constr
        (homot_point_arg Σ j)
        (homot_path_arg_target Σ j)
    := to_free_alg_endpoint (homot_path_arg_right Σ j).

  Definition free_alg_signature_homot_left_endpoint
             (j : homot_label Σ)
    : endpoint free_alg_signature_point_constr (homot_point_arg Σ j) I
    := to_free_alg_endpoint (homot_left_endpoint Σ j).

  Definition free_alg_signature_homot_right_endpoint
             (j : homot_label Σ)
    : endpoint free_alg_signature_point_constr (homot_point_arg Σ j) I
    := to_free_alg_endpoint (homot_right_endpoint Σ j).

  Definition free_alg_signature_homot_endpoint
             {Q TR T : poly_code}
             {al ar : endpoint (point_constr Σ) Q TR}
             {sl sr : endpoint (point_constr Σ) Q T}
             (p : homot_endpoint
                    (path_left Σ)
                    (path_right Σ)
                    al ar
                    sl sr)
    : homot_endpoint
        free_alg_signature_path_left
        free_alg_signature_path_right
        (to_free_alg_endpoint al)
        (to_free_alg_endpoint ar)
        (to_free_alg_endpoint sl)
        (to_free_alg_endpoint sr).
  Proof.
    induction p as [T e | T e₁ e₂ p IHp | T e₁ e₂ e₃ p₁ IHp₁ p₂ IHp₂
                    | T₁ T₂ e₁ e₂ e₃ h IHh
                    | R₁ R₂ T e₁ e₂ e₃ | T e | T e
                    | P R e₁ e₂ | P R e₁ e₂
                    | T₁ T₂ e₁ e₂ e₃ e₄ p₁ IHp₁ p₂ IHp₂
                    | P₁ P₂ P₃ e₁ e₂ e₃
                    | Z x T e | j e | ].
    - (* reflexivity *)
      exact (refl_e _).
    - (* symmetry *)
      exact (inv_e IHp).
    - (* transitivity *)
      exact (trans_e IHp₁ IHp₂).
    - (* ap *)
      exact (ap_e (to_free_alg_endpoint e₃) IHh).
    - (* associativity of composition *)
      apply comp_assoc.
    - (* left unitality *)
      apply comp_id_l.
    - (* right unitality *)
      apply comp_id_r.
    - (* first projection of pair *)
      apply pair_π₁.
    - (* second projection of pair *)
      apply pair_π₂.
    - (* pair of paths *)
      exact (path_pair IHp₁ IHp₂).
    - (* composition with pair *)
      apply comp_pair.
    - (* composition with constant *)
      apply comp_constant.
    - (* path constructor *)
      exact (path_constr j (to_free_alg_endpoint e)).
    - (* path argument *)
      apply path_arg.
  Defined.

  Definition free_alg_signature_homot_left_path
             (j : homot_label Σ)
    : homot_endpoint
        free_alg_signature_path_left
        free_alg_signature_path_right
        (free_alg_signature_path_arg_left j)
        (free_alg_signature_path_arg_right j)
        (free_alg_signature_homot_left_endpoint j)
        (free_alg_signature_homot_right_endpoint j)
    := free_alg_signature_homot_endpoint (homot_left_path Σ j).

  Definition free_alg_signature_homot_right_path
             (j : homot_label Σ)
    : homot_endpoint
        free_alg_signature_path_left
        free_alg_signature_path_right
        (free_alg_signature_path_arg_left j)
        (free_alg_signature_path_arg_right j)
        (free_alg_signature_homot_left_endpoint j)
        (free_alg_signature_homot_right_endpoint j)
    := free_alg_signature_homot_endpoint (homot_right_path Σ j).

  Definition free_alg_signature
    : hit_signature.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _  ,, _ ,, _ ,, _ ,, _).
    - exact free_alg_signature_point_constr.
    - exact (path_label Σ).
    - exact (path_source Σ).
    - exact free_alg_signature_path_left.
    - exact free_alg_signature_path_right.
    - exact (homot_label Σ).
    - exact (homot_point_arg Σ).
    - exact (homot_path_arg_target Σ).
    - exact free_alg_signature_path_arg_left.
    - exact free_alg_signature_path_arg_right.
    - exact free_alg_signature_homot_left_endpoint.
    - exact free_alg_signature_homot_right_endpoint.
    - exact free_alg_signature_homot_left_path.
    - exact free_alg_signature_homot_right_path.
  Defined.

  (** Necessary lemma *)
  Definition free_alg_sem_endpoint_UU
             {P Q : poly_code}
             (e : endpoint (point_constr Σ) P Q)
             {X : UU}
             (c : poly_act (point_constr Σ) X ⨿ A → X)
             (x : poly_act P X)
    : sem_endpoint_UU e (λ z, c(inl z)) x
      =
      sem_endpoint_UU (to_free_alg_endpoint e) c x.
  Proof.
    induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                    | P Q | P Q | P Q | P Q
                    | P Q R e₁ IHe₁ e₂ IHe₂
                    | P T t | C₁ C₂ g | ].
    - (* identity *)
      apply idpath.
    - (* composition *)
      exact (maponpaths _ (IHe₁ _) @ IHe₂ _).
    - (* left inclusion *)
      apply idpath.
    - (* right inclusion *)
      apply idpath.
    - (* left projection *)
      apply idpath.
    - (* right projection *)
      apply idpath.
    - (* pair *)
      exact (pathsdirprod (IHe₁ _) (IHe₂ _)).
    - (* constant element *)
      apply idpath.
    - (* constant map *)
      apply idpath.
    - (* constructor *)
      apply idpath.
  Defined.

  Definition free_alg_sem_endpoint_UU_natural
             {P Q : poly_code}
             (e : endpoint (point_constr Σ) P Q)
             {X Y : UU}
             {cX : poly_act (point_constr Σ) X ⨿ A → X}
             {cY : poly_act (point_constr Σ) Y ⨿ A → Y}
             {f : X → Y}
             (cf : ∏ x, f(cX x) = cY (poly_map (point_constr Σ + C A) f x))
             (x : poly_act P X)
    : sem_endpoint_UU_natural (to_free_alg_endpoint e) cf x
      =
      maponpaths (poly_map Q f) (!(free_alg_sem_endpoint_UU e cX x))
      @ sem_endpoint_UU_natural e (λ z, cf(inl z)) x
      @ free_alg_sem_endpoint_UU e cY (poly_map P f x).
  Proof.
    induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                    | P Q | P Q | P Q | P Q
                    | P Q R e₁ IHe₁ e₂ IHe₂
                    | P T t | C₁ C₂ g | ].
    - (* identity *)
      apply idpath.
    - (* composition *)
      simpl.
      etrans.
      {
        apply maponpaths_2.
        apply IHe₂.
      }
      clear IHe₂.
      etrans.
      {
        do 2 apply maponpaths.
        apply IHe₁.
      }
      clear IHe₁.
      refine (!(path_assoc _ _ _) @ _).
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          apply pathscomp_inv.
        }
        apply maponpathscomp0.
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply path_assoc.
        }
        apply maponpathscomp0.
      }
      refine (path_assoc _ _ _ @ _).
      refine (!_).
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        apply homotsec_natural'.
      }
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        apply homotsec_natural'.
      }
      do 2 refine (path_assoc _ _ _ @ _).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpathscomp0.
      }
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (!path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply maponpathscomp.
        }
        refine (!_).
        apply (homotsec_natural'
                 (λ z, free_alg_sem_endpoint_UU
                         e₂ cY (poly_map Q f z))).
      }
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        refine (!_).
        apply (homotsec_natural'
                 (sem_endpoint_UU_natural
                    e₂
                    (λ z : poly_act (point_constr Σ) X, cf (inl z)))).
      }
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply maponpathsinv0.
      }
      apply maponpathscomp.
    - (* left inclusion *)
      apply idpath.
    - (* right inclusion *)
      apply idpath.
    - (* left projection *)
      apply idpath.
    - (* right projection *)
      apply idpath.
    - (* pair *)
      simpl.
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_inv.
          }
          refine (!_).
          apply maponpaths_pathsdirprod.
        }
        etrans.
        {
          apply maponpaths.
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      refine (!_).
      exact (paths_pathsdirprod (IHe₁ _) (IHe₂ _)).
    - (* constant element *)
      apply idpath.
    - (* constant map *)
      apply idpath.
    - (* constructor *)
      apply idpath.
  Qed.

  Definition free_alg_sem_endpoint_UU_natural'
             {P Q : poly_code}
             (e : endpoint (point_constr Σ) P Q)
             {X Y : UU}
             {cX : poly_act (point_constr Σ) X ⨿ A → X}
             {cY : poly_act (point_constr Σ) Y ⨿ A → Y}
             {f : X → Y}
             (cf : ∏ x, f(cX x) = cY (poly_map (point_constr Σ + C A) f x))
             (x : poly_act P X)
    : maponpaths (poly_map Q f) (free_alg_sem_endpoint_UU e cX x)
      @ sem_endpoint_UU_natural (to_free_alg_endpoint e) cf x
      @ !(free_alg_sem_endpoint_UU e cY (poly_map P f x))
      =
      sem_endpoint_UU_natural e (λ z, cf(inl z)) x.
  Proof.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply free_alg_sem_endpoint_UU_natural.
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
    }
    refine (path_assoc _ _ _ @ _).
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        refine (!_).
        apply maponpathscomp0.
      }
      apply maponpaths.
      apply pathsinv0r.
    }
    apply idpath.
  Qed.

  Definition free_alg_sem_homot_endpoint_UU
             {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 : UU)
             (c : poly_act free_alg_signature_point_constr X → X)
             (pX : ∏ (i : path_label Σ),
                   sem_endpoint_UU (free_alg_signature_path_left i) c
                   ~
                   sem_endpoint_UU (free_alg_signature_path_right i) c)
             (z : poly_act Q X)
             (p_arg : sem_endpoint_UU al (λ w, c (inl w)) z
                      =
                      sem_endpoint_UU ar (λ w, c (inl w)) z)
    : sem_homot_endpoint_UU
        h
        X (λ z, c(inl z))
        (λ i x,
         free_alg_sem_endpoint_UU _ _ _
         @ pX i x
         @ !(free_alg_sem_endpoint_UU _ _ _))
        z
        p_arg
      =
      free_alg_sem_endpoint_UU _ _ _
      @ sem_homot_endpoint_UU
          (free_alg_signature_homot_endpoint h)
          X
          c
          pX
          z
          (!(free_alg_sem_endpoint_UU _ _ _)
           @ p_arg
           @ free_alg_sem_endpoint_UU _ _ _)
      @ !(free_alg_sem_endpoint_UU _ _ _).
  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
                    | P R e₁ e₂ | P R e₁ e₂
                    | T₁ T₂ e₁ e₂ e₃ e₄ h₁ IHh₁ h₂ IHh₂
                    | P₁ P₂ P₃ e₁ e₂ e₃
                    | Z x T e | j e | ].
    - (** identity path *)
      simpl.
      exact (!(pathsinv0r _)).
    - (** inverse path *)
      simpl.
      etrans.
      {
        apply maponpaths.
        exact IHh.
      }
      etrans.
      {
        refine (pathscomp_inv _ _ @ _).
        apply maponpaths_2.
        apply pathscomp_inv.
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths_2.
      apply pathsinv0inv0.
    - (** concatenation of paths *)
      simpl.
      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.
      do 2 refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (_ @ pathscomp0lid _).
      apply maponpaths_2.
      apply pathsinv0l.
    - (** ap on paths *)
      simpl.
      etrans.
      {
        apply maponpaths.
        exact IHh.
      }
      clear IHh.
      etrans.
      {
        apply maponpathscomp0.
      }
      refine (_ @ path_assoc _ _ _).
      apply maponpaths.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        refine (pathscomp_inv _ _ @ _).
        apply maponpaths.
        refine (!_).
        apply maponpathsinv0.
      }
      refine (!_).
      etrans.
      {
        apply maponpathscomp0.
      }
      do 2 refine (_ @ !(path_assoc _ _ _)).
      apply maponpaths_2.
      use path_inv_rotate_rr.
      apply homotsec_natural'.
    - (** associator *)
      simpl.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        apply maponpaths_2.
        etrans.
        {
          apply maponpathscomp0.
        }
        apply maponpaths_2.
        apply maponpathscomp.
      }
      unfold funcomp.
      etrans.
      {
        apply maponpaths_2.
        apply path_assoc.
      }
      apply pathsinv0r.
    - (** left unitor *)
      simpl.
      exact (!(pathsinv0r _)).
    - (** right unitor *)
      simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (pathscomp0rid _ @ _).
        apply maponpathsidfun.
      }
      exact (pathsinv0r _).
    - (** first projection *)
      simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (pathscomp0rid _ @ _).
        apply maponpaths_pr1_pathsdirprod.
      }
      exact (pathsinv0r _).
    - (** second projection *)
      simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (pathscomp0rid _ @ _).
        apply maponpaths_pr2_pathsdirprod.
      }
      exact (pathsinv0r _).
    - (** pairing *)
      simpl.
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      refine (!_).
      exact (paths_pathsdirprod IHh₁ IHh₂).
    - (** composition before pair *)
      simpl.
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          apply pathsdirprod_inv.
        }
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths_prod_path.
          }
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      exact (paths_pathsdirprod (pathsinv0r _) (pathsinv0r _)).
    - (** composition with constant *)
      simpl.
      refine (!_).
      do 2 refine (pathscomp0rid _ @ _).
      apply maponpaths_for_constant_function.
    - (** path constructor *)
      simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply homotsec_natural'.
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply homotsec_natural'.
        }
        apply pathscomp_inv.
      }
      do 2 refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      use path_inv_rotate_lr.
      apply homotsec_natural'.
    - (** path argument *)
      simpl.
      refine (!_).
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2 ; refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        apply pathsinv0r.
      }
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
  Qed.

  (** Projections of an algebra *)
  Section FreeAlgProjections.
    Variable (X : hit_algebra_one_types free_alg_signature).

    Definition free_alg_is_prealg
      : hit_prealgebra_one_types Σ.
    Proof.
      use make_hit_prealgebra.
      - exact (alg_carrier X).
      - apply (one_type_isofhlevel (pr111 X)).
      - exact (λ x, alg_constr X (inl x)).
    Defined.

    Definition free_alg_is_path_alg
      : hit_path_algebra_one_types Σ.
    Proof.
      use make_hit_path_algebra.
      - exact free_alg_is_prealg.
      - exact (λ j x,
               free_alg_sem_endpoint_UU _ _ _
               @ alg_path X j x
               @ !(free_alg_sem_endpoint_UU _ _ _)).
    Defined.

    Definition free_alg_is_alg_homot
      : is_hit_algebra_one_types Σ free_alg_is_path_alg.
    Proof.
      intros j x p.
      unfold sem_homot_endpoint_one_types.
      cbn in p.
      refine (free_alg_sem_homot_endpoint_UU
                (homot_left_path Σ j) _ _ _ _ _
              @ _
              @ !(free_alg_sem_homot_endpoint_UU
                    (homot_right_path Σ j) _ _ _ _ _)).
      apply maponpaths.
      apply maponpaths_2.
      apply (alg_homot X).
    Qed.

    Definition free_alg_is_alg
      : hit_algebra_one_types Σ.
    Proof.
      use make_algebra.
      - exact free_alg_is_path_alg.
      - exact free_alg_is_alg_homot.
    Defined.

    Definition free_alg_inc
      : A → alg_carrier free_alg_is_alg
      := λ a, alg_constr X (inr a).
  End FreeAlgProjections.

  (** Builder of algebras *)
  Section FreeAlgBuilder.
    Variable (X : hit_algebra_one_types Σ)
             (inc : A → alg_carrier X).

    Definition free_alg_point_constr
      : poly_act (point_constr free_alg_signature) (alg_carrier X)
        →
        alg_carrier X.
    Proof.
      intro x.
      induction x as [x | x].
      - exact (alg_constr X x).
      - exact (inc x).
    Defined.

    Definition make_free_alg_prealgebra
      : hit_prealgebra_one_types free_alg_signature.
    Proof.
      use make_hit_prealgebra.
      - exact (alg_carrier X).
      - apply (one_type_isofhlevel (pr111 X)).
      - exact free_alg_point_constr.
    Defined.

    Definition make_free_alg_path_algebra
      : hit_path_algebra_one_types free_alg_signature.
    Proof.
      use make_hit_path_algebra.
      - exact make_free_alg_prealgebra.
      - exact (λ j x,
               !(free_alg_sem_endpoint_UU _ free_alg_point_constr x)
               @ alg_path X j x
               @ free_alg_sem_endpoint_UU _ free_alg_point_constr x).
    Defined.

    Definition free_alg_sem_homot_endpoint_UU'
               {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)
               (z : poly_act Q (alg_carrier X))
               (p_arg : sem_endpoint_UU
                          (to_free_alg_endpoint al)
                          free_alg_point_constr
                          z
                        =
                        sem_endpoint_UU
                          (to_free_alg_endpoint ar)
                          free_alg_point_constr
                          z)
      : sem_homot_endpoint_UU
          (free_alg_signature_homot_endpoint h)
          _
          free_alg_point_constr
          (path_alg_path make_free_alg_path_algebra)
          z
          p_arg
        =
        !(free_alg_sem_endpoint_UU _ free_alg_point_constr z)
        @ sem_homot_endpoint_UU
            h
            (alg_carrier X)
            (alg_constr X)
            (alg_path X)
            z
            (free_alg_sem_endpoint_UU _ free_alg_point_constr _
             @ p_arg
             @ !(free_alg_sem_endpoint_UU _ free_alg_point_constr _))
        @ free_alg_sem_endpoint_UU _ free_alg_point_constr _.
    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
                      | P R e₁ e₂ | P R e₁ e₂
                      | T₁ T₂ e₁ e₂ e₃ e₄ h₁ IHh₁ h₂ IHh₂
                      | P₁ P₂ P₃ e₁ e₂ e₃
                      | Z x T e | j e | ].
      - (** identity path *)
        simpl.
        exact (!(pathsinv0l _)).
      - (** inverse path *)
        simpl.
        etrans.
        {
          apply maponpaths.
          exact IHh.
        }
        etrans.
        {
          refine (pathscomp_inv _ _ @ _).
          apply maponpaths_2.
          apply pathscomp_inv.
        }
        refine (!(path_assoc _ _ _) @ _).
        do 2 apply maponpaths.
        apply pathsinv0inv0.
      - (** concatenation of paths *)
        simpl.
        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.
        do 2 refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        refine (_ @ pathscomp0lid _).
        apply maponpaths_2.
        apply pathsinv0r.
      - (** ap on paths *)
        simpl.
        etrans.
        {
          apply maponpaths.
          exact IHh.
        }
        clear IHh.
        etrans.
        {
          apply maponpathscomp0.
        }
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            apply homotsec_natural'.
          }
          apply pathscomp_inv.
        }
        refine (!(path_assoc _ _ _) @ _).
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply maponpathsinv0.
        }
        apply maponpaths.
        refine (maponpathscomp0 _ _ _ @ _).
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          apply homotsec_natural'.
        }
        refine (!_).
        do 2 refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        refine (_ @ path_assoc _ _ _).
        use path_inv_rotate_rl.
        refine (!_).
        apply homotsec_natural'.
      - (** associator *)
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            refine (maponpathscomp0 _ _ _ @ _).
            apply maponpaths_2.
            apply maponpathscomp.
          }
          exact (!(path_assoc _ _ _)).
        }
        apply pathsinv0l.
      - (** left unitor *)
        simpl.
        exact (!(pathsinv0l _)).
      - (** right unitor *)
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          refine (pathscomp0rid _ @_ ).
          apply maponpathsidfun.
        }
        exact (pathsinv0l _).
      - (** first projection *)
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths_2 ; apply maponpaths.
          refine (pathscomp0rid _ @ _).
          apply maponpaths_pr1_pathsdirprod.
        }
        exact (pathsinv0l _).
      - (** second projection *)
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths_2 ; apply maponpaths.
          refine (pathscomp0rid _ @ _).
          apply maponpaths_pr2_pathsdirprod.
        }
        exact (pathsinv0l _).
      - (** pairing *)
        simpl.
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_concat.
          }
          etrans.
          {
            apply maponpaths_2.
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        refine (!_).
        exact (paths_pathsdirprod IHh₁ IHh₂).
      - (** composition before pair *)
        simpl.
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths_2.
                apply maponpaths_prod_path.
              }
              apply pathsdirprod_concat.
            }
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        exact (paths_pathsdirprod (pathsinv0l _) (pathsinv0l _)).
      - (** composition with constant *)
        simpl.
        refine (!_).
        refine (pathscomp0rid _ @ _).
        etrans.
        {
          apply maponpaths.
          refine (pathscomp0rid _ @ _).
          apply maponpaths_for_constant_function.
        }
        apply idpath.
      - (** path constructor *)
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply pathscomp_inv.
        }
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        do 2 refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        refine (!(path_assoc _ _ _) @ _).
        use path_inv_rotate_ll.
        refine (!_).
        apply homotsec_natural'.
      - (** path argument *)
        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 make_free_alg_is_hit_algebra
      : is_hit_algebra_one_types free_alg_signature make_free_alg_path_algebra.
    Proof.
      intros j x p.
      simpl in p.
      refine (free_alg_sem_homot_endpoint_UU' _ _ _
              @ _
              @ !(free_alg_sem_homot_endpoint_UU' _ _ _)).
      apply maponpaths.
      apply maponpaths_2.
      apply (alg_homot X j x).
    Qed.

    Definition make_free_alg_algebra
      : hit_algebra_one_types free_alg_signature.
    Proof.
      use make_algebra.
      - exact make_free_alg_path_algebra.
      - exact make_free_alg_is_hit_algebra.
    Defined.
  End FreeAlgBuilder.

  Section FreeAlgMakeFreeAlg.
    Variable (X : hit_algebra_one_types Σ)
             (inc : A → alg_carrier X).

    Local Definition free_alg_is_alg_make_free_alg_algebra_prealg
      : pr11 (free_alg_is_alg (make_free_alg_algebra X inc)) --> pr11 X.
    Proof.
      use make_hit_prealgebra_mor.
      - exact (λ z, z).
      - exact (λ z,
               maponpaths
                 (alg_constr X)
                 (poly_id (point_constr Σ) (alg_carrier X) z)).
    Defined.

    Local Definition free_alg_to_make_free_alg_sem_endpoint
          {P Q : poly_code}
          (e : endpoint (point_constr Σ) P Q)
          (x : poly_act P (alg_carrier X))
      : sem_endpoint_UU_natural
          e
          (prealg_map_commute free_alg_is_alg_make_free_alg_algebra_prealg)
          x
        =
        !(poly_id _ _ _)
        @ maponpaths
            (sem_endpoint_UU e prealg_constr)
            (poly_id _ _ _).
    Proof.
      induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                      | P Q | P Q | P Q | P Q
                      | P Q R e₁ IHe₁ e₂ IHe₂
                      | P T t | C₁ C₂ g | ]
      ; simpl.
      - refine (!_).
        etrans.
        {
          apply maponpaths.
          apply maponpathsidfun.
        }
        apply pathsinv0l.
      - etrans.
        {
          apply maponpaths_2.
          apply IHe₂.
        }
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        etrans.
        {
          refine (!_).
          apply maponpathscomp0.
        }
        refine (!_).
        etrans.
        {
          refine (!_).
          apply maponpathscomp.
        }
        refine (!_).
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply IHe₁.
        }
        refine (path_assoc _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply pathsinv0r.
        }
        apply idpath.
      - exact (!(pathsinv0l _)).
      - exact (!(pathsinv0l _)).
      - refine (!_).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_pr1_pathsdirprod.
        }
        apply pathsinv0l.
      - refine (!_).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_pr2_pathsdirprod.
        }
        apply pathsinv0l.
      - refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            apply maponpaths_prod_path.
          }
          etrans.
          {
            apply maponpaths_2.
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        refine (!_).
        exact (paths_pathsdirprod (IHe₁ _) (IHe₂ _)).
      - exact (!(maponpaths_for_constant_function _ _)).
      - apply idpath.
      - apply idpath.
    Qed.

    Local Definition free_alg_is_alg_make_free_alg_algebra_preserves_path
      : preserves_path
          _
          (prealg_map_commute free_alg_is_alg_make_free_alg_algebra_prealg).
    Proof.
      intros j x.
      simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        exact (free_alg_to_make_free_alg_sem_endpoint (path_left Σ j) x).
      }
      simpl.
      etrans.
      {
        apply homotsec_natural'.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply maponpathsidfun.
      }
      etrans.
      {
        apply maponpaths.
        exact (free_alg_to_make_free_alg_sem_endpoint (path_right Σ j) x).
      }
      simpl.
      apply maponpaths_2.
      unfold alg_path ; simpl.
      etrans.
      {
        refine (path_assoc _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (path_assoc _ _ _ @ _).
          apply maponpaths_2.
          apply pathsinv0r.
        }
        simpl.
        refine (!(path_assoc _ _ _) @ _).
        etrans.
        {
          apply maponpaths.
          apply pathsinv0r.
        }
        apply pathscomp0rid.
      }
      apply idpath.
    Qed.

    Definition free_alg_is_alg_make_free_alg_algebra
      : free_alg_is_alg (make_free_alg_algebra X inc) --> X.
    Proof.
      use make_algebra_map.
      use make_hit_path_alg_map.
      - exact free_alg_is_alg_make_free_alg_algebra_prealg.
      - exact free_alg_is_alg_make_free_alg_algebra_preserves_path.
    Defined.

    Local Definition free_alg_is_alg_make_free_alg_algebra_prealg_inv
      : pr11 X --> pr11 (free_alg_is_alg (make_free_alg_algebra X inc)).
    Proof.
      use make_hit_prealgebra_mor.
      - exact (λ z, z).
      - exact (λ z,
               maponpaths
                 (alg_constr X)
                 (poly_id (point_constr Σ) (alg_carrier X) z)).
    Defined.

    Local Definition free_alg_is_alg_make_free_alg_algebra_preserves_path_inv
      : preserves_path
          _
          (prealg_map_commute free_alg_is_alg_make_free_alg_algebra_prealg_inv).
    Proof.
      intros j x.
      simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        exact (free_alg_to_make_free_alg_sem_endpoint (path_left Σ j) x).
      }
      simpl.
      unfold alg_path.
      simpl.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          do 2 (refine (path_assoc _ _ _ @ _) ; apply maponpaths_2).
          apply pathsinv0r.
        }
        simpl.
        refine (!(path_assoc _ _ _) @ _).
        etrans.
        {
          apply maponpaths.
          apply pathsinv0r.
        }
        apply pathscomp0rid.
      }
      simpl.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply maponpathsidfun.
      }
      etrans.
      {
        apply maponpaths.
        exact (free_alg_to_make_free_alg_sem_endpoint (path_right Σ j) x).
      }
      simpl.
      refine (!_).
      apply homotsec_natural'.
    Qed.

    Definition free_alg_is_alg_make_free_alg_algebra_inv
      : X --> free_alg_is_alg (make_free_alg_algebra X inc).
    Proof.
      use make_algebra_map.
      use make_hit_path_alg_map.
      - exact free_alg_is_alg_make_free_alg_algebra_prealg_inv.
      - exact free_alg_is_alg_make_free_alg_algebra_preserves_path_inv.
    Defined.
  End FreeAlgMakeFreeAlg.

  (** Projections of 1-cells *)
  Definition preserves_A
             {X Y : hit_algebra_one_types Σ}
             (f : X --> Y)
             (Xa : A → alg_carrier X)
             (Ya : A → alg_carrier Y)
    : UU
    := ∏ (a : A),
       alg_map_carrier f (Xa a) = Ya a.

  Section FreeAlgMapProjections.
    Context {X Y : hit_algebra_one_types free_alg_signature}
            (f : X --> Y).

    Definition free_alg_map_prealg_mor
      : pr11 (free_alg_is_alg X) --> pr11 (free_alg_is_alg Y).
    Proof.
      use make_hit_prealgebra_mor.
      - exact (alg_map_carrier f).
      - exact (λ x, alg_map_commute f (inl x)).
    Defined.

    Definition free_alg_map_preserves_path
      : preserves_path _ (prealg_map_commute free_alg_map_prealg_mor).
    Proof.
      intros j x.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply (free_alg_sem_endpoint_UU_natural' (path_right Σ j)).
      }
      simpl.
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          refine (!_).
          apply maponpathscomp0.
        }
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        etrans.
        {
          apply maponpaths.
          apply pathsinv0l.
        }
        apply pathscomp0rid.
      }
      refine (path_assoc _ _ _ @ _).
      do 2 refine (_ @ !(path_assoc _ _ _)).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply maponpathscomp0.
      }
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        exact (alg_map_path f j x).
      }
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply (free_alg_sem_endpoint_UU_natural' (path_left Σ j)).
      }
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      refine (_ @ pathscomp0rid _).
      apply maponpaths.
      apply pathsinv0l.
    Qed.

    Definition free_alg_map_alg_mor
      : free_alg_is_alg X --> free_alg_is_alg Y.
    Proof.
      use make_algebra_map.
      use make_hit_path_alg_map.
      - exact free_alg_map_prealg_mor.
      - exact free_alg_map_preserves_path.
    Defined.

    Definition free_alg_map_on_A
      : preserves_A
          free_alg_map_alg_mor
          (free_alg_inc X)
          (free_alg_inc Y)
      := λ a, alg_map_commute f (inr a).
  End FreeAlgMapProjections.

  Section FreeAlgMapBuilder.
    Context {X : hit_algebra_one_types free_alg_signature}
            {Y : hit_algebra_one_types Σ}
            (incY : A → alg_carrier Y)
            (f : free_alg_is_alg X --> Y)
            (Hf : preserves_A f (free_alg_inc X) incY).

    Definition make_free_alg_prealg_mor
      : pr11 X --> pr11 (make_free_alg_algebra Y incY).
    Proof.
      use make_hit_prealgebra_mor.
      - exact (alg_map_carrier f).
      - intro x.
        induction x as [x | x].
        + exact (alg_map_commute f x).
        + exact (Hf x).
    Defined.

    Definition make_free_alg_preserves_path
      : preserves_path _ (prealg_map_commute make_free_alg_prealg_mor).
    Proof.
      intros j x ; simpl.
      etrans.
      {
        apply maponpaths.
        apply (free_alg_sem_endpoint_UU_natural (path_right _ _)).
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply (free_alg_sem_endpoint_UU_natural (path_left _ _)).
      }
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths_2.
        apply maponpathsinv0.
      }
      use path_inv_rotate_ll.
      refine (!_).
      do 2 refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply maponpathscomp0.
        }
        etrans.
        {
          refine (!_).
          apply maponpathscomp0.
        }
        apply maponpaths.
        exact (!(path_assoc _ _ _)).
      }
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        exact (alg_map_path f j x).
      }
      refine (!(path_assoc _ _ _) @ _ @ path_assoc _ _ _).
      apply maponpaths.
      simpl.
      refine (!_).
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        apply pathsinv0r.
      }
      apply idpath.
    Qed.

    Definition make_free_alg_mor
      : X --> make_free_alg_algebra Y incY.
    Proof.
      pose Hf.
      use make_algebra_map.
      use make_hit_path_alg_map.
      - exact make_free_alg_prealg_mor.
      - exact make_free_alg_preserves_path.
    Defined.
  End FreeAlgMapBuilder.

  Section FreeAlgCellToComp.
    Context {X : hit_algebra_one_types free_alg_signature}
            {Y : hit_algebra_one_types Σ}
            (Yinc : A → alg_carrier Y)
            (f : free_alg_is_alg X --> Y)
            (Hf : preserves_A f (free_alg_inc X) Yinc).

    Definition free_alg_map_free_alg_is_make_free_alg_carrier
      : alg_map_carrier f
        ~
        alg_map_carrier
          (free_alg_map_alg_mor (make_free_alg_mor Yinc f Hf)
           · free_alg_is_alg_make_free_alg_algebra Y Yinc)
      := homotrefl _.

    Definition free_alg_map_free_alg_is_make_free_alg_is_algebra_2cell
      : is_algebra_2cell free_alg_map_free_alg_is_make_free_alg_carrier.
    Proof.
      intro x.
      cbn ; unfold homotcomp, homotfun, funhomotsec ; simpl.
      rewrite !pathscomp0rid.
      rewrite maponpathsidfun.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      rewrite <- maponpathscomp0.
      apply maponpaths.
      apply poly_id_comp.
    Qed.

    Definition free_alg_map_free_alg_is_make_free_alg
      : f
        ==>
        free_alg_map_alg_mor (make_free_alg_mor Yinc f Hf)
        · free_alg_is_alg_make_free_alg_algebra Y Yinc.
    Proof.
      use make_algebra_2cell.
      - exact free_alg_map_free_alg_is_make_free_alg_carrier.
      - exact free_alg_map_free_alg_is_make_free_alg_is_algebra_2cell.
    Defined.

    Definition free_alg_map_free_alg_is_make_free_alg_inv_carrier
      : alg_map_carrier (free_alg_map_alg_mor (make_free_alg_mor Yinc f Hf))
        ~
        alg_map_carrier (f · free_alg_is_alg_make_free_alg_algebra_inv Y Yinc)
      := homotrefl _.

    Definition free_alg_map_free_alg_is_make_free_alg_inv_is_algebra_2cell
      : is_algebra_2cell free_alg_map_free_alg_is_make_free_alg_inv_carrier.
    Proof.
      intro x.
      cbn ; unfold homotcomp, homotfun, funhomotsec ; simpl.
      rewrite !pathscomp0rid.
      rewrite maponpathsidfun.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      rewrite <- maponpathscomp0.
      apply maponpaths.
      apply poly_id_comp.
    Qed.

    Definition free_alg_map_free_alg_is_make_free_alg_inv
      : free_alg_map_alg_mor (make_free_alg_mor Yinc f Hf)
        ==>
        f · free_alg_is_alg_make_free_alg_algebra_inv Y Yinc.
    Proof.
      use make_algebra_2cell.
      - exact free_alg_map_free_alg_is_make_free_alg_inv_carrier.
      - exact free_alg_map_free_alg_is_make_free_alg_inv_is_algebra_2cell.
    Defined.
  End FreeAlgCellToComp.

  Definition alg_2cell_carrier_free_alg_map_free_alg_is_make_free_alg
             {X : hit_algebra_one_types free_alg_signature}
             {Y : hit_algebra_one_types Σ}
             (Yinc : A → alg_carrier Y)
             (f : free_alg_is_alg X --> Y)
             (Hf : preserves_A f (free_alg_inc X) Yinc)
    : alg_2cell_carrier (free_alg_map_free_alg_is_make_free_alg Yinc f Hf)
      =
      homotrefl _
    := idpath _.

  Definition alg_2cell_carrier_free_alg_map_free_alg_is_make_free_alg_inv
             {X : hit_algebra_one_types free_alg_signature}
             {Y : hit_algebra_one_types Σ}
             (Yinc : A → alg_carrier Y)
             (f : free_alg_is_alg X --> Y)
             (Hf : preserves_A f (free_alg_inc X) Yinc)
    : alg_2cell_carrier (free_alg_map_free_alg_is_make_free_alg_inv Yinc f Hf)
      =
      homotrefl _
    := idpath _.

  (** Projections of 2-cells *)
  Section FreeAlgCellProjections.
    Context {X Y : hit_algebra_one_types free_alg_signature}
            {f g : X --> Y}
            (τ : f ==> g).

    Definition free_alg_cell_alg_cell
      : free_alg_map_alg_mor f ==> free_alg_map_alg_mor g.
    Proof.
      use make_algebra_2cell.
      - exact (alg_2cell_carrier τ).
      - abstract
          (intro x ;
           cbn in x ;
           refine (alg_2cell_commute τ (inl x) @ _) ; simpl ;
           apply maponpaths ;
           apply maponpathscomp).
    Defined.

    Definition free_alg_cell_on_A
               (a : A)
      : alg_2cell_carrier τ (alg_constr X (inr a)) @ alg_map_commute g (inr a)
        =
        alg_map_commute f (inr a).
    Proof.
      exact (alg_2cell_commute τ (inr a) @ pathscomp0rid _).
    Qed.
  End FreeAlgCellProjections.

  (** Builder of 2-cells *)
  Section FreeAlgCellBuilder.
    Context {X Y : hit_algebra_one_types free_alg_signature}
            {f g : X --> Y}
            (τ : free_alg_map_alg_mor f ==> free_alg_map_alg_mor g)
            (Hτ : ∏ (a : A),
                  alg_2cell_carrier τ (alg_constr X (inr a)) @ alg_map_commute g (inr a)
                  =
                  alg_map_commute f (inr a)).

    Definition make_free_alg_cell
      : f ==> g.
    Proof.
      use make_algebra_2cell.
      - exact (alg_2cell_carrier τ).
      - abstract
          (intros x ;
           induction x as [x | x] ;
           [ refine (alg_2cell_commute τ x @ _) ; simpl ;
             apply maponpaths ;
             refine (!_) ;
             apply (maponpathscomp inl)
           | simpl ;
             exact (Hτ x @ !(pathscomp0rid _))]).
    Defined.
  End FreeAlgCellBuilder.

  (** Mapping principles of free algebra *)
  Section FreeAlgMapping.
    Variable (X : hit_algebra_one_types free_alg_signature)
             (HX : is_initial _ X).

    (** Mapping principle for 1-cells *)
    Section FreeAlgMapUMPOne.
      Variable (Y : hit_algebra_one_types Σ)
               (Yinc : A → alg_carrier Y).

      Definition free_alg_ump_1_free_alg_map
        : X --> make_free_alg_algebra Y Yinc
        := is_biinitial_1cell_property
             HX
             (make_free_alg_algebra Y Yinc).

      Definition free_ump_1
        : free_alg_is_alg X --> Y
        := free_alg_map_alg_mor free_alg_ump_1_free_alg_map
           · free_alg_is_alg_make_free_alg_algebra Y Yinc.

      Definition free_alg_one_cell_on_A
                 (a : A)
        : alg_map_carrier free_alg_ump_1_free_alg_map (free_alg_inc X a)
          =
          Yinc a
        := free_alg_map_on_A free_alg_ump_1_free_alg_map a.
    End FreeAlgMapUMPOne.

    (** Mapping principle for 2-cells. *)
    Section FreeAlgMapUMPTwo.
      Variable (Y : hit_algebra_one_types Σ)
               (Yinc : A → alg_carrier Y)
               (f g : free_alg_is_alg X --> Y)
               (Hf : preserves_A f (free_alg_inc X) Yinc)
               (Hg : preserves_A g (free_alg_inc X) Yinc).

      Definition free_alg_ump_2_alg_cell
        : make_free_alg_mor Yinc f Hf ==> make_free_alg_mor Yinc g Hg
        := @is_biinitial_2cell_property
             _ _
             HX
             (make_free_alg_algebra Y Yinc)
             (make_free_alg_mor Yinc f Hf)
             (make_free_alg_mor Yinc g Hg).

      Definition free_alg_ump_2
        : f ==> g
        := free_alg_map_free_alg_is_make_free_alg Yinc f Hf
           • (free_alg_cell_alg_cell free_alg_ump_2_alg_cell
              ▹ free_alg_is_alg_make_free_alg_algebra Y Yinc)
           • (hit_alg_is_invertible_2cell_one_type
                Σ
                (free_alg_map_free_alg_is_make_free_alg Yinc g Hg))^-1.

      Definition free_alg_ump_2_on_A
                 (a : A)
        : alg_2cell_carrier free_alg_ump_2 (alg_constr X (inr a))
          @ Hg a
          =
          Hf a.
      Proof.
        unfold free_alg_ump_2.
        rewrite !alg_2cell_vcomp.
        unfold homotcomp.
        etrans.
        {
          do 3 apply maponpaths_2.
          exact (eqtohomot
                   (alg_2cell_carrier_free_alg_map_free_alg_is_make_free_alg
                      Yinc f Hf) _).
        }
        unfold homotrefl.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply pathscomp0lid.
        }
        etrans.
        {
          do 2 apply maponpaths_2.
          exact (eqtohomot
                   (alg_2cell_rwhisker
                      (free_alg_cell_alg_cell free_alg_ump_2_alg_cell)
                      (free_alg_is_alg_make_free_alg_algebra Y Yinc))
                   _).
        }
        etrans.
        {
          do 2 apply maponpaths_2.
          apply maponpathsidfun.
        }
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          exact (eqtohomot
                   (alg_2cell_inv
                      (free_alg_map_free_alg_is_make_free_alg Yinc g Hg))
                   _).
        }
        unfold invhomot.
        etrans.
        {
          apply maponpaths_2.
          do 2 apply maponpaths.
          exact (eqtohomot
                   (alg_2cell_carrier_free_alg_map_free_alg_is_make_free_alg
                      Yinc g Hg)
                   _).
        }
        unfold homotrefl.
        etrans.
        {
          apply maponpaths_2.
          apply pathscomp0rid.
        }
        refine (alg_2cell_commute free_alg_ump_2_alg_cell (inr a) @ _) ; simpl.
        apply pathscomp0rid.
      Qed.
    End FreeAlgMapUMPTwo.

    (** Mapping principles for equalities *)
    Local Definition free_alg_ump_eq_help_cell
          (Y : hit_algebra_one_types Σ)
          (Yinc : A → alg_carrier Y)
          (f g : free_alg_is_alg X --> Y)
          (Hf : preserves_A f (free_alg_inc X) Yinc)
          (Hg : preserves_A g (free_alg_inc X) Yinc)
          (τ : f ==> g)
          (Hτ : ∏ (a : A),
                alg_2cell_carrier τ (alg_constr X (inr a)) @ Hg a
                =
                Hf a)
      : make_free_alg_mor Yinc f Hf ==> make_free_alg_mor Yinc g Hg.
    Proof.
      simple refine
             (@make_free_alg_cell
                X
                (make_free_alg_algebra Y Yinc)
                (make_free_alg_mor Yinc f Hf)
                (make_free_alg_mor Yinc g Hg)
                (free_alg_map_free_alg_is_make_free_alg_inv Yinc f Hf
                 • (τ ▹ free_alg_is_alg_make_free_alg_algebra_inv Y Yinc)
                 • ((hit_alg_is_invertible_2cell_one_type
                       Σ
                       (free_alg_map_free_alg_is_make_free_alg_inv Yinc g Hg))^-1))
                _).
      abstract
        (intro a ;
         cbn ;
         unfold homotcomp, invhomot, homotfun ;
         cbn ;
         rewrite pathscomp0rid ;
         rewrite maponpathsidfun ;
         exact (Hτ a)).
    Defined.

    Local Definition alg_2cell_carrier_free_alg_ump_eq_help_cell
          (Y : hit_algebra_one_types Σ)
          (Yinc : A → alg_carrier Y)
          (f g : free_alg_is_alg X --> Y)
          (Hf : preserves_A f (free_alg_inc X) Yinc)
          (Hg : preserves_A g (free_alg_inc X) Yinc)
          (τ : f ==> g)
          (Hτ : ∏ (a : A),
                alg_2cell_carrier τ (alg_constr X (inr a)) @ Hg a
                =
                Hf a)
          (x : alg_carrier X)
      : alg_2cell_carrier
          (free_alg_ump_eq_help_cell Y Yinc f g Hf Hg τ Hτ)
          x
        =
        alg_2cell_carrier τ x.
    Proof.
      unfold free_alg_ump_eq_help_cell.
      cbn.
      unfold homotcomp, invhomot, homotfun.
      rewrite maponpathsidfun.
      unfold free_alg_map_free_alg_is_make_free_alg_inv_carrier ; cbn.
      apply pathscomp0rid.
    Qed.

    Section FreeAlgMapUMPEq.
      Variable (Y : hit_algebra_one_types Σ)
               (Yinc : A → alg_carrier Y)
               (f g : free_alg_is_alg X --> Y)
               (Hf : preserves_A f (free_alg_inc X) Yinc)
               (Hg : preserves_A g (free_alg_inc X) Yinc)
               (τ θ : f ==> g)
               (Hτ : ∏ (a : A),
                     alg_2cell_carrier τ (alg_constr X (inr a)) @ Hg a
                     =
                     Hf a)
               (Hθ : ∏ (a : A),
                     alg_2cell_carrier θ (alg_constr X (inr a)) @ Hg a
                     =
                     Hf a).

      Definition free_alg_ump_eq
        : τ = θ.
      Proof.
        use algebra_2cell_eq.
        intro x.
        pose (@is_biinitial_eq_property
                _ _ HX
                (make_free_alg_algebra Y Yinc)
                (make_free_alg_mor Yinc f Hf)
                (make_free_alg_mor Yinc g Hg)
                (free_alg_ump_eq_help_cell Y Yinc f g Hf Hg τ Hτ)
                (free_alg_ump_eq_help_cell Y Yinc f g Hf Hg θ Hθ))
          as p₁.
        pose (alg_2cell_eq_component p₁ x) as p₂.
        refine (!_ @ p₂ @ _).
        - apply alg_2cell_carrier_free_alg_ump_eq_help_cell.
        - apply alg_2cell_carrier_free_alg_ump_eq_help_cell.
      Qed.
    End FreeAlgMapUMPEq.
  End FreeAlgMapping.
End FreeAlg.

Arguments free_ump_1 {_ _ _} _ _ _.
Arguments free_alg_ump_2 {_ _ _} _ _ _ _ _ _.
Arguments free_alg_ump_eq {_ _ _} _ _ _ _ _ _ _ _ _ _ _.

Arguments preserves_A {_ _ _ _} _ _ _.
Arguments free_alg_is_alg {_ _} _.
Arguments free_alg_inc {_ _} _ _.
Arguments free_alg_one_cell_on_A {_ _ _} _ _ _ _.
Arguments free_alg_ump_2_on_A {_ _ _} _ _ _ {_ _} _ _ _.


Section ProofSystem.

Require Import Syntax.
Require Import Coq.Arith.EqNat.

(************************************************************************************)
(*              Move all formulas into the belief space of a term.                  *)
(************************************************************************************)
Function relativize (p : term) (Gamma : list formula) {struct Gamma}: list formula :=
  map (fun psi => (Says p psi)) Gamma.

(************************************************************************************)
(* Proves is the heart of the proof theory. Proves describes when a FOCALE formula can *)
(* be proven given some assumed FOCALE formulas. We write Gamma |- phi if FOCALE formula  *)
(*     phi can be proven by assuming ALL of the focale formulas in the set Gamma.      *)
(************************************************************************************)

Inductive proves : list formula -> formula -> Prop :=
  (* Hypothesis: We can prove something that is assumed. *)
  hyp : forall (Gamma : list formula) (phi : formula),
    In phi Gamma
    -> proves Gamma phi
  (* We can always prove that something is true. *)
| trueI : forall (Gamma : list formula),
    proves Gamma FocalTrue
  (* If we assume falsity, then we can prove anything. *)
| falseE : forall (Gamma : list formula) (phi : formula),
    proves Gamma FocalFalse
    -> proves Gamma phi
  (* If we can prove both phi and psi, we can prove phi /\ psi. *)
| andI : forall (Gamma : list formula) (phi : formula) (psi : formula),
    proves Gamma phi -> proves Gamma psi
    -> proves Gamma (And phi psi)
  (* If we can prove phi /\ psi, we can prove phi. *)
| andE1 : forall (Gamma : list formula) (phi : formula) (psi : formula),
    proves Gamma (And phi psi)
    -> proves Gamma phi
  (* If we can prove phi /\ psi, we can prove psi. *)
| andE2 : forall (Gamma : list formula) (phi : formula) (psi : formula),
    proves Gamma (And phi psi)
    -> proves Gamma psi
  (* If we can prove phi, we can prove phi \/ psi *)
| orI1 : forall (Gamma : list formula) (phi : formula) (psi : formula),
    proves Gamma phi
    -> proves Gamma (Or phi psi)
  (* If we can prove psi, we can prove phi \/ psi *)
| orI2 : forall (Gamma : list formula) (phi : formula) (psi : formula),
    proves Gamma psi
    -> proves Gamma (Or phi psi)
  (* If we can prove A \/ B, and assuming either A or B proves C, we can prove C *)
| orE: forall (Gamma : list formula) (phi1 : formula) (phi2 : formula) (psi : formula),
    proves Gamma (Or phi1 phi2)
       -> proves (phi1::Gamma) psi
       -> proves (phi2::Gamma) psi
    -> proves Gamma psi
  (* If assuming phi along with the other assumptions in Gamma proves psi, then *)
  (* assuming Gamma proves phi -> psi. *)
| impI : forall (Gamma : list formula) (phi : formula) (psi : formula),
    proves (phi::Gamma) psi
    -> proves Gamma (Implies phi psi)
  (* If we can prove phi and phi -> psi, we can prove psi. *)
| impE : forall (Gamma : list formula) (phi : formula) (psi : formula),
    proves Gamma phi -> proves Gamma (Implies phi psi)
    -> proves Gamma psi
  (* If we can prove that phi is true, and phi has some variable x not free in *)
  (* it, then we've proven phi for all x. *)
| forallI : forall (Gamma : list formula) (phi : formula) (x : var),
    proves Gamma phi -> is_true(notfree x Gamma)
    -> proves Gamma (Forall x phi)
  (* If we can prove that phi is true for all x, then  we can substitute any *)
  (* term for x. *)
| forallE : forall (Gamma : list formula) (phi : formula) (x : var) (tau : term),
    proves Gamma (Forall x phi)
    -> proves Gamma (subst x tau phi)
  (* If we can substitute some term for x in phi, then we can prove that there *)
  (* exists an x such that phi. *)
| existsI : forall (Gamma : list formula) (phi : formula) (x : var) (tau : term),
    proves Gamma (subst x tau phi)
    -> proves Gamma (Exists x phi)
  (* If we can prove that there is an x such that phi, and from assuming phi we *)
  (* can prove psi, where x is not free in any of psi or gamma, then we can *)
  (* prove psi from gamma. *)
| existsE : forall (Gamma : list formula) (phi : formula) (x : var) (psi : formula),
    proves Gamma (Exists x phi)
      -> proves (phi::Gamma) psi
      -> is_true(notfree x (psi::Gamma))
    -> proves Gamma psi
  (* If we can prove phi from assumptions Gamma, we can prove that p says phi *)
  (* if we can assume that p says everything in Gamma. In other words, the belief *)
  (* space of a principal is closed under deduction. *)
| saysILR : forall (Gamma : list formula) (p : term) (phi : formula),
    proves Gamma phi
    -> proves (relativize p Gamma) (Says p phi)
  (* If we can prove phi from the assumption that P says everything in Gamma, *)
  (* then we can prove that p says phi from the same assumption. In other words, *)
  (* all principals are introspective. This allows us to prove p says p says phi.*)
| saysIR :  forall (Gamma : list formula) (p : term) (phi : formula),
    proves (relativize p Gamma) phi
    -> proves (relativize p Gamma) (Says p phi)
  (* If we can prove that p says phi from Gamma, we can prove the same from *)
  (* the assumption that p says everything in Gamma. This allows us to prove *)
  (* {p says phi->psi, p says (p says phi)} |- p says psi *)
| saysIL :  forall (Gamma : list formula) (p : term) (phi : formula),
    proves Gamma (Says p phi)
    -> proves (relativize p Gamma) (Says p phi)
  (* We can always prove that a term equals itself. *)
| eqRefl : forall (Gamma : list formula) (tau : term),
  proves Gamma (Eq tau tau)
  (* If we can prove that two terms are equal, we can prove it in either direction. *)
| eqSymm : forall (Gamma : list formula) (tau1 tau2 : term),
  proves Gamma (Eq tau1 tau2)
  -> proves Gamma (Eq tau2 tau1)
  (* If we can prove that A = B, and B = C, then we can prove that A = C. *)
| eqTrans : forall (Gamma : list formula) (tau1 tau2 tau3 : term),
  proves Gamma (Eq tau1 tau2) -> proves Gamma (Eq tau2 tau3)
  -> proves Gamma (Eq tau1 tau3)
  (* Functions cannot distinguish between equal arguments. *)
| eqIndF : forall (Gamma : list formula) (f : fn) (taus taus' : list term),
   taus = taus'
  -> proves Gamma (Eq (Fun_t f taus) (Fun_t f taus'))
  (* Relations cannot distinguish between equal tuples. *)
| eqIndR : forall (Gamma : list formula) (r : rel) (taus taus' : list term),
  taus = taus'
  -> proves Gamma (Rel_f r taus) -> proves Gamma (Rel_f r taus')
  (* A principal always speaks correctly about another speaking for them. *)
| handOff : forall (Gamma : list formula) (tau1 tau2 : term),
  proves Gamma (Says tau2 (Speaksfor tau1 tau2))
  -> proves Gamma (Speaksfor tau1 tau2)
  (* A principal always speaks correctly about another speaking for them about *)
  (* restricted statements. *)
| speaksSays : forall (Gamma : list formula)(tau1 tau2 : term)(phi : formula),
  proves Gamma (Speaksfor tau1 tau2) -> proves Gamma (Says tau1 phi)
  -> proves Gamma (Says tau2 phi)
  (* Same as above, but for restricted statement forms. *)
| speaksForRefl : forall (Gamma : list formula)(tau : term),
  proves Gamma (Speaksfor tau tau)
  (* A term always speaks for itself for all statement forms. *)
| speaksForTrans : forall (Gamma : list formula)(tau1 tau2 tau3 : term),
  proves Gamma (Speaksfor tau1 tau2) -> proves Gamma (Speaksfor tau2 tau3)
  -> proves Gamma (Speaksfor tau1 tau3).
(************************************************************************************)
(*  Since we're representing environments with lists instead of some kind of set,   *)
(*   we need to axiomatize what one can do with the elements of an environment---   *)
(*      namely, that they behave like elements of a set.  These axioms attempt      *)
(*               to do so.  We haven't really tested them, though.                 *)
(************************************************************************************)
Axiom env_reorder : forall (gamma : list formula) (P a1 a2 : formula), proves (a1::a2::gamma) P -> proves (a2::a1::gamma) P.
Axiom env_cons : forall (gamma : list formula) (P a1 : formula), proves gamma P -> proves (a1::gamma) P.
Axiom env_unique : forall (gamma : list formula) (P a1 : formula), proves (a1::gamma) P -> proves (a1::a1::gamma) P.

End ProofSystem.


Lemma new_lemma : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = map f l1 ++ (map f l2).
Proof.
  intros.
  induction l1 as [| h1 t1 IH1].
  - reflexivity.
  - simpl. rewrite -> IH1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros.
  induction l as [| h t IH].
  - simpl. reflexivity.
  - simpl. rewrite -> new_lemma.
    simpl. rewrite -> IH.
    reflexivity.
Qed.


(** MacBook-Air:08chapt billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqc -verbose months.v
Definition admit {T: Type} : T.
Admitted.
Inductive month : Type :=
  | january : month
  | february : month
  | march : month
  | april : month
  | may : month
  | june : month
  | july : month
  | august : month
  | september : month
  | october : month
  | november : month
  | december : month.
Definition next_month (m:month) : month :=
  match m with
  | january    => february
  | february   => march
  | march      => april
  | april       => may
  | may         => june
  | june        => july
  | july        => august
  | august      => september
  | september   => october
  | october     => november
  | november    => december
  | december    => january
  end.
Eval compute in (next_month april).
     = may
     : month
Eval compute in (next_month (next_month may)).
     = july
     : month
Example test_next_month:
  (next_month (next_month may)) = july.
Proof.
simpl.
reflexivity.
Qed.
MacBook-Air:08chapt billw$ *)

Definition admit {T: Type} : T.  Admitted.

Inductive month : Type :=
  | january : month
  | february : month
  | march : month
  | april : month
  | may : month
  | june : month
  | july : month
  | august : month
  | september : month
  | october : month
  | november : month
  | december : month.

Definition next_month (m:month) : month :=
  match m with
  | january    => february
  | february   => march
  | march      => april
  | april       => may
  | may         => june
  | june        => july
  | july        => august
  | august      => september
  | september   => october
  | october     => november
  | november    => december
  | december    => january
  end.

  Eval compute in (next_month april).
     (* ==> may : month *)
  Eval compute in (next_month (next_month may)).
     (* ==> june : month *)

Example test_next_month:
  (next_month (next_month may)) = july.

Proof. simpl. reflexivity.  Qed.


Require Import domains.
Require Import String.
Require Import List.
Require Import NPeano.

Inductive item_rep : Set :=
  | item (k v : nat)
  | submap (m : nat)
  .
Inductive map_rep : Set :=
  | empty
  | join (l r : map_rep)
  | atom (a : item_rep)
  .

Definition interp_item {K V} keys values submaps (i : item_rep) : Map K V :=
  match i with
    | item k v =>
      match nth_error keys k, nth_error values v with
        | Some k, Some v => k |-> v
        | _, _ => mapEmpty
      end
    | submap m =>
      match nth_error submaps m with
        | Some m => m
        | _ => mapEmpty
      end
  end.

Definition interp {K V} keys values submaps : map_rep -> Map K V :=
  fix eval m := match m with
    | empty => mapEmpty
    | join l r => eval l :* eval r
    | atom a => interp_item keys values submaps a
  end.

Definition mapEq {K V} keys values (submaps : list (Map K V)) ml mr : Prop :=
     interp keys values submaps ml
  ~= interp keys values submaps mr.

Fixpoint merge {A} (lt : A -> A -> bool) (l1 l2 : list A) : list A :=
  match l1 with
    | nil => l2
    | (cons v1 l1') =>
      (fix scan l2 :=
         match l2 with
           | nil => l1
           | cons v2 l2' =>
             if lt v1 v2
             then cons v1 (merge lt l1' l2)
             else cons v2 (scan l2')
         end) l2
  end.

Definition test1 : merge NPeano.ltb (cons 1 (cons 3 (cons 4 nil))) (cons 0 (cons 2 (cons 5 nil)))
                    = cons 0 (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 nil)))))
                           := eq_refl _.

Fixpoint removeMatches' {A} (cmp : A -> A -> comparison) (l1 l2 l1_acc l2_acc : list A) : (list A * list A) :=
  match l1 with
    | nil => (rev l1_acc, rev_append l2_acc l2)
    | (cons v1 l1') =>
      (fix scan l2 l2_acc {struct l2} :=
         match l2 with
           | nil => (rev_append l1_acc l1, rev l2_acc)
           | cons v2 l2' =>
             match cmp v1 v2 with
               | Lt => removeMatches' cmp l1' l2 (v1::l1_acc) l2_acc
               | Eq => removeMatches' cmp l1' l2' l1_acc l2_acc
               | Gt => scan l2' (v2::l2_acc)
             end
         end) l2 l2_acc
  end.

Definition removeMatches {A} cmp (l1 l2 : list A) := removeMatches' cmp l1 l2 nil nil.

Definition test2 :
  removeMatches Nat.compare (cons 1 (cons 3 (cons 4 nil))) (cons 0 (cons 1 (cons 2 (cons 4 nil))))
  = (cons 3 nil, cons 0 (cons 2 nil)) := eq_refl _.

Definition item_lt (i1 i2 : item_rep) : bool :=
  match i1, i2 with
    | item k v, item k2 v2 =>
      orb (ltb k k2) (andb (Nat.eqb k k2) (ltb v v2))
    | item _ _, submap _ => true
    | submap _, item _ _ => false
    | submap m, submap m2 => ltb m m2
  end.
Definition item_cmp (i1 i2 : item_rep) : comparison :=
  match i1, i2 with
    | item k v, item k2 v2 =>
      match Nat.compare k k2 with
        | Eq => Nat.compare v v2
        | o => o
      end
    | item _ _, submap _ => Lt
    | submap _, item _ _ => Gt
    | submap m, submap m2 => Nat.compare m m2
  end.

Lemma item_cmp_prop : forall i1 i2, item_cmp i1 i2 = Eq -> i1 = i2.
Proof.
destruct i1;destruct i2;simpl;unfold Nat.compare;
repeat match goal with [|-context [Compare_dec.nat_compare ?x ?y]] =>
                   destruct (Compare_dec.nat_compare_spec x y) end;
congruence.
Qed.

Definition joins (l : list map_rep) := fold_right join empty l.
Fixpoint canonicalize (m : map_rep) : list item_rep :=
  match m with
    | empty => nil
    | join l r => merge item_lt (canonicalize l) (canonicalize r)
    | atom a => cons a nil
  end.

Section Equivalence.
  Variables K V : Type.
  Variable keys : list K.
  Variable values : list V.
  Variable submaps : list (Map K V).

  Local Notation int := (interp keys values submaps).

  Lemma merge_join {A} (lt : A -> A -> bool) (f : A -> map_rep) (l1 l2 : list A) :
    int (joins (map f (merge lt l1 l2)))
        ~= int (join (joins (map f l1)) (joins (map f l2))).

  revert l2; induction l1; intro; simpl.
  rewrite equivUnitL; reflexivity.
  induction l2; simpl.
  rewrite equivUnit; reflexivity.
  destruct (lt a a0); simpl.
  rewrite IHl1; simpl; equate_maps.
  rewrite IHl2; equate_maps.
  Qed.

  Lemma canon_equiv : forall m, int m ~= int (joins (map atom (canonicalize m))).
  Proof.
    induction m;simpl;rewrite ?equivUnit, ?equivUnitL; try reflexivity.
    rewrite IHm1, IHm2, merge_join. reflexivity.
  Qed.

  Lemma app_equiv l1 l2 : int (joins (l1 ++ l2)) ~= int (joins l1) :* int (joins l2).
    induction l1.
    simpl; rewrite equivUnitL; reflexivity.
    simpl; rewrite IHl1, equivAssoc; reflexivity.
  Qed.

  Section RemoveEquiv.
    Variable m1 m2 : map_rep. (* Need a rest of map to make this flexible enough *)

  Local Notation build_equiv l1 l2 := (int (joins (m1 :: map atom l1)) ~= int (joins (m2 :: map atom l2))).

  Lemma removeEquivSubmaps (l1 l2 l1_acc l2_acc : list item_rep) :
    match removeMatches' item_cmp l1 l2 l1_acc l2_acc with
      | (l1', l2') => build_equiv l1' l2'
    end ->
    build_equiv (rev_append l1_acc l1) (rev_append l2_acc l2).
  revert l1_acc l2 l2_acc;induction l1.
  simpl; intros; rewrite <- rev_alt; assumption.
  induction l2.
  simpl; intros; rewrite <- rev_alt; assumption.
  intros; simpl in * |- *.
  destruct (item_cmp a a0) eqn:Hcmp.
  (* Both step? *)
  Focus 3.
  (* Gt -> use inner IH *)
  apply (IHl2 (a0 :: l2_acc)).
  apply H.
  (* Eq -> goes back to outer IH, with thing dropped *)
  specialize (IHl1 _ _ _ H); clear -Hcmp IHl1.
    (* rearranging. *)
    apply item_cmp_prop in Hcmp. subst a.
    rewrite !rev_append_rev, !map_app, !app_equiv in IHl1 |- *.
    simpl.
    repeat rewrite (equivComAssoc _ (interp_item _ _ _ a0) _).
    rewrite IHl1. reflexivity.
  (* Lt -> use outer IH? *)
  apply IHl1 with (l1_acc := (a :: l1_acc)).
  assumption.
  Qed.
  End RemoveEquiv.

  Lemma reduce_equiv (rep1 rep2 : map_rep) :
    match removeMatches item_cmp (canonicalize rep1) (canonicalize rep2) with
      | (items1, items2) =>
        int (joins (map atom items1)) ~= int (joins (map atom items2))
    end
    -> int rep1 ~= int rep2.
  Proof.
    unfold removeMatches; intros.
    rewrite (canon_equiv rep1), (canon_equiv rep2).
    setoid_rewrite <- equivUnitL.
    change (int (joins (empty :: map atom (rev_append nil (canonicalize rep1))))
         ~= int (joins (empty :: map atom (rev_append nil (canonicalize rep2))))).
    apply removeEquivSubmaps.
    destruct (removeMatches' item_cmp (canonicalize rep1)
         (canonicalize rep2) nil nil).
    simpl; rewrite H; reflexivity.
  Qed.
End Equivalence.

Definition test3 : forall (k1 k2 : string) (v1 v2 : nat) (m1 : Map string nat),
                     k1 |-> v1 :* m1 :* k2 |-> v2 ~= m1 :* k2 |-> v2 :* k1 |-> v1.
Proof.
intros.
change
  (interp (k1 :: k2 :: nil) (v1 :: v2 ::nil) (m1 :: nil)
        (join (atom (item 0 0)) (join (atom (submap 0)) (atom (item 1 1))))
     ~=
  interp (k1 :: k2 :: nil) (v1 :: v2 ::nil) (m1 :: nil)
        (join (atom (submap 0)) (join (atom (item 1 1)) (atom (item 0 0))))).
apply reduce_equiv.
simpl.
reflexivity.
Qed.

Ltac inList x xs :=
  match xs with
      | nil => false
      | x :: _ => true
      | _ :: ?xs' => inList x xs'
  end.
Ltac insert x xs :=
  match inList x xs with
    | true => xs
    | false => constr:(x :: xs)
  end.
Ltac index x xs :=
  match xs with
    | (x :: _) => constr:0
    | (?x' :: ?xs) => let ix := index x xs in constr:(S ix)
  end.
Ltac gatherKeys gathered t :=
  match t with
    | ?l :* ?r => let gathered' := gatherKeys gathered l in gatherKeys gathered' r
    | (?k |-> _) => insert k gathered
    | _ => gathered
  end.
Ltac gatherValues gathered t :=
  match t with
    | ?l :* ?r => let gathered' := gatherValues gathered l in gatherValues gathered' r
    | (_ |-> ?v) => insert v gathered
    | _ => gathered
  end.
Ltac gatherSubmaps gathered t :=
  match t with
    | ?l :* ?r => let gathered' := gatherSubmaps gathered l in gatherSubmaps gathered' r
    | (_ |-> ?v) => gathered
    | ?m => insert m gathered
  end.

Ltac quoteMap ks vs ms t :=
  match t with
    | (@mapEmpty _ _) => empty
    | ?l :* ?r =>
      let repl := quoteMap ks vs ms l in
      let repr := quoteMap ks vs ms r in
      constr:(join repl repr)
    | ?k |-> ?v =>
      let repk := index k ks in
      let repv := index v vs in
      constr:(atom (item repk repv))
    | ?m =>
      let repm := index m ms in
      constr:(atom (submap repm))
  end.
Ltac quote_map_equation := match goal with
    [|- @MapEquiv ?K ?V ?l ?r ] =>
    let ks := gatherKeys (@nil K) l in
    let ks := gatherKeys ks r in
    let vs := gatherValues (@nil V) l in
    let vs := gatherValues vs r in
    let ms := gatherSubmaps (@nil (Map K V)) l in
    let ms := gatherSubmaps ms r in
    let repl := quoteMap ks vs ms l in
    let repr := quoteMap ks vs ms r in
    change (interp ks vs ms repl ~= interp ks vs ms repr)
end.

Definition test4 : forall (k1 k2 : string) (v1 v2 : nat) (m1 : Map string nat),
                     k1 |-> v1 :* m1 :* k2 |-> v2 ~= m1 :* k2 |-> v2 :* k1 |-> v1.
Proof.
intros.
quote_map_equation.
apply reduce_equiv.
simpl.
reflexivity.
Qed.

Ltac map_simpl := quote_map_equation;apply reduce_equiv;simpl.

Require Import kstyle.
Require Import ZArith.
Coercion EVar : string >-> Exp.
Coercion ECon : Z >-> Exp.

Ltac name_evars t :=
  match t with
    | ?l ~= ?r => name_evars l; name_evars r
    | ?l :* ?r => name_evars l; name_evars r
    | ?k |-> ?v => name_evars k; name_evars v
    | ?m => try (is_evar m;set m)
  end.


(** * Example: Rutten's stream calculus *)

Require Import Psatz.
From Coinduction Require Import tower rel tactics.
Set Implicit Arguments.

Module streams.

 (** we consider streams of natural numbers, for the sake of simplicity *)
 CoInductive S := cons(n: nat)(q: S).

 Definition hd (s: S) := let 'cons n _ := s in n.
 Definition tl (s: S) := let 'cons _ q := s in q.

 (** the following function characterises (extensional) equality of streams *)
 Program Definition b: mon (S -> S -> Prop) :=
   {| body R s t := hd s = hd t /\ R (tl s) (tl t) |}.
 Next Obligation. firstorder. Qed.

 (** associated relation *)
 Infix "~" := (gfp b) (at level 70).

 (** notations  for easing readability in proofs by enhanced coinduction *)
 Infix "[~]" := (`_) (at level 70).
 Infix "{~}" := (b `_) (at level 70).

 (** elements of the final chain are equivalence relations *)
 #[export] Instance Equivalence_t {R: Chain b}: Equivalence `R.
 Proof.
   constructor; revert R.
   - apply Reflexive_chain. intros R HR x. now split.
   - apply Symmetric_chain. intros R HR x y []. now split; symmetry.
   - apply Transitive_chain. intros R HR x y z [] []. split. congruence. etransitivity; eauto.
 Qed.

 #[export] Instance hd_bisim: Proper (gfp b ==> eq) hd.
 Proof. intros x y H. apply (gfp_pfp b), H. Qed.

 #[export] Instance tl_bisim: Proper (gfp b ==> gfp b) tl.
 Proof. intros x y H. apply (gfp_pfp b), H. Qed.

 (** * "constant" streams *)
 CoFixpoint c n := cons n (c 0).

 (** * pointwise sum and its properties *)
 CoFixpoint plus s t := cons (hd s + hd t) (plus (tl s) (tl t)).
 Infix "+" := plus.

 Lemma plusC: forall x y, x + y ~ y + x.
 Proof.
   coinduction R HR. intros x y. split; simpl.
    lia.
    apply HR.
 Qed.

 Lemma plus_0x x: c 0 + x ~ x.
 Proof.
   revert x. coinduction R HR. intro x. split; simpl.
    reflexivity.
    apply HR.
 Qed.

 Lemma plusA: forall x y z, x + (y + z) ~ (x + y) + z.
 Proof.
   coinduction R HR. intros x y z. split; simpl.
    lia.
    apply HR.
 Qed.

 (** addition corresponds to a compatible function and preserves the final chain *)
 #[export] Instance plus_chain: forall {R: Chain b}, Proper (`R ==> `R ==> `R) plus.
 Proof.
   apply (Proper_chain 2).
   intros R HR x y [xy0 xy'] u v [uv0 uv'].
   split; cbn.
    congruence.
    now apply HR.
 Qed.

 (** * shuffle product *)
 (** shuffle product cannot be defined as easily as one could expect in Coq,
     because of the guard condition. Here we simply assume its existence for the sake of simplicity *)
 Parameter shuf: S -> S -> S.
 Infix "@" := shuf (at level 40, left associativity).
 Axiom hd_shuf: forall s t, hd (s @ t) = (hd s * hd t)%nat.
 Axiom tl_shuf: forall s t, tl (s @ t) = tl s @ t + s @ tl t.
 Ltac ssimpl := repeat (rewrite ?hd_shuf, ?tl_shuf; simpl hd; simpl tl).

 Lemma shuf_0x: forall x, c 0 @ x ~ c 0.
 Proof.
   coinduction R HR. intros x. split; ssimpl.
    nia.
    rewrite HR. rewrite plus_0x. apply HR.
 Qed.

 Lemma shuf_1x: forall x, c 1 @ x ~ x.
 Proof.
   coinduction R HR. intros x. split; ssimpl.
    lia.
    rewrite shuf_0x, plus_0x. apply HR.
 Qed.

 Lemma shufC: forall x y, x @ y ~ y @ x.
 Proof.
   coinduction R HR. intros x y. split; ssimpl.
    nia.
    now rewrite HR, plusC, HR.
 Qed.

 Lemma shuf_x_plus: forall x y z, x @ (y + z) ~ x@y + x@z.
 Proof.
   coinduction R HR. intros x y z. split; ssimpl.
    nia.
    rewrite 2HR. rewrite 2plusA.
    apply plus_chain. 2: reflexivity.
    rewrite <-2plusA.
    apply plus_chain. reflexivity. now rewrite plusC.
 Qed.

 Lemma shuf_plus_x: forall x y z, (y + z)@x ~ y@x + z@x.
 Proof.
   intros. rewrite shufC, shuf_x_plus.
   apply plus_chain; apply shufC.
 Qed.

 Lemma shufA: forall x y z, x @ (y @ z) ~ (x @ y) @ z.
 Proof.
   coinduction R HR. intros x y z. split; ssimpl.
    nia.
    rewrite shuf_x_plus, shuf_plus_x. rewrite 3HR.
    now rewrite plusA.
 Qed.

 (** shuffle product preserves the final chain *)
 #[export] Instance shuf_chain: forall {R: Chain b}, Proper (`R ==> `R ==> `R) shuf.
 Proof.
   apply (Proper_chain 2).
   intros R HR x y xy u v uv.
   pose proof xy as [xy0 xy'].
   pose proof uv as [uv0 uv'].
   split; ssimpl. congruence.
   now rewrite xy', uv', xy, uv.
 Qed.

 (** * convolution product *)
 (** like shuffle product, convolution product cannot be defined as easily as one could expect in Coq.
     Here we simply assume its existence for the sake of simplicity *)
 Parameter mult: S -> S -> S.
 Infix "*" := mult.
 Axiom hd_mult: forall s t, hd (s * t) = (hd s * hd t)%nat.
 Axiom tl_mult: forall s t, tl (s * t) = tl s * t + c (hd s) * tl t.
 Ltac msimpl := repeat (rewrite ?hd_mult, ?tl_mult; simpl hd; simpl tl).

 Lemma mult_0x: forall x, c 0 * x ~ c 0.
 Proof.
   coinduction R HR. intros x. split; msimpl.
    nia.
    rewrite HR. rewrite plus_0x. apply HR.
 Qed.

 Lemma mult_x0: forall x, x  * c 0 ~ c 0.
 Proof.
   coinduction R HR. intros x. split; msimpl.
    nia.
    rewrite HR. rewrite plus_0x. apply HR.
 Qed.

 Lemma mult_1x: forall x, c 1 * x ~ x.
 Proof.
   coinduction R HR. intros x. split; msimpl.
    lia.
    rewrite mult_0x, plus_0x. apply HR.
 Qed.

 Lemma mult_x1: forall x, x * c 1 ~ x.
 Proof.
   coinduction R HR. intros x. split; msimpl.
    lia.
    rewrite mult_x0, plusC, plus_0x. apply HR.
 Qed.

 Lemma mult_x_plus: forall x y z, x * (y + z) ~ x*y + x*z.
 Proof.
   coinduction R HR. intros x y z. split; msimpl.
    nia.
    rewrite 2HR. rewrite 2plusA.
    apply plus_chain. 2: reflexivity.
    rewrite <-2plusA.
    apply plus_chain. reflexivity. now rewrite plusC.
 Qed.

 Lemma c_plus n m: c (n+m) ~ c n + c m.
 Proof.
   coinduction R HR. clear HR. split; simpl.
    reflexivity.
    now rewrite plus_0x.
 Qed.

 Lemma c_mult n m: c (n*m) ~ c n * c m.
 Proof.
   coinduction R HR. clear HR. split; msimpl.
    reflexivity.
    now rewrite mult_0x, mult_x0, plus_0x.
 Qed.

 (** convolution product preserves the final chain  *)
 #[export] Instance mult_chain: forall {R: Chain b}, Proper (`R ==> `R ==> `R) mult.
 Proof.
   apply (Proper_chain 2).
   intros R HR x y xy u v uv.
   pose proof xy as [xy0 xy'].
   pose proof uv as [uv0 uv'].
   split; msimpl. congruence.
   now rewrite xy', uv', xy0, uv.
 Qed.

 Lemma mult_plus_x: forall x y z, (y + z) * x ~ y*x + z*x.
 Proof.
   coinduction R HR. intros x y z. split; msimpl.
    nia.
    rewrite c_plus, 2HR, 2plusA.
    apply plus_chain. 2: reflexivity.
    rewrite <-2plusA.
    apply plus_chain. reflexivity. now rewrite plusC.
 Qed.

 Lemma multA: forall x y z, x * (y * z) ~ (x * y) * z.
 Proof.
   coinduction R HR. intros x y z. split; msimpl.
    nia.
    rewrite mult_x_plus. rewrite 3HR.
    rewrite plusA, <-mult_plus_x.
    now rewrite c_mult.
 Qed.

 (** below: commutativity of convolution product, following Rutten's
     proof *)

 Lemma multC_n n: forall x, c n * x ~ x * c n.
 Proof.
   coinduction R HR. intro x. split; msimpl.
    nia.
    now rewrite mult_0x, mult_x0, plusC, HR.
 Qed.

 Definition X := cons 0 (c 1).

 Theorem expand x: x ~ c (hd x) + X * tl x.
 Proof.
   coinduction R HR. clear HR. split; msimpl.
    nia.
    now rewrite mult_0x, mult_1x, plus_0x, plusC, plus_0x.
 Qed.

 Lemma multC_11 x: tl (X * x) ~ x.
 Proof.
   coinduction R HR. clear HR. split; msimpl.
    nia.
    now rewrite !mult_0x, mult_1x, 2plus_0x, plusC, plus_0x.
 Qed.

 Lemma multC_X: forall x, X * x ~ x * X.
 Proof.
   coinduction R HR. intro x. split; msimpl.
    nia.
    rewrite mult_0x, mult_1x, mult_x1.
    rewrite plusC, plus_0x.
    rewrite plusC. now rewrite <-HR, <-expand.
 Qed.

 Lemma multC: forall x y, x * y ~ y * x.
 Proof.
   coinduction R HR. intros x y. split.
    msimpl; nia.
    rewrite (expand x) at 1. rewrite mult_plus_x. simpl tl.
    rewrite <-multA, multC_11.
    rewrite (HR (tl x)).
    rewrite multC_n. rewrite <-(multC_11 (y*tl x)).
    rewrite multA, multC_X.
    rewrite (expand x) at 3. rewrite mult_x_plus.
    now rewrite multA.
 Qed.

End streams.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural := lf1.


Require Import Coq.Program.Basics.
Require Import TypeclassHierarchy.Util.FunctionSetoid.
Require Import TypeclassHierarchy.Interfaces.Functor.

Inductive Identity (T : Type) : Type := Id : T -> Identity T.
Arguments Id {T} _.

Definition Id_fmap (A B : Type) (f : A -> B) (a : Identity A) : Identity B :=
  match a with
    Id a => Id (f a)
  end.

Instance Identity_Functor : Functor Identity := { fmap := Id_fmap }.
Proof.
  { (* fmap_proper *)
    intros A B.
    compute.
    intros x y Hyp a.
    case a.
    intros b.
    now rewrite (Hyp b).
  }
  { (* fmap_id *)
    intros A.
    compute.
    intros a.
    now case a.
  }
  { (* fmap_comp *)
    intros A B C h g.
    compute.
    intros a.
    now case a.
  }
Defined.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_cost.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Coq.omega.Omega Coq.Program.Wf.
Local Open Scope nat_scope.

Definition compare (x y: nat) : cost (compare_nat x y (x < y) (y < x) (x == y)) :=
  (1, ltngtP x y).

Record splitting (A: Type) := mkSplit { lower : seq A; middle: seq A; upper : seq A}.
Arguments mkSplit {_}.
Arguments lower {_}.
Arguments middle {_}.
Arguments upper {_}.

Definition splitting_eq_bool {A: eqType} (a b : splitting A) : bool :=
  (lower a == lower b) && (middle a == middle b) && (upper a == upper b).
Lemma eq_spl {A: eqType} : Equality.axiom (@splitting_eq_bool A).
Proof.
move=> [l1 m1 u1] [l2 m2 u2].
apply: (iffP idP); rewrite /splitting_eq_bool //=.
- move /andP => [Hand ?].
  move /andP in Hand. destruct Hand as (?&?).
  f_equal; apply /eqP; done.
- inversion 1; subst.
  apply /andP; split; auto.
  apply /andP; split; auto.
Qed.

Canonical splitting_eqMixin A := EqMixin (@eq_spl A).
Canonical splitting_eqType A := Eval hnf in EqType (splitting _) (splitting_eqMixin A).

Fixpoint partition (n: nat) (l: list nat) : cost (splitting nat) :=
  match l with
    | [::] => mret {| lower := [::]; middle := [::]; upper := [::]|}
    | m :: l =>
      spl ← partition n l;
      let '(ll, leq, lu) := (lower spl, middle spl, upper spl) in
      (cmp ← compare m n;
      match cmp with
        | CompareNatLt _ => mret (mkSplit (m :: ll) leq lu)
        | CompareNatEq _ => mret (mkSplit ll (m :: leq) lu)
        | CompareNatGt _ => mret (mkSplit ll leq (m :: lu))
      end)
  end.

Lemma partition_perm_eq l:
  ∀ n, perm_eq (lower (partition n l).2 ++ middle (partition n l).2 ++ upper (partition n l).2) l.
Proof.
  induction l => n; first by (rewrite //=).
  rewrite //=. case (ltngtP a n) => Hcmp //=.
  - by rewrite perm_cons.
  - eapply (perm_eq_trans).
    { erewrite perm_cat2l. rewrite perm_catC cat_cons. erewrite perm_cons. done. }
    rewrite -cat_cons perm_catCA cat_cons perm_cons.
    rewrite -perm_catCA.
    eapply (perm_eq_trans); last apply (IHl n).
    rewrite perm_cat2l perm_catC //.
  - rewrite -cat_cons perm_catCA // cat_cons perm_cons.
    rewrite perm_catCA //.
Qed.

Lemma partition_middle_size l:
  ∀ n, n \in l → 0 < size (middle (partition n l).2).
Proof.
  induction l => //= n Hin.
  intros. case (ltngtP a n) => //=; intros Hcmp; apply IHl;
  move: Hin; rewrite in_cons; move /orP => [HeqP|] //; exfalso;
  move /eqP in HeqP; subst; rewrite ltnn in Hcmp; done.
Qed.

Definition partition' (n: nat) (l: list nat) :
  cost { x : splitting nat | perm_eq (lower x ++ middle x ++ upper x) l &&
                             ((n \in l) ==> (0 < size (middle x)))}.
Proof.
  refine (fst (partition n l), exist _ (snd (partition n l)) _).
  apply /andP; split.
  - apply partition_perm_eq.
  - apply /implyP/partition_middle_size.
Defined.

Lemma partition_cost l: ∀ n, (partition n l).1 = (size l).
Proof.
  induction l as [| a l'] => //= n.
  rewrite /cost_bind//=. case (ltngtP a n) => //=; rewrite IHl';
  destruct (partition n l') as [? [? ? ?]] => //= ?; ring.
Qed.

Require Import Reals Fourier ProofIrrelevance FunctionalExtensionality.

Program Definition unif n : ldist_cost { x : nat | (leq x n) } :=
  mklDist [ seq (1/(INR (n.+1)), (O, exist _ (nat_of_ord i) _)) | i <- enum 'I_(n.+1) ] _ _.
Next Obligation. intros n i => //=. rewrite -ltnS. done. Qed.
Next Obligation.
  intros n.
  apply /allP => r.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  rewrite //=. induction (iota 1 n) => //=.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR. omega.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec 0 (1 / _)) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first by fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR; omega.
Qed.
Next Obligation.
  intros n.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  cut (∀ o k, \big[Rplus/0]_(a<-[seq (1 / INR n.+1) | i <- iota k o]) a
            = INR (o) / INR (n.+1)).
  {
    intros Hcut. specialize (Hcut (n.+1) O). rewrite //= in Hcut.
    rewrite Hcut. apply /eqP => //=. field.
    apply Rgt_not_eq.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); first by intros; fourier.
    apply lt_INR; omega.
  }
  induction o => k.
  - rewrite big_nil. replace (INR 0) with 0 by auto. rewrite /Rdiv Rmult_0_l //.
  - rewrite big_cons. rewrite (S_INR o).
    rewrite Rdiv_plus_distr IHo. ring.
Qed.

Program Definition draw_pivot (a : nat) (l: list nat) : ldist_cost { x : nat | x \in (a :: l) } :=
  idx ← unif (size l);
  mret (exist _ (nth O (a :: l) (sval idx)) _).
Next Obligation. intros a l (?&?) => //=. rewrite mem_nth //. Qed.

Definition qs : list nat → ldist_cost (list nat).
  refine(Fix (measure_wf lt_wf size) (fun _ => ldist_cost (list nat))
  (fun l qs =>
  match l as l' return (l = l' → ldist_cost (list nat)) with
    | [::] => λ eq, mret ([::])
    | [::a] => λ eq, mret ([::a])
    | (a :: b :: l') => λ eq,
      p ← draw_pivot a (b :: l');
      spl ← dist_ret _ (partition' (sval p) l);
      lls ← qs (lower (sval spl)) _;
      lus ← qs (upper (sval spl)) _;
      mret (lls ++ (middle (sval spl)) ++ lus)
  end (Init.Logic.eq_refl))); rewrite /MR; auto.
  - abstract (destruct spl as (spl&pf) => //=; move /andP in pf;
    destruct pf as (pf1&pf2); move /implyP in pf2;
    rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE;
    assert (0 < size (middle spl))%coq_nat by
    ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=); omega).
  - abstract (destruct spl as (spl&pf) => //=; move /andP in pf;
    destruct pf as (pf1&pf2); move /implyP in pf2;
    rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE;
    assert (0 < size (middle spl))%coq_nat by
    ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=); omega).
Defined.

Lemma easy_fix_eq:
  ∀ (A : Type) (R : A → A → Prop) (Rwf : well_founded R) (P : A → Type)
    (F : ∀ x : A, (∀ y : A, R y x → P y) → P x),
    ∀ x : A, Fix Rwf P F x = F x (λ (y : A) (_ : R y x), Fix Rwf P F y).
Proof.
  intros. apply Init.Wf.Fix_eq.
  intros. assert (f = g) as ->; last done.
  apply functional_extensionality_dep => ?.
  apply functional_extensionality_dep => ?. done.
Qed.

Lemma qs_unfold_aux l:
  qs l =
  match l as l' return (l = l' → ldist_cost (list nat)) with
    | [::] => λ eq, mret ([::])
    | [:: a] => λ eq, mret ([:: a])
    | (a :: b :: l') => λ eq,
      p ← draw_pivot a (b :: l');
      spl ← dist_ret _ (partition' (sval p) l);
      lls ← qs (lower (sval spl));
      lus ← qs (upper (sval spl));
      mret (lls ++ (middle (sval spl)) ++ lus)
  end (Init.Logic.eq_refl).
Proof. rewrite /qs easy_fix_eq; done. Qed.

Lemma qs_unfold l:
  qs l =
  (match l as l
  with
    | [::] => mret ([::])
    | [::a] => mret ([::a])
    | (a :: l) =>
      p ← draw_pivot a l;
      spl ← dist_ret _ (partition' (sval p) (a :: l));
      lls ← qs (lower (sval spl));
      lus ← qs (upper (sval spl));
      mret (lls ++ (middle (sval spl)) ++ lus)
  end).
Proof.
  rewrite qs_unfold_aux. destruct l => //. destruct l => //.
Qed.


Add LoadPath "src/".
Require Import Model.
Require Import Sets.

(* When sets are low *)
Lemma low_empty: low Ø.
Proof. simpl low. auto. Qed.

Lemma low_sing : forall x, low (sing x).
Proof. unfold sing; simpl low; tauto. Qed.

Lemma low_neg: forall x, low (neg x) <-> ~ low x.
Proof.
  destruct x; unfold neg; simpl low; tauto.
Qed.

Lemma low_cap: forall x y, low (x ⋂ y) <-> (low x \/ low y).
Proof.
  destruct x; destruct y; simpl cap; simpl low; tauto.
Qed.

Lemma low_cup: forall x y, low (x ∪ y) <-> (low x /\ low y).
Proof.
  destruct x; destruct y; simpl cap; simpl low; tauto.
Qed.

(* ZF axioms *)
(* WORK IN PROGRESS *)

(* 2. Regularity
      forall x, neq x empty -> exists y in x, y cap x = emptyset
      It does not hold, either for positive or negative sets.
      Ex.: x= {u}, y = u for positives. U minus {{}} for negatives.
*)

(* 3. Comprehension
      Yes for positive sets and sound formulas.
*)
Definition pred_sound P := forall x y, x ≡ y -> (P x <-> P y).
Definition compr: forall {x}, low x -> (set -> Prop) -> set.
Proof.
  intros x low P.
  destruct x; destruct low.
  apply (@Pos {x : X & P (s x)}).
  intro. destruct X0. exact (s x).
Defined.

Lemma compr_ok: forall {x} P (pos: low x) (pok: pred_sound P), forall z, iin z (compr pos P) <-> iin z x /\ P z.
Proof.
  intros. destruct x; destruct pos.
  simpl iin. split; intros; destruct H.
  -  destruct x. split. exists x. assumption.
    apply (pok _ _ H). assumption.
  - destruct H. destruct (pok _ _ H).
    exists (existT _ x (H2 H0)). assumption.
Qed.

(* 4. Pairing. OBVIOUS *)

(* 5. Union. Work in Progress *)
Lemma union_ax: forall x, exists y, forall z, iin z y <-> exists x', iin x' x /\ iin z x'.
Proof.
  destruct x.
  - admit.
  - exists 𝒰. intros. split; intro. simpl. admit. apply univ_ok.
Admitted.

  (*
  6. REPLACEMENT
  7. INFINITY
  8. POWER SET
  9. WELL-ORDERING
  *)

(* Definition pow X (f: X -> set) :=
  @Pos (X -> Prop)
    (fun s => @Pos { x : X & s x }
      (fun ex => match ex with existT _ x _ => f x end) )
.

Definition subset x y := forall z, iin z x -> iin z y.

Lemma subset_ex : forall x, isZF x -> exists y, forall z, iin z y <-> subset z x.
Proof.
  intros. destruct x; destruct H.
  exists (pow X s). intros. split.
  - unfold pow. simpl iin. intro. destruct H. unfold subset.
  intros. simpl iin.
  destruct z. destruct H0. destruct H. *)