(*****************************************************************

 Copowers

 We define the notion of copowers in the setting of enriched
 category theory. In ordinary category theory, all colimits can be
 constructed from so-called conical colimits (colimits of a
 functor). However, this is not necessarily the case for enriched
 category theory. Instead, a more general class of colimits is
 studied, called weighted colimits.

 One example of a weighted colimits that is not a conical colimit,
 is the copower. Suppose that `V` is a symmetric monoidal closed
 category and that `C` is enriched over `V`. Given two objects
 `v : V` and `x : C`, the copower is defined by the following
 natural isomorphism

   C ⟦ v ⊙ x , y ⟧ ≅ v ⊸ C ⟦ x , y ⟧

 where `⊸` denotes the internal hom of `V`.

 If we were looking at categories enriched over sets, then the
 copower of a set `X` with the object `x` would be the coproduct
 consisting of a copy of `x` for every member of `X`.

 Contents
 1. Cocones of copowers
 2. Copowers in an enriched category
 3. Being a copower is a proposition
 4. Accessors for copowers
 5. Builders for copowers
 6. Copowers are closed under iso
 7. Enriched categories with copowers

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.

Import MonoidalNotations.
Local Open Scope cat.
Local Open Scope moncat.

Opaque sym_mon_braiding.

Section EnrichedCopowers.
  Context {V : sym_mon_closed_cat}
          {C : category}
          (E : enrichment C V)
          (v : V)
          (x : C).

  (**
   1. Cocones of copowers
   *)
  Definition copower_cocone
    : UU
    := ∑ (a : C), v --> E ⦃ x , a ⦄.

  Coercion ob_copower_cocone
           (a : copower_cocone)
    : C
    := pr1 a.

  Definition copower_cocone_mor
             (a : copower_cocone)
    : v --> E ⦃ x , a ⦄
    := pr2 a.

  Definition make_copower_cocone
             (a : C)
             (f : v --> E ⦃ x , a ⦄)
    : copower_cocone
    := a ,, f.

  (**
   2. Copowers in an enriched category
   *)
  Definition is_copower_enriched_map
             (a : copower_cocone)
             (w : C)
    : E ⦃ a , w ⦄ --> v ⊸ (E ⦃ x , w ⦄)
    := internal_lam
         (identity _ #⊗ copower_cocone_mor a
          · enriched_comp E  _ _ _).

  Definition is_copower_enriched
             (a : copower_cocone)
    : UU
    := ∏ (w : C),
       is_z_isomorphism (is_copower_enriched_map a w).

  Definition is_copower_enriched_iso
             {a : copower_cocone}
             (Ha : is_copower_enriched a)
             (w : C)
    : z_iso (E ⦃ a , w ⦄) (v ⊸ (E ⦃ x , w ⦄))
    := _ ,, Ha w.

  (**
   3. Being a copower is a proposition
   *)
  Proposition isaprop_is_copower_enriched
              (a : copower_cocone)
    : isaprop (is_copower_enriched a).
  Proof.
    use impred ; intro.
    apply isaprop_is_z_isomorphism.
  Qed.

  (**
   4. Accessors for copowers
   *)
  Section Accessors.
    Context {a : copower_cocone}
            (Ha : is_copower_enriched a).

    Definition mor_to_copower
               {w : V}
               {b : C}
               (f : w --> v ⊸ (E ⦃ x , b ⦄))
      : w --> E ⦃ a , b ⦄
      := f · inv_from_z_iso (is_copower_enriched_iso Ha b).

    Proposition mor_to_copower_commutes
                {w : V}
                {b : C}
                (f : w --> v ⊸ (E ⦃ x , b ⦄))
      : mor_to_copower f · is_copower_enriched_map a b
        =
        f.
    Proof.
      unfold mor_to_copower.
      rewrite !assoc'.
      refine (_ @ id_right _).
      apply maponpaths.
      apply z_iso_after_z_iso_inv.
    Qed.

    Proposition mor_to_copower_eq
                {w : V}
                {b : C}
                {f g : w --> E ⦃ a , b ⦄}
                (p : f · is_copower_enriched_map a b
                     =
                     g · is_copower_enriched_map a b)
      : f = g.
    Proof.
      use (cancel_z_iso _ _ (is_copower_enriched_iso Ha _)).
      exact p.
    Qed.

    Definition arr_to_copower
               {b : C}
               (f : I_{V} --> v ⊸ (E ⦃ x , b ⦄))
      : a --> b
      := enriched_to_arr E (mor_to_copower f).

    Proposition arr_to_copower_commutes
                {b : C}
                (f : I_{V} --> v ⊸ (E ⦃ x , b ⦄))
      : enriched_from_arr E (arr_to_copower f) · is_copower_enriched_map a b
        =
        f.
    Proof.
      unfold arr_to_copower.
      rewrite enriched_from_to_arr.
      apply mor_to_copower_commutes.
    Qed.

    Proposition arr_to_copower_eq
                {b : C}
                {f g : a --> b}
                (p : enriched_from_arr E f · is_copower_enriched_map a b
                     =
                     enriched_from_arr E g · is_copower_enriched_map a b)
      : f = g.
    Proof.
      refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _).
      apply maponpaths.
      use mor_to_copower_eq.
      exact p.
    Qed.
  End Accessors.

  (**
   5. Builders for copowers
   *)
  Definition make_is_copower_enriched
             (a : copower_cocone)
             (p_map : ∏ (w : C), v ⊸ (E ⦃ x , w ⦄) --> E ⦃ a , w ⦄)
             (H₁ : ∏ (w : C), is_copower_enriched_map a w · p_map w = identity _)
             (H₂ : ∏ (w : C), p_map w · is_copower_enriched_map a w = identity _)
    : is_copower_enriched a.
  Proof.
    intro w.
    use make_is_z_isomorphism.
    - exact (p_map w).
    - split.
      + exact (H₁ w).
      + exact (H₂ w).
  Defined.

  (**
   6. Copowers are closed under iso
   *)
  Section CopowerIso.
    Context (a : copower_cocone)
            (Ha : is_copower_enriched a)
            (b : C)
            (f : z_iso a b).

    Definition copower_cocone_from_iso
      : copower_cocone.
    Proof.
      use make_copower_cocone.
      - exact b.
      - exact (copower_cocone_mor a · postcomp_arr E x f).
    Defined.

    Definition is_copower_enriched_from_iso
      : is_copower_enriched copower_cocone_from_iso.
    Proof.
      intros w.
      refine (transportf
                is_z_isomorphism
                _
                (is_z_iso_comp_of_is_z_isos _ _ (precomp_arr_is_z_iso E w _ (pr2 f)) (Ha w))).
      unfold precomp_arr, is_copower_enriched_map.
      cbn.
      use internal_funext.
      intros z h.
      rewrite !tensor_comp_r_id_r.
      refine (!_).
      etrans.
      {
        rewrite tensor_split.
        apply idpath.
      }
      rewrite !assoc'.
      rewrite !internal_beta.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        rewrite <- tensor_split'.
        rewrite tensor_split.
        rewrite !assoc'.
        apply maponpaths.
        rewrite enrichment_assoc.
        apply idpath.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        rewrite <- tensor_id_id.
        rewrite !assoc'.
        rewrite tensor_lassociator.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        rewrite tensor_lassociator.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite tensor_split.
        rewrite !assoc'.
        rewrite <- mon_inv_triangle.
        apply idpath.
      }
      rewrite <- !tensor_comp_id_l.
      apply maponpaths.
      rewrite !assoc'.
      apply maponpaths.
      unfold postcomp_arr.
      rewrite !assoc.
      apply maponpaths_2.
      rewrite tensor_linvunitor.
      rewrite !assoc'.
      apply maponpaths.
      rewrite <- !tensor_split.
      rewrite <- !tensor_split'.
      apply idpath.
    Qed.
  End CopowerIso.
End EnrichedCopowers.

(**
 7. Enriched categories with copowers
 *)
Definition enrichment_copower
           {V : sym_mon_closed_cat}
           {C : category}
           (E : enrichment C V)
  : UU
  := ∏ (v : V) (x : C),
     ∑ (e : copower_cocone E v x),
     is_copower_enriched E v x e.

Definition cat_with_enrichment_copower
           (V : sym_mon_closed_cat)
  : UU
  := ∑ (C : cat_with_enrichment V), enrichment_copower C.

Coercion cat_with_enrichment_copower_to_cat_with_enrichment
         {V : sym_mon_closed_cat}
         (C : cat_with_enrichment_copower V)
  : cat_with_enrichment V
  := pr1 C.

Definition copowers_of_cat_with_enrichment
           {V : sym_mon_closed_cat}
           (C : cat_with_enrichment_copower V)
  : enrichment_copower C
  := pr2 C.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2006                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export Arith.
Require Export listAux.
Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Section Definitions.
 Definition eqdec (X:Set) := forall x y: X, {x=y}+{x<>y}.
Hint Unfold eqdec.

Section Main.
 Variables
           I (* composition modes *)
           J (* unary modes *)
           : Set.

 Section formulae_etc.
  Variable A W : Set.

(* definition of formulas *)
  Inductive Form   : Set :=
   | At : A -> Form
   | Slash : I -> Form  -> Form  -> Form
   | Backslash : I -> Form -> Form  -> Form
   | Dot : I -> Form  -> Form  -> Form
   | Box : J -> Form  -> Form
   | Diamond : J -> Form  -> Form .

  (* decidability of equality within Form *)
Definition eqDecF:forall(eqdecI :eqdec I) (eqdecJ :eqdec J)
 (eqdecA :eqdec A), eqdec Form.
 intros; unfold eqdec.
 decide equality.
Defined.
 (* resources that will be used as leaves in the context *)
  Inductive resource : Set :=
   | word : nat -> W -> resource
   | hyp : nat -> resource.

 (* decidability of equality within the set of resources*)
 Definition eqdecRess:forall(eqdecW:eqdec W), eqdec resource.
  intros;unfold eqdec; decide equality.
  generalize n n0; decide equality.
  generalize n n0; decide equality.
Defined.

  Inductive bcontext : Set := (* bare contexts, without resources *)
  | form : Form -> bcontext
  | bComma : I -> bcontext -> bcontext -> bcontext
  | bDiamond : J -> bcontext -> bcontext.

  (* contexts with resources *)
  Inductive context  : Set :=
   | res  : resource -> Form -> context
   | Comma : I -> context -> context -> context
   | TDiamond : J -> context -> context.

Inductive is_sub_cont (T1:context):context ->Prop:=
|sub_all:is_sub_cont T1 T1
|sub_left:forall T2 T3 i, is_sub_cont T1 T2->
                                   is_sub_cont T1 (Comma i T2 T3)
|sub_right:forall T2 T3 i,is_sub_cont T1 T3->
                                   is_sub_cont T1 (Comma i T2 T3)
|sub_diam:forall T2 j, is_sub_cont T1 T2->
                                  is_sub_cont T1 (TDiamond j T2).

(* decidability of equality within the set of contexts*)
 Definition eqdecC:forall(eqdecI :eqdec I) (eqdecJ :eqdec J)
 (eqdecA :eqdec A)(eqdecW:eqdec W), eqdec context.
  intros;unfold eqdec; decide equality.
  apply eqDecF; auto.
  apply eqdecRess; auto.
Defined.

  Inductive hcontext : Set := (* context with holes *)
   | hres :  resource -> Form -> hcontext
   | hComma : I -> hcontext -> hcontext -> hcontext
   | hDiamond : J -> hcontext -> hcontext
   | hole : hcontext.

   Fixpoint fill (h:hcontext)(Gamma : context) {struct h} : context :=
   match h with hole => Gamma
              | hComma i h1 h2 => Comma  i (fill  h1 Gamma) (fill h2 Gamma)
              | hDiamond j h1 => TDiamond  j (fill h1 Gamma)
              | hres r F => res r F
           end.

 Fixpoint context_inject (Gamma:context) : hcontext :=
  match Gamma with
  | res r F => hres r F
  | Comma i Gamma1 Gamma2 => hComma i (context_inject Gamma1)
                                      (context_inject Gamma2)
  | TDiamond j Gamma1 => hDiamond j (context_inject Gamma1)
  end.

 (* definition of function that converts a context to a form *)
  Fixpoint contextToForm (T:context) : Form :=
   match T with
   | res r f => f
   | Comma i t1 t2 =>
       Dot i (contextToForm t1) (contextToForm t2)
   | TDiamond j t => Diamond j (contextToForm t)
   end.

 (* from Huet's zippers *)

  Inductive zcontext : Set := (* context with 1 hole *)
   | zroot : zcontext
   | zleft  : I ->  zcontext -> context -> zcontext
   | zright : I -> context->  zcontext -> zcontext
   | zdown : J ->  zcontext -> zcontext.

  Fixpoint zfill (z:zcontext)(Gamma : context) {struct z} : context :=
   match z with zroot => Gamma
              | zleft i z1 Gamma2 =>
                   zfill z1 (Comma  i Gamma Gamma2)
              | zright i Gamma1 z2 =>
                   zfill z2 (Comma i Gamma1 Gamma)
              | zdown j z1 => zfill z1 (TDiamond j Gamma)
           end.

 Fixpoint zcontext_inject_aux (zx:zcontext)(hc : hcontext){struct zx}
   :hcontext
   := match zx with
   | zroot => hc
   | zleft  i zc1 c2 =>
       zcontext_inject_aux zc1 (hComma i hc (context_inject c2))
   | zright  i c1 zc2 =>
      zcontext_inject_aux zc2 (hComma i (context_inject c1) hc)
   | zdown j zc1 =>  zcontext_inject_aux zc1 (hDiamond j hc)
 end.

 Definition zcontext_inject zc : hcontext :=
   zcontext_inject_aux zc hole.

 Fixpoint zgraft (z z': zcontext){struct z} : zcontext :=
   match z with
  | zroot => z'
  | zleft i zc1 c2 => zleft i (zgraft zc1 z') c2
  | zright i c1 zc2 => zright i c1 (zgraft zc2 z')
  | zdown j zc1 => zdown j (zgraft zc1 z')
 end.

 Lemma zgraft_def : forall z z' c,
      zfill (zgraft z z') c = zfill z' (zfill z c).
  induction z.
  simpl.
  auto.
  intros; simpl; auto.
  intros; simpl; auto.
  intros; simpl; auto.
 Qed.

Theorem no_holes : forall (Gamma Delta:context),
     fill (context_inject Gamma) Delta = Gamma.
Proof.
 induction Gamma;simpl;auto.
 intros;rewrite IHGamma1; rewrite IHGamma2;auto.
 intros;rewrite IHGamma; auto.
Qed.

Lemma zfill_fill_0 : forall (zc:zcontext)(hc:hcontext)(c:context),
   zfill zc (fill hc c) = fill (zcontext_inject_aux zc hc) c.
Proof.
 induction zc.
 simpl; auto.
 intros.
 simpl.
 rewrite <- IHzc.
 simpl.
 rewrite no_holes.
 auto.
 intros.
 simpl.
 rewrite <- IHzc.
 simpl.
 rewrite no_holes.
 auto.
 intros.
 simpl.
 rewrite <- IHzc.
 simpl.
 trivial.
Qed.

Theorem zfill_fill : forall (zc:zcontext)(c:context),
   zfill zc c = fill (zcontext_inject zc) c.
Proof.
 unfold zcontext_inject.
 intros; rewrite <- zfill_fill_0.
 simpl.
 auto.
Qed.

Inductive matches : bcontext -> context -> Prop :=
 |  form_matches : forall F r, matches (form F) (res r F)
 |  comma_matches : forall (i:I) b1 b2 Gamma1 Gamma2,
           matches b1 Gamma1 -> matches b2 Gamma2 ->
           matches (bComma i b1 b2) (Comma i Gamma1 Gamma2)
 |  diam_matches : forall (j:J) b  Gamma ,
           matches b Gamma ->
           matches (bDiamond j b) (TDiamond j Gamma).

Fixpoint context_strip (Gamma :context): bcontext :=
  match Gamma with
  | res r F => form F
  | Comma i Gamma1 Gamma2 => bComma i (context_strip Gamma1)
                                      (context_strip Gamma2)
  | TDiamond j Gamma1 => bDiamond j (context_strip Gamma1)
  end.

 Theorem strip_match : forall Gamma : context,
                        matches (context_strip Gamma) Gamma.
 Proof.
   induction Gamma;simpl; constructor; auto.
 Qed.

Theorem match_strip : forall bGamma Gamma,
                         matches bGamma Gamma -> bGamma = context_strip Gamma.
 induction 1;   simpl ; auto.
 rewrite IHmatches1; rewrite IHmatches2; auto.
 rewrite IHmatches; auto.
 Qed.

(* definition of an equivalence relation between contexts *)
 Definition context_equiv Gamma Gamma' :=
        (context_strip Gamma)=(context_strip Gamma').

 Inductive context_eqv:context ->context ->Set:=
 |form_eqv:forall F r1 r2, context_eqv (res r1 F) (res r2 F)
 | com_eqv:forall Gamma1 Gamma2 Gamma1' Gamma2' (i:I),
               context_eqv Gamma1 Gamma1'->context_eqv Gamma2 Gamma2'->
               context_eqv (Comma i Gamma1 Gamma2) (Comma i Gamma1' Gamma2')
 |diam_eqv:forall (j:J)Gamma1 Gamma1' , context_eqv Gamma1 Gamma1'->
                                      context_eqv (TDiamond j Gamma1) (TDiamond j Gamma1').
(* a faire si c'est vraiment obligatoire
 Theorem context_eq_refl:forall (Gamma Gamma':context),
        context_equiv Gamma Gamma'->
        context_eqv Gamma Gamma'.

*)

 Definition matches_inv_form : forall F Gamma, matches (form F) Gamma ->
          {r: resource | Gamma = res r F}.
  intros F Gamma;case Gamma.
  intros r f H; exists r;inversion H; trivial.
  intros; cut False.
  destruct 1.
  inversion H.
  intros; cut False.
  destruct 1.
  inversion H.
 Defined.

 Definition matches_inv_Comma : forall i b1 b2  Gamma,
        matches (bComma i b1 b2) Gamma ->
        {Gamma1 : context & {Gamma2 : context |
                                  Gamma = Comma i Gamma1 Gamma2 /\
                                  matches b1 Gamma1 /\
                                  matches b2 Gamma2}}.
 intros i b1 b2 Gamma; case Gamma.
 intros r f H; cut False.
 induction 1.
 inversion H.
 intros i0 c c0 H; exists c;exists c0; inversion H.
 split; auto.
 intros j c H;cut False.
 induction 1.
 inversion H.
 Defined.

 Definition matches_inv_Diam : forall j b  Gamma,
        matches (bDiamond j b) Gamma ->
        {Gamma1 : context | Gamma = TDiamond j Gamma1 /\
                                  matches b Gamma1}.
  intros j b Gamma; case Gamma.
  intros r f H; cut False.
  induction 1.
  inversion H.
  intros i c c0 H; cut False.
  induction 1.
  inversion H.
  intros j0 c H.
  exists c;inversion H;split; auto.
 Defined.

End formulae_etc.

Inductive rule_pattern : Set :=
 |  pvar : nat -> rule_pattern
 |  pcomma : I -> rule_pattern -> rule_pattern -> rule_pattern
 |  pdiam : J -> rule_pattern -> rule_pattern.

Fixpoint flatten_pattern(rp:rule_pattern):list nat:=
match rp with
|pvar i => i::nil
|pcomma i T1 T2=>flatten_pattern T1 ++ flatten_pattern T2
|pdiam j T1=>flatten_pattern T1
end.

  (* symbolic structural rule *)
 Definition structrule := prod rule_pattern rule_pattern.

Inductive hasSubContexts (A W:Set): rule_pattern->context A W->list
(context A W)->Prop:=
|has_pvar:forall (i:nat)(Delta:context A W),
   hasSubContexts (pvar i) Delta (Delta::nil)
|has_pcom:forall r1 r2 Delta1 Delta2 l1 l2 i,
                 hasSubContexts r1 Delta1 l1->
                 hasSubContexts r2 Delta2 l2->
                 hasSubContexts (pcomma i r1 r2)(Comma i Delta1
		 Delta2) (l1++l2)
|has_pdiam:forall  r Delta l j,
              hasSubContexts r Delta l->
              hasSubContexts (pdiam j r) (TDiamond j Delta) l.

(* some functions *)
Fixpoint isLeaf (n:nat)(rp1 :rule_pattern){struct
rp1}:Prop:=
match rp1 with
|pvar j=> n=j
|pcomma i r1 r2=>(isLeaf n r1)\/(isLeaf n r2)
|pdiam _ r1 =>(isLeaf n r1)
end.

Lemma in_isLeaf:forall (rp:rule_pattern )n,
                In n (flatten_pattern rp)->
                isLeaf n rp.
Proof.
 intro rp; elim rp; simpl in |- *.
 intros n n0; induction 1.
 auto.
 tauto.
 intros.
 elim (in_app_or _ _ _ H1).
 intro; left; auto.
 intro; right; auto.
 auto.
Qed.

Lemma isLeaf_in:forall (rp:rule_pattern)n,
                isLeaf n rp->
                 In n (flatten_pattern rp).
Proof.
intro rp; elim rp; simpl in |- *.
intros; left; auto.
intros.
apply in_or_app.
case H1.
intro; left; auto.
intro; right; auto.
auto.
Qed.

Fixpoint noIntersection(rp1 rp2:rule_pattern){struct rp1}:Prop:=
match rp1 with
| pvar i => ~ (isLeaf i rp2)
|pcomma i r1 r2 =>noIntersection r1 rp2 /\ noIntersection r2 rp2
|pdiam i r1 =>noIntersection r1 rp2
end.

Fixpoint allDistinctLeaves (rp1:rule_pattern){struct rp1}:Prop:=
match rp1 with
|pvar i =>True
|pcomma i r1 r2=> allDistinctLeaves r1 /\  allDistinctLeaves r2 /\
 noIntersection r1 r2
|pdiam j r1 =>allDistinctLeaves r1
end.

Fixpoint isIncluded (rp1 rp2:rule_pattern){struct
rp1}:Prop:=
match rp1 with
|pvar i=>isLeaf i rp2
|pcomma _ r1 r2=>isIncluded r1 rp2 /\ isIncluded r2 rp2
|pdiam _ r1=>isIncluded r1 rp2
end.

(* some auxiliary lemmas about the functions above *)
Lemma noIntersectionLeaf:forall n (rp1 rp2:rule_pattern) ,
    noIntersection rp1 rp2 ->
    isLeaf n rp1->
   ~isLeaf n rp2.
 intros n rp1; elim rp1.
 simpl in |- *.
 intros; subst; auto.
 intros.
 simpl in H2.
 simpl in H1.
 elim H1; intros.
 elim H2; eauto.
 simpl in |- *.
 auto.
Qed.

Definition isLeaf_dec:forall (n:nat)(rp:rule_pattern),
                 {isLeaf n rp}+{~ isLeaf n rp}.
 intros; elim rp.
 intros.
 simpl in |- *.
 elim (eq_nat_dec n n0).
 intro; left; auto.
 intro; right; auto.
 intros.
 elim H; elim H0; intros.
 left; simpl in |- *; tauto.
 left; simpl in |- *; tauto.
 left; simpl in |- *; tauto.
 right; simpl in |- *; tauto.
 intros.
 elim H; intros.
 left; simpl in |- *; auto.
 right; simpl in |- *; auto.
Defined.

Definition isLeaf_dec_com:forall (rp1 rp2:rule_pattern)(i:I)n,
                      noIntersection rp1 rp2 ->
                     isLeaf n (pcomma i rp1 rp2) ->
                     {isLeaf n rp1 /\ ~ isLeaf n rp2}+
                     {isLeaf n rp2 /\ ~ isLeaf n rp1}.

 simpl in |- *.
 intros.
 case (isLeaf_dec n rp1).
 case (isLeaf_dec n rp2).
 intros.
 elim (noIntersectionLeaf _ _ _ H i1).
 auto.
 intros; left; tauto.
 intro; elim (isLeaf_dec n rp2).
 intro.
 right; tauto.
 intro.
 cut False.
 intro F; elim F.
 elim H0; tauto.
Defined.

Lemma noInter_pattern_to_list:forall (rp1 rp2:rule_pattern),
                              noIntersection rp1 rp2->
                              noInter (flatten_pattern rp1)
                              (flatten_pattern rp2).
Proof.
 intro rp1; elim rp1; simpl in |- *.
 intros; split.
 red in |- *.
 intro; elim H.
 apply in_isLeaf; auto.
 auto.
 intros.
 apply noInter_app.
 elim H1; auto.
 elim H1; auto.
 auto.
Qed.

Lemma allDistinct_to_distinct:forall (rp:rule_pattern),
                              allDistinctLeaves rp->
                              distinct_elts (flatten_pattern rp).
 intro rp; elim rp; simpl in |- *.
 tauto.
 intros.
 decompose [and] H1; clear H1.
 apply distinct_app; auto.
 apply noInter_pattern_to_list; auto.
 auto.
Qed.

Lemma isIncluded_to_isIncl:forall(r1 r2:rule_pattern),
                         isIncluded r1 r2->
                         isIncl (flatten_pattern r1)(flatten_pattern
                              r2).
Proof.
 intro r1; elim r1; simpl in |- *.
 intros.
 split.
 apply isLeaf_in; auto.
 auto.
 intros.
 case H1; intros.
 apply isIncl_app; auto.
 auto.
Qed.

Inductive same_shape(A W:Set): rule_pattern->(context A
W)->Prop:=
|same_shape_leaf:forall(n:nat) Gamma, same_shape (pvar n) Gamma
|same_shape_comma:forall(i:I)(r1 r2:rule_pattern)(Gamma1
Gamma2:context A W), same_shape r1 Gamma1->
                     same_shape r2 Gamma2 ->
                     same_shape (pcomma i r1 r2) (Comma i Gamma1
		     Gamma2)
|same_shape_diam:forall(j:J)(rp:rule_pattern)(Gamma:context A W),
                    same_shape rp Gamma->
                    same_shape (pdiam j rp) (TDiamond j Gamma).

Lemma subCont_same_shape:forall (A W:Set) rp Gamma,
                          same_shape rp Gamma->
                         (exists l:list (context A W),
                          hasSubContexts rp Gamma l).
Proof.
 induction 1.
 econstructor; econstructor.
 elim IHsame_shape1.
 elim IHsame_shape2.
 intros; econstructor; econstructor; eauto.
 elim IHsame_shape.
 intros; econstructor; econstructor; eauto.
Qed.

Lemma same_shape_SubCont:forall  (A W:Set) rp (Gamma:context A W)l,
                          hasSubContexts rp Gamma l->
                           same_shape rp Gamma.
Proof.
 induction 1.
 constructor.
 constructor; auto.
 constructor; auto.
Qed.

Lemma nth_flatten_leaf:forall rp i n,
         nth_error (flatten_pattern rp) i=Some n->
         isLeaf n rp.
Proof.
 intro rp; elim rp; intros.
 generalize H; clear H; case i.
 simpl in |- *.
 injection 1; auto.
 simpl in |- *.
 intro n1; case n1; simpl in |- *.
 discriminate 1.
 discriminate 2.
 simpl in |- *.
 simpl in H1.
 elim (nth_error_app _ _ _ H1).
 intro; left; eauto.
 intro K;decompose [and] K;clear K; right; eauto.
 simpl in H0; simpl in |- *; eauto.
Qed.

Definition sameShapeCom:forall(A W:Set) (rp1 rp2:rule_pattern)(Gamma:context A W)i,
                        same_shape (pcomma i rp1 rp2) Gamma->
                        {Gamma1:context A W&{Gamma2:context  A W|Gamma=(Comma i Gamma1 Gamma2) /\
                                      same_shape rp1 Gamma1 /\same_shape rp2 Gamma2}}.
 intros.
 generalize H; clear H.
 case Gamma; intros.
 cut False.
 tauto.
 inversion H.
 econstructor; econstructor.
 split.
 cut (i = i0).
 intro; subst; auto.
 inversion H.
 auto.
 split; inversion H; auto.
 cut False.
 tauto.
 inversion H.
Defined.

Definition sameShapeDiam:forall(A W:Set) (rp1:rule_pattern)(Gamma:context A W)i,
                        same_shape (pdiam i rp1) Gamma->
                        {Gamma1:context A W|Gamma=(TDiamond i Gamma1) /\
                                    same_shape rp1 Gamma1}.
 intros.
 generalize H; clear H.
 case Gamma.
 intros; cut False.
 tauto.
 inversion H.
 intros; cut False.
 tauto.
 inversion H.
 intros.
 econstructor; cut (j = i).
 intro; subst.
 split.
 auto.
 inversion H.
 auto.
 inversion H; auto.
Defined.

(* compilation from abstract rules to concrete rules
    with the help of Paul Gloess *)

Fixpoint access (A W:Set)(eqdecI :eqdec I)(eqdecJ :eqdec J)
(rp:rule_pattern)(j:nat){struct rp}:(context A W)->(option (context A W))*bool:=
match rp with
|pvar i =>match (eq_nat_dec i j) with
          |right _ =>fun Gamma:(context A W) =>(None, true)
          |left _ =>fun Gamma:(context A W) =>((Some Gamma),true)
          end
|pcomma i rp1 rp2=>(fun Gamma:context A W=>
                                  match Gamma with
                                  |Comma l Gamma1 Gamma2 =>match (eqdecI l i) with
                                   |right _ =>(None,false)
                                   |left _ =>match (access eqdecI eqdecJ rp1 j Gamma1) with
                                            |(None, false)=> (None,false)
                                            |(None,true) =>(access eqdecI eqdecJ rp2 j Gamma2)
                                            |((Some Delta),b)=> match (access eqdecI eqdecJ rp2 j Gamma2) with
                                                    |((Some _), _ )=>(None,false)
                                                    |(None,true) => ((Some Delta),b)
                                                    |(None, false)=>(None,false)
                                                     end end
                                    end
                                  |other =>(None,false)
                               end)
|pdiam i rp1 =>(fun Gamma:context A W=>
                                  match Gamma with
                                  |TDiamond l Gamma1 =>
                                 match (eqdecJ i l) with
                                   |right _ => (None,false)
                                   |left _ =>(access eqdecI eqdecJ rp1 j Gamma1)
                                   end
                                  |other => (None,false)
                                 end)
end.

Fixpoint compile (A W:Set)(eqdecI :eqdec I)(eqdecJ:eqdec J)
(rp1 rp2:rule_pattern){struct rp2}:(context A W) -> (option (context A W)):=
match rp2 with
|pvar i => fun Gamma:(context A W)=> match (access eqdecI eqdecJ rp1 i Gamma) with
           |((Some Gamma') ,_ )=> Some Gamma'
           |other =>None
         end
|pcomma i r1 r2=>fun Gamma:(context A W) => match (compile eqdecI eqdecJ rp1 r1 Gamma) with
                                             |None =>None
                                             |Some Delta1 => match (compile eqdecI eqdecJ rp1 r2 Gamma) with
                                                  |None =>None
                                                  |Some Delta2 =>Some (Comma i Delta1 Delta2)
                                                  end
                                              end
|pdiam i r1=>fun Gamma:(context A W) =>match (compile eqdecI eqdecJ rp1 r1 Gamma) with
                                             |None =>None
                                             |Some Delta1 =>Some (TDiamond i Delta1)
                                              end
end.

 Definition apply_rule (st:structrule)(eqdecI: eqdec I)(eqdecJ : eqdec
       J)(A W:Set): context A W -> option (context A W):=
match st with
| (r1,r2)=>compile  eqdecI eqdecJ r1 r2
end.

Lemma subCont_length:forall (A W:Set) rp (Gamma:context A W) l,
                      hasSubContexts rp Gamma l->
                      length l=length (flatten_pattern rp).
Proof.
 induction 1.
 simpl in |- *; auto.
 simpl in |- *.
 rewrite length_app.
 rewrite length_app.
 auto.
 simpl in |- *; auto.
Qed.

 Parameter bapply_rule :  structrule -> eqdec I -> eqdec J -> forall A,
       bcontext A -> option (bcontext A).

 (* extension is the data type that represents the set of structural rules*)
 Inductive extension : Type :=
      NL : extension
    | add_rule : structrule -> extension -> extension.

 Fixpoint add_extension (e e':extension) {struct e} :extension :=
  match e with
  | NL => e'
  | add_rule r e'' => add_rule r (add_extension e'' e')
  end.

 Inductive in_extension (s: structrule) :extension -> Prop :=
 | in_extension_rule : forall e, in_extension s (add_rule s e)
 | in_extension_right : forall e s',
                      in_extension s e ->
                      in_extension s (add_rule s' e).

 Section rep.

 Variables A W: Set.

 (* replace Delta Delta' Gamma Gamma' means :
    Gamma = Gamma0[Delta] and Gamma'=Gamma0[Delta']
    replacement at one location (one hole in Gamma0)
 *)

 Inductive replace (Delta Delta':context A W):
    context A W -> context A W  -> Set :=
   | replaceRoot :  replace Delta Delta' Delta Delta'
   | replaceLeft :
       forall (Gamma1 Gamma2 Gamma3:context A W) (i:I),
         replace Delta Delta' Gamma1 Gamma2 ->
         replace  Delta Delta'  (Comma i Gamma1 Gamma3)
                                (Comma i Gamma2 Gamma3)
   | replaceRight :
       forall (Gamma1 Gamma2 Gamma3:context A W) (i:I),
         replace Delta Delta' Gamma1 Gamma2 ->
         replace  Delta Delta'  (Comma i Gamma3 Gamma1)
                                (Comma i Gamma3 Gamma2)
    | replaceDiamond :
       forall (Gamma1 Gamma2 :context A W) (j:J),
         replace Delta Delta' Gamma1 Gamma2 ->
         replace Delta Delta' (TDiamond j Gamma1) (TDiamond j Gamma2).

 (* generalisation of replace to any number of holes in Gamma0 *)
 Inductive par_replace (Delta Delta':context A W):
    context A W -> context A W -> Set :=
   | par_zero : forall Gamma, par_replace Delta Delta' Gamma Gamma
   | par_root :  par_replace Delta Delta' Delta Delta'
   | par_replaceBin :
       forall (Gamma1 Gamma2 Gamma3 Gamma4 :context A W) (i:I),
         par_replace Delta Delta' Gamma1 Gamma3 ->
         par_replace Delta Delta' Gamma2 Gamma4 ->
         par_replace  Delta Delta'  (Comma i Gamma1 Gamma2)
                                (Comma i Gamma3 Gamma4)
   | par_replaceDiamond :
       forall (Gamma1 Gamma2 :context A W) (j:J),
         par_replace Delta Delta' Gamma1 Gamma2 ->
         par_replace Delta Delta' (TDiamond j Gamma1) (TDiamond j Gamma2).

  Definition repToParRep:forall (T1 T2 T3 T4:context A W),
     replace T1 T2 T3 T4 -> par_replace T1 T2 T3 T4.
  induction 1; repeat constructor; auto.
Defined.

  Definition zfill_to_replace_0 :
   forall (Delta1 Delta2: context A W)(ZGamma : zcontext A W)
     (Gamma1 Gamma2:context A W),
     replace Delta1 Delta2 Gamma1 Gamma2 ->
     replace Delta1 Delta2 (zfill ZGamma Gamma1) (zfill ZGamma Gamma2).

  induction ZGamma.
  simpl;auto.
  simpl; intros.
  apply IHZGamma.
  constructor 2.
  auto.
  simpl; intros.
  apply IHZGamma.
  constructor 3.
  auto.
  simpl; intros.
  apply IHZGamma.
  constructor 4.
  auto.
Defined.

Definition zfill_to_replace :
   forall (ZGamma : zcontext A W)(Delta1 Delta2: context A W),
     replace Delta1 Delta2 (zfill ZGamma Delta1) (zfill ZGamma Delta2).

  intros; apply zfill_to_replace_0.
  constructor 1.
 Defined.

Definition replace_to_zfill:
   forall (Delta1 Delta2 Gamma1 Gamma2: context A W),
    replace Delta1 Delta2 Gamma1 Gamma2 ->
      {ZGamma : zcontext A W | zfill ZGamma Delta1 = Gamma1 /\
                               zfill ZGamma Delta2 = Gamma2}.
   induction 1.
   exists (zroot A W).
   simpl; split; auto.
   case IHreplace; intros Z1 [e1 e2].
   exists (zgraft Z1 (zleft i (zroot _ _)  Gamma3)).
   rewrite zgraft_def.
   rewrite zgraft_def.
   simpl.
   rewrite e1;rewrite e2; auto.
   case IHreplace; intros Z1 [e1 e2].
   exists (zgraft Z1 (zright i Gamma3  (zroot _ _))).
   rewrite zgraft_def.
   rewrite zgraft_def.
   simpl.
   simpl.
   rewrite e1;rewrite e2; auto.
   case IHreplace; intros Z1 [e1 e2].
   exists (zgraft Z1 (zdown j (zroot _ _))).
   rewrite zgraft_def.
   rewrite zgraft_def.
   simpl.
   rewrite e1;rewrite e2; auto.
Defined.

Definition fill_to_par_replace :
     forall (HGamma : hcontext A W)(Delta1 Delta2: context A W),
     par_replace Delta1 Delta2 (fill HGamma Delta1) (fill HGamma Delta2).

 simple induction HGamma.
 simpl.
 constructor 1.
 simpl; intros.
 constructor 3.
 auto.
 auto.
 simpl; constructor 4; auto.
 simpl;constructor 2.
Defined.

Definition par_replace_to_fill:
   forall (Delta1 Delta2 Gamma1 Gamma2: context A W),
    par_replace Delta1 Delta2 Gamma1 Gamma2 ->
      {HGamma : hcontext A W | fill HGamma Delta1 = Gamma1 /\
                               fill HGamma Delta2 = Gamma2}.
    induction 1.
    elim Gamma.
    intros r f;exists (hres r f);simpl.
    split;auto.
    intros.
    case H; intros HG1 H1; case H0; intros HG2 H2.
    exists (hComma i HG1 HG2); simpl; auto.
    case H1; case H2; intros.
    rewrite H3; rewrite H4 ; rewrite H5 ; rewrite H6.
    split; auto.
    intros.
    case H; intros HG1 [H1 H2].
    exists (hDiamond j HG1); simpl.
    rewrite H1; rewrite H2; auto.
    exists (hole A W).
    simpl; auto.
    case IHpar_replace1; intros HG1 [e1 e2].
    case IHpar_replace2; intros HG2 [e3 e4].
    exists (hComma i HG1 HG2).
    simpl; rewrite e1;rewrite e2;rewrite e3;rewrite e4; auto.
    case IHpar_replace; intros HG1 [e1 e2].
    exists (hDiamond j HG1).
    simpl;rewrite e1; rewrite e2;auto.
 Defined.

(* same_shape and par_replace *)
Lemma same_shape_par_replace:forall (r:resource W)(Delta Gamma1
Gamma2:context A W)A1,
           par_replace (res r A1) Delta Gamma1 Gamma2->
	   forall (r1:rule_pattern),same_shape r1 Gamma1 ->
                                   same_shape r1 Gamma2.
 induction 1.
 auto.
 intros.
 inversion H.
 constructor 1.
 intros.
 inversion H1.
 constructor.
 constructor.
 eauto.
 eauto.
 intros.
 inversion H0; constructor.
 eauto.
Qed.

 Section struct_replace_def.

             Variables  (decI : eqdec I)
                        (decJ : eqdec J).

             Variable   (Ru : structrule).
 (* application of the structural rule Ru to a context Delta
    gives Delta'
 *)

 Inductive struct_replace (Delta Delta': context A W):
   context A W -> context A W -> Set :=
   | struct_replaceRoot :
        apply_rule Ru decI decJ Delta = Some Delta' ->
          struct_replace Delta Delta' Delta Delta'
   | struct_replaceLeft :
       forall (Gamma1 Gamma2 Gamma3:context A W) (i:I),
         struct_replace Delta Delta' Gamma1 Gamma2 ->
         struct_replace  Delta Delta'  (Comma i Gamma1 Gamma3)
                                (Comma i Gamma2 Gamma3)
   | rstruct_replaceRight :
       forall (Gamma1 Gamma2 Gamma3:context A W) (i:I),
         struct_replace Delta Delta' Gamma1 Gamma2 ->
         struct_replace  Delta Delta'  (Comma i Gamma3 Gamma1)
                                (Comma i Gamma3 Gamma2)
   | struct_replaceDiamond :
       forall (Gamma1 Gamma2 :context A W) (j:J),
         struct_replace Delta Delta' Gamma1 Gamma2 ->
         struct_replace Delta Delta' (TDiamond j Gamma1) (TDiamond j Gamma2).

  Definition zfill_to_struct_replace_0 :
   forall (ZGamma : zcontext A W)(Delta1 Delta2: context A W),
     apply_rule Ru decI decJ Delta1 = Some Delta2 ->
   forall  (Gamma1 Gamma2:context A W),
     struct_replace Delta1 Delta2 Gamma1 Gamma2 ->
     struct_replace Delta1 Delta2 (zfill ZGamma Gamma1) (zfill ZGamma Gamma2).

  induction ZGamma.
  simpl;auto.
  simpl; intros.
  apply IHZGamma.
  auto.
  constructor 2.
  auto.
  simpl; intros.
  apply IHZGamma.
  auto.
  constructor 3.
  auto.
  simpl; intros.
  apply IHZGamma.
  auto.
  constructor 4.
  auto.
Defined.

Definition struct_replace_as_zfill :
   forall (ZGamma : zcontext A W)(Delta Delta':context A W),
      apply_rule Ru decI decJ Delta = Some Delta' ->
      struct_replace Delta Delta' (zfill ZGamma Delta) (zfill ZGamma Delta').

 intros.
 apply zfill_to_struct_replace_0.
 auto.
 constructor 1.
 auto.
Defined.

Definition struct_replace_to_zfill :
   forall (Gamma Gamma' Delta Delta':context A W),
   struct_replace Delta Delta' Gamma Gamma' ->
   {ZGamma:zcontext A W |
     Gamma = zfill ZGamma Delta /\ Gamma' = zfill ZGamma Delta' /\
     apply_rule Ru decI decJ Delta = Some Delta'}.
 induction 1.
 exists (zroot A W);simpl; auto.
 case IHstruct_replace; intros ZG1 [e1 [e2 e3]].
 exists (zgraft ZG1 (zleft i (zroot _ _)  Gamma3)).
 rewrite zgraft_def.
 rewrite zgraft_def.
 simpl.
 rewrite e1;rewrite e2; auto.
 case IHstruct_replace; intros ZG1 [e1 [e2 e3]].
 exists (zgraft ZG1 (zright i Gamma3  (zroot _ _))).
 rewrite zgraft_def.
 rewrite zgraft_def.
 simpl.
 rewrite e1;rewrite e2; auto.
 case IHstruct_replace; intros ZG1 [e1 [e2 e3]].
 exists (zgraft ZG1 (zdown j  (zroot _ _))).
 rewrite zgraft_def.
 rewrite zgraft_def.
 simpl.
 rewrite e1;rewrite e2; auto.
Defined.

(*
Definition struct_replace_rep:forall (Delta1 Delta2 Gamma1 Gamma2 :context  A W),
                              apply_rule Ru decI decJ Delta1=Some Delta2 ->
                              replace Delta2 Delta1 Gamma2 Gamma1->
                              struct_replace Delta1 Delta2 Gamma1 Gamma2.
*)
End struct_replace_def.
End rep.
End Main.
End Definitions.

Section replace_props.
 Definition replace_to_par : forall I J A W
                           (Delta Delta' Gamma Gamma': context I J A W),
                          replace Delta Delta' Gamma Gamma' ->
                          par_replace Delta Delta' Gamma Gamma'.
 induction 1.
 constructor 2.
 constructor 3;auto.
 constructor 1.
 constructor 3;auto.
 constructor 1.
 constructor 4;auto.
Defined.

Definition replaceProp:forall (I J A W  : Set)(T1 T2 T3 T4 T5:context I J A W),
                         replace T1 T2 T3 T4 ->
                         {T6:context I J A W & (replace T1 T5 T3 T6 *
                                               replace T5 T2 T6 T4)%type}.
 induction 1.
 exists T5.
 split.
 constructor 1.
 constructor.
 elim IHreplace.
 intros.
 exists (Comma i x Gamma3);split; constructor;tauto.
 elim IHreplace; intros.
 exists (Comma i Gamma3 x); split; constructor 3;tauto.
 elim IHreplace.
 intros.
 exists (TDiamond j x); split; constructor 4; tauto.
Defined.

Definition replaceParCom: forall (I J A W  : Set)
                                 (A1:resource W)(f1: Form  I J A)
                                 (Delta Delta1 Delta2 Gamma:context I J A W)
                                 (i:I),
  par_replace (res A1 f1) Delta (Comma i Delta1 Delta2) Gamma ->
  {Delta1' :context I J A W  &
     {Delta2' :context I J A W &
        {H1: par_replace (res A1 f1) Delta Delta1 Delta1' &
           { H2 : par_replace (res A1 f1) Delta Delta2 Delta2'
                   | Gamma =Comma i Delta1' Delta2'}}}}.

 intros.
 inversion H.
 exists Delta1.
 exists Delta2.
 exists (par_zero (res A1 f1) Delta Delta1).
 exists (par_zero (res A1 f1) Delta Delta2).
 auto.
 exists Gamma3.
 exists Gamma4.
 exists H4.
 exists H5.
 auto.
Defined.

Definition replaceParDiam:forall (I J A W  : Set)
                                 (A1:resource W)
                                 (f1: Form  I J A)
                                 (Delta Delta1  Gamma:context I J A W)
                                 (j:J),
 par_replace (res A1 f1) Delta (TDiamond j Delta1) Gamma ->
  { Delta2 :context I J A W &
   { H :par_replace (res A1 f1) Delta Delta1 Delta2 |
         Gamma = TDiamond j Delta2}}.

 intros.
 inversion H.
 exists Delta1.
 exists (par_zero (res A1 f1) Delta Delta1).
 auto.
 exists Gamma2.
 exists H3.
 auto.
Defined.

Definition doubleReplacePar:
   forall (I J A W  : Set) (A1:resource W)(f1: Form  I J A)
          (Delta1 Delta2 Gamma1 Gamma2 Delta :context I J A W),
   replace Delta1 Delta2 Gamma1 Gamma2 ->
   forall (Gamma':context I J A W),
     par_replace (res A1 f1) Delta Gamma2 Gamma' ->
     {Delta2' :context I J A W &
      {Gamma1' :context I J A W &
            (par_replace (res A1 f1) Delta Gamma1 Gamma1' *
              ((par_replace  (res A1 f1) Delta Delta2 Delta2') *
                 (replace Delta1 Delta2' Gamma1' Gamma'))%type)%type}}.

 induction 1; intros.
 exists Gamma'.
 exists Delta1.
 split.
 constructor.
 split.
 auto.
 constructor.
 elim (replaceParCom H0).
 intros Gamma4 H1; elim H1; clear H1; intros Delta2' H1; elim H1; clear H1;
 intros H1 H2.
 elim H2; clear H2; intros H2 H3.
 elim (IHreplace Gamma4 H1).
 intros Gamma5 H4.
 elim H4; clear H4; intros Gamma6 H4.
 exists Gamma5.
 exists (Comma i Gamma6 Delta2').
 split.
 constructor; tauto.
 split.
 tauto.
 rewrite H3; constructor; tauto.
 elim (replaceParCom H0).
 intros Gamma4 H1; elim H1; clear H1; intros Delta2' H1; elim H1; clear H1;
 intros H1 H2.
 elim H2; clear H2; intros H2 H3.
 elim (IHreplace Delta2' H2).
 intros Gamma5 H4.
 elim H4; clear H4; intros Gamma6 H4.
 exists Gamma5.
 exists (Comma i Gamma4 Gamma6).
 split.
 constructor; tauto.
 split.
 tauto.
 rewrite H3; constructor; tauto.
 elim (replaceParDiam H0).
 intros Gamma3 H1.
 elim H1; clear H1; intros H1 H2.
 elim (IHreplace Gamma3 H1).
 intros Gamma4 H3.
 elim H3; clear H3; intros Gamma5 H3.
 exists Gamma4.
 exists (TDiamond j Gamma5).
 split.
 constructor; tauto.
 split.
 tauto.
 rewrite H2; constructor; tauto.
Defined.

(* gives a sufficient condition to ensure cut rule :
   At present, it is defined abstractly in terms of
   a property of substitution.
   Must be changed in further releases.
*)
Definition weak_sahlqvist_rule (I J :Set) (s:structrule I J) :=
 forall  (decI : eqdec I)(decJ : eqdec J) A W
         (T1 T2 Delta T1': context I J A W)
         (A1:resource W)(f1: Form I J A),
          apply_rule s decI decJ  T1 = Some T2 ->
          par_replace (res A1 f1) Delta T1 T1' ->
           {T2':context I J A W  &
            {H:par_replace (res A1 f1) Delta T2 T2'
             | apply_rule s decI decJ  T1' = Some T2'}}.

Definition weak_sahlqvist_ext (I J:Set)(R:extension I J):=
  forall (s:structrule I J) ,
    in_extension s R ->
    weak_sahlqvist_rule  s.

Definition structrule_subst_commute:forall (I J A W:Set) (decI : eqdec I)
                  (decJ : eqdec J)(ru:structrule I J ),
      weak_sahlqvist_rule  ru ->
    forall (T1 T2 Gamma Gamma' Delta:context I J A W)
       (A1:resource W)(f1: Form  I J A),
    struct_replace  decI decJ ru T1 T2 Gamma Gamma'->
   forall (Gamma0':context I J A W),
       (par_replace (res A1 f1) Delta Gamma Gamma0')->
          {T1':context I J A W &
              {T2':context I J A W &
                {Gamma1 :context I J A W &
                    (((par_replace  (res A1 f1) Delta T1 T1') *
                      (par_replace  (res A1 f1) Delta T2 T2'))%type *
                             ((par_replace  (res A1 f1) Delta Gamma' Gamma1)*
                                               (struct_replace  decI decJ  ru
                                                                T1'  T2'
                                               Gamma0' Gamma1))%type)%type}}}.
  induction 2.
  intros.
  unfold weak_sahlqvist_rule in X.
  elim (X decI decJ A W T1 T2 Delta Gamma0' A1 f1 e H).
  intros Gamma1 H1.
  elim H1; clear H1; intros H1 H2.
  exists Gamma0'.
  exists Gamma1.
  exists Gamma1.
  split; split; auto.
  econstructor; eauto.
  intros.
  elim (replaceParCom H0).
  intros Gamma4 H2; elim H2; clear H2; intros Delta2' H2; elim H2; clear H2;
  intros H2 H3.
  elim H3; clear H3; intros H3 H4.
  elim (IHstruct_replace Gamma4 H2).
  intros Gamma5 H5; elim H5; clear H5; intros T2' H5.
  elim H5; clear H5; intros Gamma6 H5.
  exists Gamma5.
  exists T2'.
  exists (Comma i Gamma6 Delta2').
  split; split.
  tauto.
  tauto.
  constructor; tauto.
  rewrite H4; constructor; tauto.
  intros.
  elim (replaceParCom H0).
  intros Gamma4 H2; elim H2; clear H2; intros Delta2' H2; elim H2; clear H2;
  intros H2 H3; elim H3; clear H3; intros H3 H4.
  elim (IHstruct_replace Delta2' H3).
  intros Gamma5 H5; elim H5; clear H5; intros T2' H5.
  elim H5; clear H5; intros Gamma6 H5.
  exists Gamma5.
  exists T2'.
  exists (Comma i Gamma4 Gamma6).
  split; split.
  tauto.
  tauto.
  constructor; tauto.
  rewrite H4; constructor; tauto.
  intros.
  elim (replaceParDiam H0).
  intros Gamma3 H2.
  elim H2; clear H2; intros H2 H3.
  elim (IHstruct_replace Gamma3 H2).
  intros Gamma4 H4; elim H4; clear H4;
  intros T2' H4; elim H4; clear H4;
  intros Gamma5 H4.
  exists Gamma4.
  exists T2'.
  exists (TDiamond  j Gamma5).
  split; split.
  tauto.
  tauto.
  constructor; tauto.
  rewrite H3; constructor; tauto.
Defined.

End replace_props.

Implicit Arguments hyp [W].
Implicit Arguments pvar [I J].
Implicit Arguments pcomma [I J].
Implicit Arguments pdiam [I J].
Implicit Arguments NL [I J ].
Implicit Arguments res [W].
Implicit Arguments res [I J A W].
Implicit Arguments At [A I J].

Hint Resolve zgraft_def no_holes zfill_fill_0 zfill_fill strip_match match_strip
zfill_to_replace struct_replace_as_zfill:ctl_db.
Hint Resolve subCont_length isIncluded_to_isIncl allDistinct_to_distinct.

Notation "r1 'U' r2":=(add_rule r1 r2)(at level 30).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e321m9_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Program MathClasses.interfaces.canonical_names util.Container QArith QMinMax CRlattice.

Definition Range (T: Type) := prod T T.

#[global]
Instance in_QRange: Container Q (Range Q)
  := λ r x, (Qmin (fst r) (snd r) <= x <= Qmax (fst r) (snd r))%Q.

#[global]
Instance in_CRRange: Container (msp_car CR) (Range (msp_car CR))
  := λ r x,
     (ucFun (ucFun CRmin (fst r)) (snd r) <= x)%CR
     ∧ (x <= ucFun (ucFun CRmax (fst r)) (snd r))%CR.

#[global]
Instance in_sig_Range `{Container A (Range A)} (P: A → Prop): Container (sig P) (Range (sig P))
  := λ r x, In (` (fst r), ` (snd r)) (` x).


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs
 Require Import edone bcase fset base modular_hilbert sltype.
From CompDecModal.CTL
 Require Import CTL_def hilbert.
Import IC.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Translation of History Rules to Hilbert Refutations *)

Definition AU_ (u s t : form) := AU (s :/\: u) (t :/\: u).

Lemma AUH_hil (s t u v : form) :
  prv (u :/\: t ---> Bot) ->
  prv (u ---> s ---> ~~: AX (AU_ (~~: u :/\: v) s t)) ->
  prv (u ---> AU_ v s t ---> Bot).
Proof.
  move => H0 H1.
  suff sf: prv (AU_ v s t ---> AU_ (~~: u :/\: v) s t).
  { do 2 Intro.
    Have (~~: t); [Intro; ApplyH H0; by ApplyH axAI| Intro].
    Have ((s :/\: v) :/\: AX (AU_ v s t)).
    + Rev* 1. rewrite /AU_. rewrite -> axAUeq at 1. rewrite /Or.
      Intro. Apply. ApplyH axAcase. do 2 Intro. by Apply* 3.
    + rewrite -> sf at 2. do 2 ApplyH axAcase. do 2 Intro. by ApplyH H1. }
  apply: rAU_ind.
  - rule axAcase. do 2 Intro. ApplyH axAUI. ApplyH axAI.
    ApplyH axAI. Intro. ApplyH H0. by ApplyH axAI.
  - rule axAcase. do 3 Intro. ApplyH axAUf. ApplyH axAI.
    ApplyH axAI. Intro. by ApplyH H1.
Qed.

Definition EU_ (H s t : form) := EU (s :/\: H) (t :/\: H).

Lemma ARH_hil (s t C H : form) :
  prv (t ---> ~~: C) ->
  prv (EX (EU_ (~~: C :/\: H) s t) ---> s ---> ~~: C) ->
  prv (C ---> EU_ H s t ---> fF).
Proof.
  move => H0 H1.
  suff sf: prv (EU_ H s t ---> EU_ (~~: C :/\: H) s t).
  { do 2 Intro.
    Have (~~: t); [Intro; ApplyH H0; by ApplyH axAI| Intro].
    Have ((s :/\: H) :/\: EX (EU_ H s t)).
    + Rev* 1. rewrite /EU_. rewrite -> axEUeq at 1. rewrite /Or.
      Intro. Apply. ApplyH axAcase. do 2 Intro. by Apply* 3.
    + rewrite -> sf at 2. do 2 ApplyH axAcase. do 3 Intro. by ApplyH H1. }
  apply: EU_ind.
  - rule axAcase. do 2 Intro. ApplyH axEUI. ApplyH axAI.
    ApplyH axAI. Intro. by ApplyH H0.
  - rule axAcase. do 3 Intro. ApplyH axEUI2. ApplyH axAI.
    ApplyH axAI. Intro. by ApplyH H1.
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sha_sel_sel_equ_reduce :
  forall T1 x1 L1 ss1 T1', T1 = (t_sha_sel x1 L1 ss1 T1') ->
                      forall T2 x2 L2 T2', T2 = (t_sel_equ x2 L2 T2') ->
                                      subtype T1 T2 = orb (subtype T1 T2')
                                                          (subtype T1' T2).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import syntax.
Require Import ZArith.

(* Arithmetic operations that will be used for validation, e.g. add
for the addition associativity-related optimization.  Temporarily, the
operations are defined by plus of ZArith, but later, it should be
defined by operations that are used by vellvm for soundness proof. *)

Module INTEGER_OPERATION.
  Definition add (lhs rhs : INTEGER.t) : INTEGER.t := (lhs + rhs)%Z.
  Definition sub (lhs rhs : INTEGER.t) : INTEGER.t := (lhs - rhs)%Z.
End INTEGER_OPERATION.


(**
Here we define the signature for monoidal objects.
Basically, these satisfy the same laws as monoidal categories, but instead, the laws are formulated using HIT signature.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

Require Import 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.

(** The signature *)
Definition monoidal_point_constr
  : poly_code
  := C unit_one_type + I * I.

Inductive monoidal_paths : UU :=
| lunit : monoidal_paths
| runit : monoidal_paths
| massoc : monoidal_paths.

Inductive monoidal_homots : UU :=
| triangle : monoidal_homots
| pentagon : monoidal_homots.

Definition monoidal_paths_args
  : monoidal_paths → poly_code.
Proof.
  intro i.
  induction i.
  - (* lunit *)
    exact I.
  - (* runit *)
    exact I.
  - (* massoc *)
    exact (I * I * I).
Defined.

Definition unit_endpoint
           (P : poly_code)
  : endpoint monoidal_point_constr P I
  := comp
       (comp
          (c P (tt : unit_one_type))
          (ι₁ _ _))
       constr.

Definition mult_endpoint
           {P : poly_code}
           (e₁ e₂ : endpoint monoidal_point_constr P I)
  : endpoint monoidal_point_constr P I
  := comp
       (comp
          (pair e₁ e₂)
          (ι₂ _ _))
       constr.

Definition monoidal_paths_lhs
           (i : monoidal_paths)
  : endpoint monoidal_point_constr (monoidal_paths_args i) I.
Proof.
  induction i.
  - (* lunit *)
    exact (mult_endpoint
             (unit_endpoint _)
             (id_e _ _)).
  - (* runit *)
    exact (mult_endpoint
             (id_e _ _)
             (unit_endpoint _)).
  - (* massoc *)
    exact (mult_endpoint
             (comp (π₁ _ _) (π₁ _ _))
             (mult_endpoint
                (comp (π₁ _ _) (π₂ _ _))
                (π₂ _ _))).
Defined.

Definition monoidal_paths_rhs
           (i : monoidal_paths)
  : endpoint monoidal_point_constr (monoidal_paths_args i) I.
Proof.
  induction i.
  - (* lunit *)
    exact (id_e _ _).
  - (* runit *)
    exact (id_e _ _).
  - (* massoc *)
    exact (mult_endpoint
             (mult_endpoint
                (comp (π₁ _ _) (π₁ _ _))
                (comp (π₁ _ _) (π₂ _ _)))
             (π₂ _ _)).
Defined.

Definition monoidal_homots_point_arg
           (i : monoidal_homots)
  : poly_code.
Proof.
  induction i.
  - (* triangle *)
    exact (I * I).
  - (* pentagon *)
    exact (I * I * I * I).
Defined.

Definition monoidal_homots_point_left_endpoint
           (i : monoidal_homots)
  : endpoint monoidal_point_constr (monoidal_homots_point_arg i) I.
Proof.
  induction i.
  - (* triangle *)
    exact (mult_endpoint
             (π₁ _ _)
             (mult_endpoint
                (unit_endpoint _)
                (π₂ _ _))).
  - (* pentagon *)
    exact (mult_endpoint
             (comp (π₁ _ _) (comp (π₁ _ _) (π₁ _ _)))
             (mult_endpoint
                (comp (π₁ _ _) (comp (π₁ _ _) (π₂ _ _)))
                (mult_endpoint
                   (comp (π₁ _ _) (π₂ _ _))
                   (π₂ _ _)))).
Defined.

Definition monoidal_homots_point_right_endpoint
           (i : monoidal_homots)
  : endpoint monoidal_point_constr (monoidal_homots_point_arg i) I.
Proof.
  induction i.
  - (* triangle *)
    exact (mult_endpoint
             (π₁ _ _)
             (π₂ _ _)).
  - (* pentagon *)
    exact (mult_endpoint
             (mult_endpoint
                (mult_endpoint
                   (comp (π₁ _ _) (comp (π₁ _ _) (π₁ _ _)))
                   (comp (π₁ _ _) (comp (π₁ _ _) (π₂ _ _))))
                (comp (π₁ _ _) (π₂ _ _)))
             (π₂ _ _)).
Defined.

Definition lunit_homot_endpoint
           {P : poly_code}
           (e : endpoint monoidal_point_constr P I)
  : homot_endpoint
      monoidal_paths_lhs
      monoidal_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint (unit_endpoint P) e)
      e.
Proof.
  refine (trans_e
            _
            (comp_id_r _)).
  refine (trans_e
            _
            (path_constr
               lunit
               _)).
  simpl.
  unfold mult_endpoint.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  unfold unit_endpoint.
  refine (trans_e
            (path_pair _ _)
            (inv_e (comp_pair _ _ _))).
  - refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply path_inl.
    apply inv_e.
    apply comp_constant.
  - apply inv_e.
    apply comp_id_r.
Defined.

Definition runit_homot_endpoint
           {P : poly_code}
           (e : endpoint monoidal_point_constr P I)
  : homot_endpoint
      monoidal_paths_lhs
      monoidal_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint e (unit_endpoint _))
      e.
Proof.
  refine (trans_e
            _
            (comp_id_r _)).
  refine (trans_e
            _
            (path_constr
               runit
               _)).
  simpl.
  unfold mult_endpoint.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  refine (trans_e
            _
            (inv_e
               (comp_assoc _ _ _))).
  apply ap_e.
  unfold unit_endpoint.
  refine (trans_e
            (path_pair _ _)
            (inv_e (comp_pair _ _ _))).
  - apply inv_e.
    apply comp_id_r.
  - refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply path_inl.
    apply inv_e.
    apply comp_constant.
Defined.

Definition assoc_homot_endpoint
           {P : poly_code}
           (e₁ e₂ e₃ : endpoint monoidal_point_constr P I)
  : homot_endpoint
      monoidal_paths_lhs
      monoidal_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint
         e₁
         (mult_endpoint
            e₂
            e₃))
      (mult_endpoint
         (mult_endpoint
            e₁
            e₂)
         e₃).
Proof.
  unfold mult_endpoint.
  refine (trans_e
            _
            (trans_e
               (path_constr massoc (pair (pair e₁ e₂) e₃))
               _))
  ; simpl ; unfold mult_endpoint.
  - refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              _
              (inv_e (comp_assoc _ _ _))).
    apply ap_e.
    refine (trans_e
              (path_pair _ _)
              (inv_e (comp_pair _ _ _))).
    + apply inv_e.
      refine (trans_e
                (comp_assoc _ _ _)
                _).
      refine (trans_e
                (ap_e _ (pair_π₁ _ _))
                _).
      apply pair_π₁.
    + refine (trans_e
                _
                (inv_e (comp_assoc _ _ _))).
      apply ap_e.
      refine (trans_e
                _
                (inv_e (comp_assoc _ _ _))).
      apply ap_e.
      refine (trans_e
                (path_pair _ _)
                (inv_e (comp_pair _ _ _))).
      * apply inv_e.
        refine (trans_e
                  (comp_assoc _ _ _)
                  _).
        refine (trans_e
                  (ap_e _ (pair_π₁ _ _))
                  _).
        apply pair_π₂.
      * apply inv_e.
        apply pair_π₂.
  - refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_assoc _ _ _)
              _).
    apply ap_e.
    refine (trans_e
              (comp_pair _ _ _)
              (path_pair _ _)).
    + refine (trans_e
                (comp_assoc _ _ _)
                _).
      apply ap_e.
      refine (trans_e
                (comp_assoc _ _ _)
                _).
      apply ap_e.
      refine (trans_e
                (comp_pair _ _ _)
                (path_pair _ _)).
      * refine (trans_e
                  (comp_assoc _ _ _)
                  _).
        refine (trans_e
                  (ap_e _ (pair_π₁ _ _))
                  _).
        apply pair_π₁.
      * refine (trans_e
                  (comp_assoc _ _ _)
                  _).
        refine (trans_e
                  (ap_e _ (pair_π₁ _ _))
                  _).
        apply pair_π₂.
    + apply pair_π₂.
Defined.

Definition lwhisker_endpoint
           {P : poly_code}
           (e₁ : endpoint monoidal_point_constr P I)
           {e₂ e₃ : endpoint monoidal_point_constr P I}
           (h : homot_endpoint
                  monoidal_paths_lhs
                  monoidal_paths_rhs
                  (c P (tt : unit_one_type))
                  (c P (tt : unit_one_type))
                  e₂
                  e₃)
  : homot_endpoint
      monoidal_paths_lhs
      monoidal_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint e₁ e₂)
      (mult_endpoint e₁ e₃).
Proof.
  unfold mult_endpoint.
  use ap_e.
  use ap_e.
  use path_pair.
  - apply refl_e.
  - exact h.
Defined.

Definition rwhisker_endpoint
           {P : poly_code}
           {e₁ e₂ : endpoint monoidal_point_constr P I}
           (e₃ : endpoint monoidal_point_constr P I)
           (h : homot_endpoint
                  monoidal_paths_lhs
                  monoidal_paths_rhs
                  (c P (tt : unit_one_type))
                  (c P (tt : unit_one_type))
                  e₁
                  e₂)
  : homot_endpoint
      monoidal_paths_lhs
      monoidal_paths_rhs
      (c P (tt : unit_one_type))
      (c P (tt : unit_one_type))
      (mult_endpoint e₁ e₃)
      (mult_endpoint e₂ e₃).
Proof.
  unfold mult_endpoint.
  use ap_e.
  use ap_e.
  use path_pair.
  - exact h.
  - apply refl_e.
Defined.

Definition monoidal_homots_point_lhs
           (i : monoidal_homots)
  : homot_endpoint
      monoidal_paths_lhs
      monoidal_paths_rhs
      (c (monoidal_homots_point_arg i) (tt : unit_one_type))
      (c (monoidal_homots_point_arg i) (tt : unit_one_type))
      (monoidal_homots_point_left_endpoint i)
      (monoidal_homots_point_right_endpoint i).
Proof.
  induction i.
  - (* triangle *)
    exact (lwhisker_endpoint
             (π₁ I I)
             (lunit_homot_endpoint _)).
  - (* pentagon *)
    exact (trans_e
             (assoc_homot_endpoint _ _ _)
             (assoc_homot_endpoint _ _ _)).
Defined.

Definition monoidal_homots_point_rhs
           (i : monoidal_homots)
  : homot_endpoint
      monoidal_paths_lhs
      monoidal_paths_rhs
      (c (monoidal_homots_point_arg i) (tt : unit_one_type))
      (c (monoidal_homots_point_arg i) (tt : unit_one_type))
      (monoidal_homots_point_left_endpoint i)
      (monoidal_homots_point_right_endpoint i).
Proof.
  induction i.
  - (* triangle *)
    exact (trans_e
             (assoc_homot_endpoint _ _ _)
             (rwhisker_endpoint
                (π₂ I I)
                (runit_homot_endpoint _))).
  - (* pentagon *)
    exact (trans_e
             (lwhisker_endpoint
                _
                (assoc_homot_endpoint _ _ _))
             (trans_e
                (assoc_homot_endpoint _ _ _)
                (rwhisker_endpoint
                   _
                   (assoc_homot_endpoint _ _ _)))).
Defined.

Definition monoidal_signature
  : hit_signature.
Proof.
  simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _  ,, _ ,, _ ,, _ ,, _).
  - exact monoidal_point_constr.
  - exact monoidal_paths.
  - exact monoidal_paths_args.
  - exact monoidal_paths_lhs.
  - exact monoidal_paths_rhs.
  - exact monoidal_homots.
  - exact monoidal_homots_point_arg.
  - exact (λ _, C unit_one_type).
  - exact (λ _, @c _ _ unit_one_type tt).
  - exact (λ _, @c _ _ unit_one_type tt).
  - exact monoidal_homots_point_left_endpoint.
  - exact monoidal_homots_point_right_endpoint.
  - exact monoidal_homots_point_lhs.
  - exact monoidal_homots_point_rhs.
Defined.

(**
The projections of the algebra.
We do this both for path algebras and algebras.
This way we can reuse stuff for the builder
 *)
Section MonoidalPathAlgebraProjections.
  Variable (X : hit_path_algebra_one_types monoidal_signature).

  Definition monoidal_PA_carrier
    : one_type
    := pr11 X.

  Definition monoidal_PA_unit
    : monoidal_PA_carrier
    := pr21 X (inl tt).

  Definition monoidal_PA_mult
             (x y : monoidal_PA_carrier)
    : monoidal_PA_carrier
    := pr21 X (inr (x ,, y)).

  Definition monoidal_PA_lunit
             (x : monoidal_PA_carrier)
    : monoidal_PA_mult monoidal_PA_unit x
      =
      x
    := pr2 X lunit x.

  Definition monoidal_PA_runit
             (x : monoidal_PA_carrier)
    : monoidal_PA_mult x monoidal_PA_unit
      =
      x
    := pr2 X runit x.

  Definition monoidal_PA_assoc
             (x y z : monoidal_PA_carrier)
    : monoidal_PA_mult x (monoidal_PA_mult y z)
      =
      monoidal_PA_mult (monoidal_PA_mult x y) z
    := pr2 X massoc ((x ,, y) ,, z).

  Definition monoidal_triangle_left
             (x y : monoidal_PA_carrier)
    : maponpaths (λ z, monoidal_PA_mult x z) (monoidal_PA_lunit y)
      =
      sem_homot_endpoint_one_types
        (homot_left_path monoidal_signature triangle)
        (pr1 X) (pr2 X)
        (x,, y)
        (idpath tt).
  Proof.
    unfold monoidal_PA_mult, monoidal_PA_lunit.
    simpl.
    rewrite !pathscomp0rid.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_r.
      }
      apply maponpathscomp.
    }
    exact (maponpathscomp (λ q, inr (x,, q)) (pr21 X)  (pr2 X lunit y)).
  Qed.

  Definition monoidal_triangle_right
             (x y : monoidal_PA_carrier)
    : sem_homot_endpoint_one_types
        (homot_right_path monoidal_signature triangle)
        (pr1 X) (pr2 X)
        (x,, y)
        (idpath tt)
      =
      monoidal_PA_assoc x monoidal_PA_unit y
      @ maponpaths (λ z, monoidal_PA_mult z y) (monoidal_PA_runit x).
  Proof.
    unfold monoidal_PA_assoc, monoidal_PA_runit.
    simpl.
    rewrite !pathscomp0rid.
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_l.
      }
      exact (maponpathscomp (λ q, q ,, y) inr (pr2 X runit x)).
    }
    exact (maponpathscomp (λ q, inr (q,, y)) (pr21 X) (pr2 X runit x)).
  Qed.

  Definition monoidal_pentagon_left
             (w x y z : monoidal_PA_carrier)
    : monoidal_PA_assoc w x (monoidal_PA_mult y z)
      @ monoidal_PA_assoc (monoidal_PA_mult w x) y z
      =
      sem_homot_endpoint_one_types
        (homot_left_path monoidal_signature pentagon)
        (pr1 X) (pr2 X)
        (((w,, x),, y),, z)
        (idpath tt).
  Proof.
    simpl.
    rewrite !pathscomp0rid.
    apply idpath.
  Qed.

  Definition monoidal_pentagon_right
             (w x y z : monoidal_PA_carrier)
    : sem_homot_endpoint_one_types
        (homot_right_path monoidal_signature pentagon)
        (pr1 X) (pr2 X)
        (((w,, x),, y),, z)
        (idpath tt)
      =
      maponpaths (λ q, monoidal_PA_mult w q) (monoidal_PA_assoc x y z)
      @ monoidal_PA_assoc w (monoidal_PA_mult x y) z
      @ maponpaths (λ q, monoidal_PA_mult q z) (monoidal_PA_assoc w x y).
  Proof.
    simpl.
    rewrite !pathscomp0rid.
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply ap_pair_r.
        }
        apply maponpathscomp.
      }
      apply (maponpathscomp (λ q, inr (w ,, q)) (pr21 X)).
    }
    do 2 apply maponpaths.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply ap_pair_l.
      }
      apply (maponpathscomp (λ q, q ,, z) inr).
    }
    apply (maponpathscomp (λ q, inr (q ,, z)) (pr21 X)).
  Qed.
End MonoidalPathAlgebraProjections.

(** Projections for algebra *)
Section MonoidalAlgebraProjections.
  Variable (X : hit_algebra_one_types monoidal_signature).

  Definition monoidal_carrier
    : one_type
    := monoidal_PA_carrier (pr1 X).

  Definition monoidal_unit
    : monoidal_carrier
    := monoidal_PA_unit (pr1 X).

  Definition monoidal_mult
             (x y : monoidal_carrier)
    : monoidal_carrier
    := monoidal_PA_mult (pr1 X) x y.

  Definition monoidal_lunit
             (x : monoidal_carrier)
    : monoidal_mult monoidal_unit x
      =
      x
    := monoidal_PA_lunit (pr1 X) x.

  Definition monoidal_runit
             (x : monoidal_carrier)
    : monoidal_mult x monoidal_unit
      =
      x
    := monoidal_PA_runit (pr1 X) x.

  Definition monoidal_assoc
             (x y z : monoidal_carrier)
    : monoidal_mult x (monoidal_mult y z)
      =
      monoidal_mult (monoidal_mult x y) z
    := monoidal_PA_assoc (pr1 X) x y z.

  Definition monoidal_triangle
             (x y : monoidal_carrier)
    : maponpaths
        (λ z, monoidal_mult x z)
        (monoidal_lunit y)
      =
      (monoidal_assoc _ _ _)
      @ maponpaths
          (λ z, monoidal_mult z y)
          (monoidal_runit x).
  Proof.
    refine (_ @ pr2 X triangle (x ,, y) (idpath tt) @ _).
    - apply monoidal_triangle_left.
    - apply monoidal_triangle_right.
  Qed.

  Definition monoidal_pentagon
             (w x y z : monoidal_carrier)
    : monoidal_assoc w x (monoidal_mult y z)
      @ monoidal_assoc (monoidal_mult w x) y z
      =
      maponpaths
        (λ q, monoidal_mult w q)
        (monoidal_assoc x y z)
      @ monoidal_assoc w (monoidal_mult x y) z
      @ maponpaths
          (λ q, monoidal_mult q z)
          (monoidal_assoc w x y).
  Proof.
    refine (_ @ pr2 X pentagon (((w ,, x) ,, y) ,, z) (idpath tt) @ _).
    - apply monoidal_pentagon_left.
    - apply monoidal_pentagon_right.
  Qed.
End MonoidalAlgebraProjections.

(** Projections for algebra homomorphisms *)
Section MonoidalPreAlgMorphismProjections.
  Context {X Y : hit_algebra_one_types monoidal_signature}
          (f : pr11 X --> pr11 Y).

  Definition monoidal_map_carrier_PA
    := pr1 f.

  Definition monoidal_map_unit_PA
    := pr1 (pr2 f) (inl tt).

  Definition monoidal_map_mult_PA
             (x y : alg_carrier X)
    := pr1 (pr2 f) (inr (x ,, y)).

  Definition monoidal_map_lunit_r
             (x : alg_carrier X)
    : ((pr12 f) (inr ((pr211 X) (inl tt),, x))
      @ maponpaths
          (pr211 Y)
          (maponpaths
             inr
             (pathsdirprod
                ((pr12 f) (inl tt) @ idpath ((pr211 Y) (inl tt)))
                (idpath ((pr1 f) x))))) @ (pr21 Y) lunit ((pr1 f) x)
      =
      monoidal_map_mult_PA (monoidal_unit X) x
      @ maponpaths
          (λ z, monoidal_mult Y z (monoidal_map_carrier_PA x))
          monoidal_map_unit_PA
      @ monoidal_lunit Y (monoidal_map_carrier_PA x).
  Proof.
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          refine (!_).
          apply ap_pair_l.
        }
        apply maponpaths.
        apply pathscomp0rid.
      }
      apply (maponpathscomp (λ z, z ,, _) inr).
    }
    apply (maponpathscomp (λ z, inr (z ,, _)) (pr211 Y)).
  Qed.

  Definition monoidal_map_runit_r
             (x : alg_carrier X)
    : ((pr12 f) (inr (x,, (pr211 X) (inl tt)))
      @ maponpaths
          (pr211 Y)
          (maponpaths
             inr
             (pathsdirprod
                (idpath (pr1 f x))
                ((pr12 f) (inl tt) @ idpath ((pr211 Y) (inl tt))))))
      @ (pr21 Y) runit (pr1 f x)
      =
      monoidal_map_mult_PA x (monoidal_unit X)
      @ maponpaths
          (λ z, monoidal_mult Y (monoidal_map_carrier_PA x) z)
          monoidal_map_unit_PA
      @ monoidal_runit Y (monoidal_map_carrier_PA x).
  Proof.
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          refine (!_).
          apply ap_pair_r.
        }
        apply maponpaths.
        apply pathscomp0rid.
      }
      exact (maponpathscomp (λ z, pr1 f x ,, z) inr (pr12 f (inl tt))).
    }
    apply (maponpathscomp (λ z, inr (_ ,, z)) (pr211 Y)).
  Qed.

  Definition monoidal_map_assoc_l
             (x y z : monoidal_carrier X)
    : maponpaths
        monoidal_map_carrier_PA
        (monoidal_assoc X x y z)
      @ monoidal_map_mult_PA (monoidal_mult X x y) z
      @ maponpaths
          (λ q, monoidal_mult Y q (monoidal_map_carrier_PA z))
          (monoidal_map_mult_PA x y)
      =
      maponpaths
        (pr1 f)
        (monoidal_assoc X x y z)
      @ monoidal_map_mult_PA (monoidal_mult _ x y) z
      @ maponpaths
          (pr211 Y)
          (maponpaths
             inr
             (pathsdirprod
                (monoidal_map_mult_PA x y
                 @ maponpaths
                     (pr211 Y)
                     (maponpaths
                        inr
                        (pathsdirprod (idpath _) (idpath _))))
                (idpath _))).
  Proof.
    do 2 apply maponpaths.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          refine (!_).
          apply ap_pair_l.
        }
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply maponpaths.
          apply maponpaths.
          refine (!_).
          apply ap_pair_r.
        }
        simpl.
        apply pathscomp0rid.
      }
      simpl.
      exact (maponpathscomp (λ q, q ,, pr1 f z) inr _).
    }
    exact (maponpathscomp (λ q, inr (q ,, pr1 f z)) (pr211 Y) _).
  Qed.

  Definition monoidal_map_assoc_r
             (x y z : monoidal_carrier X)
    : monoidal_map_mult_PA x (monoidal_mult _ y z)
      @ maponpaths
          (pr211 Y)
          (maponpaths
             inr
             (pathsdirprod
                (idpath _)
                (monoidal_map_mult_PA y z
                 @ maponpaths
                     (pr211 Y)
                     (maponpaths
                        inr
                        (pathsdirprod (idpath _) (idpath _))))))
      @ monoidal_assoc
          _
          (monoidal_map_carrier_PA x)
          (monoidal_map_carrier_PA y)
          (monoidal_map_carrier_PA z)
      =
      monoidal_map_mult_PA x (monoidal_mult _ y z)
      @ maponpaths
          (λ q, monoidal_mult Y (monoidal_map_carrier_PA x) q)
          (monoidal_map_mult_PA y z)
      @ monoidal_assoc
          _
          (monoidal_map_carrier_PA x)
          (monoidal_map_carrier_PA y)
          (monoidal_map_carrier_PA z).
  Proof.
    apply maponpaths.
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          refine (!_).
          apply ap_pair_r.
        }
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply maponpaths.
          apply maponpaths.
          refine (!_).
          apply ap_pair_l.
        }
        simpl.
        apply pathscomp0rid.
      }
      simpl.
      exact (maponpathscomp (λ q, pr1 f x ,, q) inr _).
    }
    exact (maponpathscomp (λ q, inr (pr1 f x ,, q)) (pr211 Y) _).
  Qed.
End MonoidalPreAlgMorphismProjections.

Section MonoidalMorphismProjections.
  Context {X Y : hit_algebra_one_types monoidal_signature}
          (f : X --> Y).

  Definition monoidal_map_carrier
    : monoidal_carrier X → monoidal_carrier Y
    := monoidal_map_carrier_PA (pr11 f).

  Definition monoidal_map_unit
    : monoidal_map_carrier (monoidal_unit X)
      =
      monoidal_unit Y
    := monoidal_map_unit_PA (pr11 f).

  Definition monoidal_map_mult
             (x y : monoidal_carrier X)
    : monoidal_map_carrier (monoidal_mult _ x y)
      =
      monoidal_mult
        _
        (monoidal_map_carrier x)
        (monoidal_map_carrier y)
    := monoidal_map_mult_PA (pr11 f) x y.

  Definition monoidal_map_lunit
             (x : monoidal_carrier X)
    : maponpaths
        monoidal_map_carrier
        (monoidal_lunit _ x)
      =
      monoidal_map_mult (monoidal_unit _) x
      @ maponpaths
          (λ z, monoidal_mult Y z _)
          monoidal_map_unit
      @ monoidal_lunit _ (monoidal_map_carrier x).
  Proof.
    refine (_ @ eqtohomot (pr21 f lunit) x @ _).
    - exact (!(pathscomp0rid _)).
    - exact (monoidal_map_lunit_r _ x).
  Qed.

  Definition monoidal_map_runit
             (x : monoidal_carrier X)
    : maponpaths
        monoidal_map_carrier
        (monoidal_runit _ x)
      =
      monoidal_map_mult x (monoidal_unit _)
      @ maponpaths
          (λ z, monoidal_mult Y _ z)
          monoidal_map_unit
      @ monoidal_runit _ (monoidal_map_carrier x).
  Proof.
    refine (_ @ eqtohomot (pr21 f runit) x @ _).
    - exact (!(pathscomp0rid _)).
    - exact (monoidal_map_runit_r _ x).
  Qed.

  Definition monoidal_map_assoc
             (x y z : monoidal_carrier X)
    : maponpaths
          monoidal_map_carrier
          (monoidal_assoc _ x y z)
      @ monoidal_map_mult (monoidal_mult _ x y) z
      @ maponpaths
          (λ q, monoidal_mult Y q _)
          (monoidal_map_mult x y)
      =
      monoidal_map_mult x (monoidal_mult _ y z)
      @ maponpaths
          (λ q, monoidal_mult Y _ q)
          (monoidal_map_mult y z)
      @ monoidal_assoc
          _
          (monoidal_map_carrier x)
          (monoidal_map_carrier y)
          (monoidal_map_carrier z).
  Proof.
    refine (_ @ eqtohomot (pr21 f massoc) ((x ,, y) ,, z) @ _).
    - exact (monoidal_map_assoc_l _ x y z).
    - exact (!(path_assoc _ _ _) @ monoidal_map_assoc_r (pr11 f) x y z).
  Qed.
End MonoidalMorphismProjections.

(** Projections of 2-cells of monoidal algebras *)
Section MonoidalCellProjections.
  Context {X Y : hit_algebra_one_types monoidal_signature}
          {f g : X --> Y}
          (α : f ==> g).

  Definition monoidal_cell_carrier
             (x : monoidal_carrier X)
    : monoidal_map_carrier f x = monoidal_map_carrier g x
    := pr111 α x.

  Definition monoidal_cell_unit
    : monoidal_cell_carrier (monoidal_unit X) @ monoidal_map_unit g
      =
      monoidal_map_unit f.
  Proof.
    exact (eqtohomot (pr211 α) (inl tt) @ pathscomp0rid _).
  Qed.

  Definition monoidal_cell_comp
             (x y : monoidal_carrier X)
    : monoidal_cell_carrier
        (monoidal_mult _ x y)
      @ monoidal_map_mult g x y
      =
      monoidal_map_mult f x y
      @ maponpaths
          (λ z, monoidal_mult Y z _)
          (monoidal_cell_carrier x)
      @ maponpaths
          (λ z, monoidal_mult Y _ z)
          (monoidal_cell_carrier y).
  Proof.
    refine (eqtohomot (pr211 α) (inr (x ,, y)) @ _).
    refine (maponpaths (λ p, _ @ p) _).
    refine (_ @ uncurry_ap
                  (monoidal_mult Y)
                  (monoidal_cell_carrier x)
                  (monoidal_cell_carrier y)).
    apply (maponpathscomp inr (pr211 Y)).
  Qed.
End MonoidalCellProjections.

(** The builder *)
Section MonoidalAlgebraBuilder.
  Variable (A : one_type)
           (e : A)
           (m : A → A → A)
           (unitl_m : ∏ (x : A), m e x = x)
           (unitr_m : ∏ (x : A), m x e = x)
           (assoc_m : ∏ (x y z : A), m x (m y z) = m (m x y) z)
           (triangle_m : ∏ (x y : A),
                          maponpaths (λ z, m x z) (unitl_m y)
                          =
                          (assoc_m _ _ _)
                            @ maponpaths (λ z, m z y) (unitr_m x))
           (pentagon_m : ∏ (w x y z : A),
                         assoc_m w x (m y z)
                         @ assoc_m (m w x) y z
                         =
                         maponpaths (λ q, m w q) (assoc_m x y z)
                         @ assoc_m w (m x y) z
                         @ maponpaths (λ q, m q z) (assoc_m w x y)).

  Local Definition build_monoidal_prealgebra
    : hit_prealgebra_one_types monoidal_signature.
  Proof.
    use make_hit_prealgebra.
    - apply A.
    - apply one_type_isofhlevel.
    - simpl ; intro x.
      induction x as [ | x].
      + exact e.
      + exact (m (pr1 x) (pr2 x)).
  Defined.

  Local Definition build_monoidal_path_algebra
    : hit_path_algebra_one_types monoidal_signature.
  Proof.
    use make_hit_path_algebra.
    - exact build_monoidal_prealgebra.
    - intros j x.
      induction j.
      + (* left unit *)
        exact (unitl_m x).
      + (* right unit *)
        exact (unitr_m x).
      + (* assoc *)
        exact (assoc_m (pr11 x) (pr21 x) (pr2 x)).
  Defined.

  Local Definition build_monoidal_path_is_algebra
    : is_hit_algebra_one_types monoidal_signature build_monoidal_path_algebra.
  Proof.
    intros j x p.
    induction j ; cbn in x.
    - refine (_ @ triangle_m (pr1 x) (pr2 x) @ _).
      + refine (!_).
        exact (monoidal_triangle_left build_monoidal_path_algebra (pr1 x) (pr2 x)).
      + refine (!_).
        exact (monoidal_triangle_right build_monoidal_path_algebra (pr1 x) (pr2 x)).
    - refine (_ @ pentagon_m (pr111 x) (pr211 x) (pr21 x) (pr2 x) @ _).
      + refine (!_).
        exact (monoidal_pentagon_left
                 build_monoidal_path_algebra
                 (pr111 x) (pr211 x) (pr21 x) (pr2 x)).
      + refine (!_).
        exact (monoidal_pentagon_right
                 build_monoidal_path_algebra
                 (pr111 x) (pr211 x) (pr21 x) (pr2 x)).
  Qed.

  Definition build_monoidal_algebra
    : hit_algebra_one_types monoidal_signature.
  Proof.
    use make_algebra.
    - exact build_monoidal_path_algebra.
    - exact build_monoidal_path_is_algebra.
  Defined.
End MonoidalAlgebraBuilder.

(** Builder for 1-cells in the bicategory of monoidal algebras in 1-types *)
Section MonoidalMapBuilder.
  Context {X Y : hit_algebra_one_types monoidal_signature}
          (f_comp : monoidal_carrier X → monoidal_carrier Y)
          (f_unit : f_comp (monoidal_unit X) = monoidal_unit Y)
          (f_mult : ∏ (x y : monoidal_carrier X),
                    f_comp (monoidal_mult _ x y)
                    =
                    monoidal_mult _ (f_comp x) (f_comp y))
          (f_lunit : ∏ (x : monoidal_carrier X),
                     maponpaths f_comp (monoidal_lunit _ x)
                     =
                     f_mult (monoidal_unit _) x
                     @ maponpaths (λ z, monoidal_mult Y z _) f_unit
                     @ monoidal_lunit _ (f_comp x))
          (f_runit : ∏ (x : monoidal_carrier X),
                     maponpaths f_comp (monoidal_runit _ x)
                     =
                     f_mult x (monoidal_unit _)
                     @ maponpaths (λ z, monoidal_mult Y _ z) f_unit
                     @ monoidal_runit _ (f_comp x))
          (f_assoc : ∏ (x y z : monoidal_carrier X),
                     maponpaths
                       f_comp
                       (monoidal_assoc _ x y z)
                     @ f_mult (monoidal_mult _ x y) z
                     @ maponpaths
                         (λ q, monoidal_mult Y q _)
                         (f_mult x y)
                     =
                     f_mult x (monoidal_mult _ y z)
                     @ maponpaths
                         (λ q, monoidal_mult Y _ q)
                         (f_mult y z)
                     @ monoidal_assoc
                         _
                         (f_comp x) (f_comp y) (f_comp z)).

  Definition make_monoidal_prealg_map
    : pr11 X --> pr11 Y.
  Proof.
    use make_hit_prealgebra_mor.
    - exact f_comp.
    - intro x ; induction x as [x | x].
      + induction x.
        exact f_unit.
      + exact (f_mult (pr1 x) (pr2 x)).
  Defined.

  Definition make_monoidal_map
    : X --> Y.
  Proof.
    use make_algebra_map.
    use make_hit_path_alg_map.
    - exact make_monoidal_prealg_map.
    - intros i x.
      induction i.
      + refine (pathscomp0rid _ @ f_lunit x @ _).
        exact (!(monoidal_map_lunit_r make_monoidal_prealg_map x)).
      + refine (pathscomp0rid _ @ f_runit x @ _).
        exact (!(monoidal_map_runit_r make_monoidal_prealg_map x)).
      + refine (_ @ f_assoc (pr11 x) (pr21 x) (pr2 x) @ _).
        * exact (!(monoidal_map_assoc_l make_monoidal_prealg_map _ _ _)).
        * exact (!(monoidal_map_assoc_r make_monoidal_prealg_map _ _ _)
                  @ path_assoc _ _ _).
  Qed.
End MonoidalMapBuilder.

(** Builder for 2-cells in the bicategory of monoidal algebras in 1-types *)
Section MonoidalCellBuilder.
  Context {X Y : hit_algebra_one_types monoidal_signature}
          {f g : X --> Y}
          (α_comp : ∏ (x : monoidal_carrier X),
                    monoidal_map_carrier f x
                    =
                    monoidal_map_carrier g x)
          (α_unit : α_comp (monoidal_unit X) @ monoidal_map_unit g
                    =
                    monoidal_map_unit f)
          (α_compose : ∏ (x y : monoidal_carrier X),
                       α_comp (monoidal_mult _ x y)
                       @ monoidal_map_mult g x y
                       =
                       monoidal_map_mult f x y
                       @ maponpaths
                           (λ z, monoidal_mult Y z _)
                           (α_comp x)
                       @ maponpaths
                           (λ z, monoidal_mult Y _ z)
                           (α_comp y)).

  Definition make_monoidal_cell_is_2cell
    : disp_2cells
        (α_comp : prebicat_cells one_types (pr111 f) (pr111 g))
        (pr211 f)
        (pr211 g).
  Proof.
    use funextsec.
    intro z.
    induction z as [a | a].
    - induction a.
      exact (α_unit @ !(pathscomp0rid _)).
    - refine (α_compose (pr1 a) (pr2 a) @ _).
      refine (maponpaths (λ p, _ @ p) _).
      refine (!_).
      refine (_ @ uncurry_ap
                    (monoidal_mult Y)
                    (α_comp (pr1 a))
                    (α_comp (pr2 a))).
      apply (maponpathscomp inr (pr211 Y)).
  Qed.

  Definition make_monoidal_cell
    : f ==> g
    := ((α_comp ,, make_monoidal_cell_is_2cell) ,, (λ _, tt)) ,, tt.
End MonoidalCellBuilder.

(** Lists form an algebra for this signature *)
Definition concatenate_assoc
           {A : UU}
           (x y z : list A)
  : concatenate
      x
      (concatenate y z)
    =
    concatenate
      (concatenate x y)
      z.
Proof.
  revert x.
  apply list_ind.
  - apply idpath.
  - exact (λ x xs IHxs, maponpaths (cons x) IHxs).
Defined.

Definition list_triangle
           {A : UU}
           (x y : list A)
  : idpath (concatenate x (concatenate nil y))
    =
    concatenate_assoc x nil y
    @ maponpaths (λ z : list A, concatenate z y) (concatenate_nil x).
Proof.
  revert x.
  apply list_ind.
  - apply idpath.
  - intros x xs IHxs ; simpl.
    refine (maponpaths (maponpaths (cons x)) IHxs @ _) ; simpl.
    refine (maponpathscomp0 (cons x) _ _ @ _).
    apply maponpaths.
    etrans.
    {
      apply (maponpathscomp (λ z, concatenate z y) (cons x)).
    }
    refine (!_).
    apply (maponpathscomp (cons x) (λ z, concatenate z y)).
Qed.

Definition list_pentagon
           {A : UU}
           (w x y z : list A)
  : concatenate_assoc w x (concatenate y z)
    @ concatenate_assoc (concatenate w x) y z
    =
    maponpaths (λ q, concatenate w q) (concatenate_assoc x y z)
    @ concatenate_assoc w (concatenate x y) z
    @ maponpaths (λ q, concatenate q z) (concatenate_assoc w x y).
Proof.
  revert w x.
  use list_ind ; simpl.
  - use list_ind.
    + apply idpath.
    + simpl ; intros x xs IHxs.
      refine (maponpaths (maponpaths (cons x)) (IHxs @ pathscomp0rid _) @ _).
      refine (_ @ !((pathscomp0rid _))).
      refine (_ @ !(maponpathscomp
                      (cons x)
                      (λ q, concatenate nil q)
                      (concatenate_assoc xs y z))).
      exact (maponpathscomp (concatenate nil) (cons x) _).
  - intros w ws IHws x.
    refine (!(maponpathscomp0
                (cons w)
                (concatenate_assoc ws x (concatenate y z))
                (concatenate_assoc (concatenate ws x) y z))
            @ _).
    refine (maponpaths (maponpaths (cons w)) (IHws x) @ _).
    refine (maponpathscomp0 (cons w) _ _ @ _).
    refine (maponpaths (λ q, q @ _) (maponpathscomp (concatenate ws) (cons w) _) @ _).
    apply maponpaths.
    refine (maponpathscomp0 (cons w) _ _ @ _).
    apply maponpaths.
    refine (maponpathscomp (λ q, concatenate q z) (cons w) _ @ _).
    exact (!(maponpathscomp
               (cons w)
               (λ q, concatenate q z)
               (concatenate_assoc ws x y))).
Qed.

Definition list_monoidal_algebra
           (A : one_type)
  : hit_algebra_one_types monoidal_signature.
Proof.
  use build_monoidal_algebra.
  - refine (make_one_type (list A) _).
    apply isofhlevellist.
    apply one_type_isofhlevel.
  - exact nil.
  - exact concatenate.
  - exact nil_concatenate.
  - exact concatenate_nil.
  - exact concatenate_assoc.
  - exact list_triangle.
  - exact list_pentagon.
Defined.

Definition incl_list_monoidal_algebra
           (A : one_type)
  : A → alg_carrier (list_monoidal_algebra A)
  := λ a, cons a nil.