Require Import HoTT.
Require Import HoTT.Categories Category.
From GCTT Require Import categories sigma_lemmas path_lemmas quotients monoidal_category.
(* From GCTT Require Export monoidal_1type. *)
(* Change this once monoidal_category is in _CoqProject *)

(*These notations are defined elsewhere, but I do not know how to import it.*)
Local Notation "x --> y" := (morphism _ x y) (at level 99, right associativity, y at level 200) : type_scope.
Notation "F '_0' x" := (Functor.Core.object_of F x) (at level 10, no associativity, only parsing) : object_scope.
Notation "F '_1' m" := (Functor.Core.morphism_of F m) (at level 10, no associativity) : morphism_scope.
Open Scope category_scope.
Open Scope morphism_scope.

Section Localize.
  (* Definition Relation (A : Type) := (A -> A -> Type)%type. *)

  (** TODO: Update comments *)
  (** if we have a monoidal action with left_cancellation, we can build a category with objects X and
       arrows  [{m : M & m ⊗ x = m ⊗ y}] *)
  Definition monact_relation {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (a : Monoidal_Action S X) (x y : X)
    : relation ({s : S & a (s, x) --> y}).
  intros [s g] [t h].
  exact {sigma : Isomorphic s t & h o (a _1 (pair_1 sigma 1)) = g  }.
  Defined.

  (* This is an equivalence relation, here is a proof of reflexivity *)
  Lemma refl_monact_relation {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (a : Monoidal_Action S X) {x y : X}
             (f : {s : S & a (s, x) --> y})
    : monact_relation a x y f f.
  Proof.
    srapply @exist.
    { apply isomorphic_refl. }
    simpl. rewrite identity_of. apply right_identity.
  Qed.

  Definition monoidal_action_morphism (S : Symmetric_Monoidal_Category) (X : PreCategory)
             (a : Monoidal_Action S X) :
    (X -> X -> Type)
    := fun x y => set_quotient (monact_relation a x y).

  (* Definition left_faithful {C D : PreCategory} (m : Functor (A*B) B) := *)
  (* forall (s t : A) (f g : s --> t) (b : B), *)
  (*   m _1 (pair_1 f (identity b)) = m _1 (pair_1 f (identity b)) *)
  (*   ap (fun x => m x b) p = ap (fun x => m x b) q -> p = q. *)

  Definition functor_isomorphic {C D : PreCategory} (F : Functor C D)
             {c1 c2 : C} (e : Isomorphic c1 c2)
    : Isomorphic (F c1) (F c2).
  Proof.
    srefine (@Build_Isomorphic D _ _ (F _1 e) _).
  Defined.

  Definition prod_isomorphic {C D : PreCategory} {c1 c2 : C} {d1 d2 : D}
             (f : Isomorphic c1 c2) (g : Isomorphic d1 d2)
    : Isomorphic (C := C * D) (c1, d1) (c2, d2).
  Proof.
    srefine (@Build_Isomorphic
               (C*D) (c1,d1) (c2,d2)
               (morphism_isomorphic (Isomorphic := f), morphism_isomorphic (Isomorphic := g)) _).
    srapply @Build_IsIsomorphism.
    - exact (f^-1, g^-1).
    - apply path_prod; apply left_inverse.
    - apply path_prod; apply right_inverse.
  Defined.

  Definition monoidal_action_cat_compose' {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (a : Monoidal_Action S X) {x y z : X}
    : {s : S & (a _0 (s, y))%object --> z} ->
      {s : S & (a _0 (s, x))%object --> y} -> {s : S & (a _0 (s, x))%object --> z}.
  Proof.
    intros [s1 f1] [s2 f2].
    exists (s1 +' s2).
    refine (f1 o (a _1 _ o mon_action_mult _ _ _ s1 s2 x)).
    exact (1, f2).
  Defined.

  Proposition welldef_monoidal_action_cat_compose
             {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (a : Monoidal_Action S X) (x y z : X)
             (f f' : {s : S & (a _0 (s, y))%object --> z})
             (g g' : {s : S & (a _0 (s, x))%object --> y})
             (H1 : monact_relation a y z f f')
             (H2 : monact_relation a x y g g')
    : monact_relation a x z (monoidal_action_cat_compose' a f g)
                      (monoidal_action_cat_compose' a f' g').
  Proof.
    unfold monact_relation.
    destruct H1 as [sigma1 p1].
    destruct H2 as [sigma2 p2].
    simpl.
    srapply @exist.
    - apply (functor_isomorphic (binary_op)).
      srefine (prod_isomorphic sigma1 sigma2).
    - simpl.
      destruct f as [s f]. destruct p1.
      destruct g as [t g]. destruct p2.
      repeat rewrite associativity.
      apply (ap (fun h => f'.2 o h)).
      rewrite natl_mon_action_mult.
      repeat rewrite <- associativity.
      apply (ap (fun h => h o mon_action_mult S X a s t x)).
      rewrite <- composition_of. rewrite <- composition_of.
      simpl.  rewrite left_identity. rewrite left_identity.
      rewrite right_identity. reflexivity.
  Qed.

  Definition monoidal_action_cat (S : Symmetric_Monoidal_Category) (X : PreCategory)
             (a : Monoidal_Action S X)
    : PreCategory.
  Proof.
    srefine (Build_PreCategory (monoidal_action_morphism S X a) _ _ _ _ _ _).
    (* identity *)
    - intro x. apply class_of. exists (moncat_id _). apply mon_action_id.
    (* composition *)
    - intros x y z. unfold monoidal_action_morphism.
      srefine (set_quotient_rec2' (monact_relation a y z) _ _ _); simpl.
      + intros f1 f2. apply class_of.
        apply (monoidal_action_cat_compose' _ f1 f2).
      + simpl. intros f f' g.  intro H.
        apply related_classes_eq.
        apply (welldef_monoidal_action_cat_compose _ _ _ _ _ _ _ _ H).
        apply refl_monact_relation.
      + simpl. intros f g g'. intro H.
        apply related_classes_eq.
        refine (welldef_monoidal_action_cat_compose _ _ _ _ _ _ _ _ _ H).
        apply refl_monact_relation.
    (* associativity *)
    - intros x1 x2 x3 x4.
      srapply @set_quotient_ind_prop.
      intros [s f].
      srapply @set_quotient_ind_prop.
      intros [t g].
      srapply @set_quotient_ind_prop.
      intros [u h].
      simpl.
      apply related_classes_eq.
      exists (iso_moncat_assoc S u t s).
      simpl.
      repeat rewrite associativity.
      apply (ap (fun v => h o v)).
      transitivity
        (a _1 (pair_1 1 g) o (mon_action_mult S X a u t x2 o (a _1 (pair_1 (1 +^ 1) f))) o
           mon_action_mult S X a (u +' t) s x1).
      { rewrite natl_mon_action_mult.
        repeat rewrite associativity.
        rewrite action_coh_pent.
        repeat rewrite <- associativity.
        apply (ap (fun v => v o _)).
        apply (ap (fun v => v o _)).
        rewrite <- composition_of.
        rewrite <- composition_of.
        simpl.  rewrite left_identity. rewrite left_identity. reflexivity. }
      rewrite identity_of. simpl.
      repeat rewrite <- associativity. reflexivity.
    (* left identity *)
    - simpl.
      intros x1 x2.
      srapply @set_quotient_ind_prop.
      intros [s f]. simpl.
      apply related_classes_eq.
      exists (iso_moncat_lid S s).
      simpl. repeat rewrite <- associativity.
      rewrite natl_mon_action_id.
      rewrite <- action_coh_tri1.
      repeat rewrite associativity. reflexivity.
    (* right identity *)
    - simpl.
      intros x1 x2.
      srapply @set_quotient_ind_prop.
      intros [s f]. simpl.
      apply related_classes_eq.
      exists (iso_moncat_rid S s).
      simpl. repeat rewrite <- associativity.
      rewrite <- action_coh_tri2.
      repeat rewrite associativity.
      reflexivity.
  Defined.

  Definition cat_to_actcat {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (act : Monoidal_Action S X)
             (* (left_cancel : left_faithful act) *)
    : Functor X (monoidal_action_cat S X act).
  Proof.
    srapply @Build_Functor.
    - exact idmap.
    - intros x y. simpl.
      intro f. apply class_of.
      exists (moncat_id _).
      exact (f o (mon_action_id _ _ act x)).
    - intros x y z f g. simpl.
      apply inverse.
      apply related_classes_eq. unfold monact_relation. simpl.
      exists (iso_moncat_rid S (moncat_id S)).
      simpl.
      repeat rewrite associativity.
      apply (ap (fun v => g o v)).
      refine (_ @ (associativity _ _ _ _ _ _ _ _)).
      rewrite natl_mon_action_id.
      refine (_ @ (associativity _ _ _ _ _ _ _ _)^).
      refine (_ @ (associativity _ _ _ _ _ _ _ _)^).
      apply (ap (fun v => f o v)).
      refine (_ @ (associativity _ _ _ _ _ _ _ _)).
      rewrite <- (natl_mon_action_id _ _ act _ _ (mon_action_id S X act x)).
      rewrite <- action_coh_tri2. repeat rewrite associativity.
      reflexivity.
    - intro x. simpl. apply (ap (class_of _)).
      rewrite left_identity. reflexivity.
  Defined.

  Definition include_in_monoidal_action_cat {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (act : Monoidal_Action S X)
             (* (left_cancel : left_faithful act) *)
             (F : Functor S X)

    : Functor S (monoidal_action_cat S X act)
    := cat_to_actcat act o F.

  Definition triv_act_morphism {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (act : Monoidal_Action S X)
             (s : S) (x : X)
    : morphism (monoidal_action_cat S X act) x (act (s,x))
    := class_of (monact_relation act _ _) (s ; (Category.identity (act (s, x)))).

  Lemma decompose_actcat {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (act : Monoidal_Action S X)
             (x y : X)
             (s : S) (f : act (s, x) --> y)
    : class_of (monact_relation act x y ) (s; f) =
      (cat_to_actcat act) _1 f o triv_act_morphism act s x.
  Proof.
    simpl.  apply inverse. apply related_classes_eq.
    unfold monact_relation. simpl.
    exists (iso_moncat_lid S s).
    simpl.
    rewrite <- action_coh_tri1.
    rewrite identity_of.  rewrite left_identity.
    repeat rewrite associativity. reflexivity.
  Qed.

  Lemma natl_cat_to_actcat {S : Symmetric_Monoidal_Category} {X : PreCategory}
             (act : Monoidal_Action S X)
             (s : S) {x y : X} (f : x --> y)
    : (cat_to_actcat act) _1 (act _1 (pair_1 1 f)) o triv_act_morphism act s x
      = triv_act_morphism act s y o ((cat_to_actcat act) _1 f).
  Proof.
    rewrite <- decompose_actcat. simpl.
    apply inverse.
    apply related_classes_eq.
    unfold monact_relation. simpl.
    exists (iso_moncat_rid S s).
    simpl.
    rewrite <- action_coh_tri2. rewrite left_identity.
    repeat rewrite <- associativity.
    rewrite <- composition_of.
    simpl. rewrite left_identity. reflexivity.
  Qed.

End Localize.

Section Group_Completion.
  Definition diag_act_obj (S : Symmetric_Monoidal_Category) : S * (S * S) -> S * S.
  Proof.
    intros [s [x1 x2]].
    exact (s +' x1, s +' x2).
  Defined.

  Definition diag_act_fun (S : Symmetric_Monoidal_Category) : Functor (S * (S * S)) (S * S).
  Proof.
    srapply (Build_Functor (S * (S * S)) (S * S) (diag_act_obj S)).
    - intros [s [x1 x2]] [t [y1 y2]]. simpl.
      intros [f [g1 g2]].
      exact (f +^ g1, f +^ g2).
    - intros.
      simpl.  rewrite <- composition_of. rewrite <- composition_of. simpl. reflexivity.
    - intros.  simpl. rewrite <- identity_of. rewrite <- identity_of. reflexivity.
  Defined.

  (* Definition diag_act_mult (S : Symmetric_Monoidal_Category) (s t: S) (x : S * S) *)
  (*   : diag_act_fun S (s +' t, x) --> diag_act_fun S (s, (diag_act_fun S (t,x))). *)
  (* Proof. *)
  (*   simpl. refine (moncat_assoc S _ _ _ , moncat_assoc S _ _ _). *)
  (* Defined. *)

  Definition prod_isisomorphism (C D : PreCategory) {c c' : C} {d d' : D}
             (f : c --> c') (g : d --> d')
    : IsIsomorphism f -> IsIsomorphism g
      -> IsIsomorphism (C := C*D) (s := (_,_)) (d := (_,_)) (f,g).
  Proof.
    intros isiso_f isiso_g.
    srapply @Build_IsIsomorphism.
    - exact (f^-1, g^-1).
    - apply path_prod; apply left_inverse.
    - apply path_prod; apply right_inverse.
  Defined.

  Definition diag_act (S : Symmetric_Monoidal_Category) : Monoidal_Action S (S * S).
  Proof.
    srefine (Build_Monoidal_Action S (S * S) (diag_act_fun S)
                                 (fun _ _ _ => (moncat_assoc S _ _ _,moncat_assoc S _ _ _)) _ _
                                 (fun _ => (moncat_lid S _, moncat_lid S _)) _ _
                                 _ _ _
            ); intros; simpl.
    - apply prod_isisomorphism; apply isiso_moncat_assoc.
    - apply path_prod; apply natural_moncat_assoc.
    - apply prod_isisomorphism; apply isiso_moncat_lid.
    - apply path_prod; apply natural_moncat_lid.
    - apply path_prod; apply moncat_coh_tri1.
    - apply path_prod; apply moncat_coh_tri2.
    - apply path_prod; apply moncat_coh_pent.
  Defined.

  Definition group_completion_moncat (S : Symmetric_Monoidal_Category)
    := monoidal_action_cat _ _ (diag_act S).

  Definition include_in_gcl (S : Symmetric_Monoidal_Category)
    : Functor S (group_completion_moncat S).
  Proof.
    apply include_in_monoidal_action_cat.
    srapply @Build_Functor.
    - intro a. exact (a,a).
    - intros a b f.
      exact (f,f).
    - reflexivity.
    - reflexivity.
  Defined.

  Definition functor_group_completion_1' (S T : Symmetric_Monoidal_Category)
             (F : Monoidal_Functor S T)
             {x1 x2 y1 y2 : S}
             (f : {s : S & diag_act S (s, (x1, x2)) --> (y1, y2)})
    : {t : T & diag_act T (t, (F x1, F x2)) --> (F y1, F y2)}.
  Proof.
    destruct f as [s [f1 f2]]. simpl in f1, f2.
    exists (F s).
    simpl.
    srefine (((F _1 f1) o (mon_fun_sum _ _ F _ _)^-1) ,((F _1 f2) o (mon_fun_sum _ _ F _ _)^-1));
      apply isiso_mon_fun_sum.
  Defined.

  Lemma welldef_functor_group_completion_1 (S T : Symmetric_Monoidal_Category)
             (F : Monoidal_Functor S T)
             {x1 x2 y1 y2 : S}
             (f g : {s : S & diag_act S (s, (x1, x2)) --> (y1, y2)})
    : monact_relation (diag_act S) _ _ f g
      -> monact_relation (diag_act T) _ _ (functor_group_completion_1' _ _ F f)
                         (functor_group_completion_1' _ _ _ g).
  Proof.
    destruct f as [s f].
    destruct g as [t [g1 g2]]. simpl in *.
    intros [sigma p].
    exists (functor_isomorphic F (sigma)). simpl.
    simpl in p. destruct p. simpl.
    rewrite composition_of. rewrite composition_of.
    apply path_prod; simpl;
      apply  iso_moveL_pV; repeat rewrite associativity;
        rewrite <- (identity_of F);
        rewrite <- natl_mon_fun_sum; simpl;
          rewrite iso_compose_V_pp; reflexivity.
  Defined.

  Definition functor_group_completion (S T : Symmetric_Monoidal_Category)
             (F : Monoidal_Functor S T)
    : Functor (group_completion_moncat S) (group_completion_moncat T).
  Proof.
    srapply @Build_Functor.
    - intros [a b]. exact (F a, F b).
    - intros [x1 x2] [y1 y2].
      srapply @set_quotient_rec.
      { intro f. apply class_of.
        apply functor_group_completion_1'. exact f. }
      intros f g. simpl. intro H.
      apply related_classes_eq.
      apply welldef_functor_group_completion_1. exact H.
    - simpl. intros [x1 x2] [y1 y2] [z1 z2].
      srapply @set_quotient_ind_prop.
      intros [s f].
      srapply @set_quotient_ind_prop.
      intros [t g].
      simpl. apply related_classes_eq.
      exists (iso_mon_fun_sum F t s).
      simpl. destruct f as [f1 f2]. destruct g as [g1 g2]. simpl in *.
      rewrite composition_of. rewrite composition_of. rewrite composition_of. rewrite composition_of.
      repeat rewrite associativity.
      apply path_prod; simpl.
      + apply (ap (fun v => F _1 g1 o v)).
        apply iso_moveR_Vp.
        repeat rewrite <- associativity.
        rewrite natl_mon_fun_sum. apply iso_moveL_pV.
        rewrite associativity.
        rewrite associativity.
        rewrite <- (associativity _ _ _ _ _ (mon_fun_sum S T F (t +' s) x1)).
        rewrite mon_fun_assoc.
        repeat rewrite <- associativity.
        rewrite <- composition_of. simpl. rewrite left_identity.
        rewrite iso_compose_pV_p. rewrite identity_of.
        reflexivity.
      + apply (ap (fun v => F _1 g2 o v)).
        apply iso_moveR_Vp.
        repeat rewrite <- associativity.
        rewrite natl_mon_fun_sum. apply iso_moveL_pV.
        rewrite associativity.
        rewrite associativity.
        rewrite <- (associativity _ _ _ _ _ (mon_fun_sum S T F (t +' s) x2)).
        rewrite mon_fun_assoc.
        repeat rewrite <- associativity.
        rewrite <- composition_of. simpl. rewrite left_identity.
        rewrite iso_compose_pV_p. rewrite identity_of.
        reflexivity.
    - simpl. intros [x1 x2].
      apply related_classes_eq.
      exists (iso_mon_fun_id F).
      simpl. rewrite mon_fun_lid. rewrite mon_fun_lid. simpl.
      rewrite iso_compose_pp_V. rewrite iso_compose_pp_V.
      reflexivity.
  Defined.

  (* move *)
  (* Sum of iso is iso *)
  Definition sum_iso {M : Cat_Magma} {a b c d : M}
             (f : Isomorphic a b) (g : Isomorphic c d)
    : Isomorphic (a +' c) (b +' d).
  Proof.
    apply (functor_isomorphic (binary_op)).
    apply prod_isomorphic.
    - exact f. - exact g.
  Defined.

  Definition iso_moncat_sum_aa_aa (S : Symmetric_Monoidal_Category)
             (a b c d : S)
    : Isomorphic (a +' (b +' c) +' d) ((a +' b) +' (c +' d)) .
  Proof.
    refine (isomorphic_trans _ (iso_moncat_assoc S _ _ _)).
    refine (sum_iso _ (isomorphic_refl S d)).
    apply isomorphic_sym.
    apply iso_moncat_assoc.
  Defined.

  Definition iso_twist_middle (S : Symmetric_Monoidal_Category)
             (a b c d : S)
    : Isomorphic ((a +' b) +' (c +' d))  ((a +' c) +' (b +' d)).
  Proof.
    refine (isomorphic_trans _ (iso_moncat_sum_aa_aa S _ _ _ _ )).
    refine (isomorphic_trans (isomorphic_sym (iso_moncat_sum_aa_aa S _ _ _ _ )) _ ).
    refine (sum_iso _ (isomorphic_refl S d)).
    refine (sum_iso (isomorphic_refl S a) _).
    apply iso_moncat_sym.
  Defined.

  Definition twist_middle (S : Symmetric_Monoidal_Category)
             (a b c d : S)
    : ((a +' b) +' (c +' d)) --> ((a +' c) +' (b +' d))
    := iso_twist_middle S a b c d.

  Instance isiso_twist_middle (S : Symmetric_Monoidal_Category)
             (a b c d : S)
    : IsIsomorphism (twist_middle S a b c d) := _.
  Arguments twist_middle : simpl never.

  (* Definition coh_twist_middle (S : Symmetric_Monoidal_Category)(a b c d e : S) *)
  (*   : twist_middle S a b (d +' c) e = *)
  (*     (moncat_assoc S a d c +^ 1) o (iso_moncat_assoc S (a +' d) c (b +' e))^-1 o *)
  (*     (1 +^ moncat_assoc S c b e) o (1 +^ (moncat_sym S b c +^ 1)) o *)
  (*     (1 +^ (iso_moncat_assoc S b c e)^-1) o twist_middle S a b d (c +' e) o *)
  (*     (1 +^ moncat_assoc S d c e). *)
  (* Proof. *)
  (*   unfold twist_middle. unfold iso_twist_middle. simpl. *)
  (*   change (binary_op _1 (?f, ?g)) with (f +^ g). *)
  (*   change (binary_op _1 (?f, ?g)) with (f +^ g). *)
  (*   assert (p : moncat_sym S b (d +' c) = *)
  (*           (iso_moncat_assoc S d c b)^-1 o (1 +^ moncat_sym S b c) o *)
  (*             (moncat_assoc S d b c) o (moncat_sym S b d +^ 1) o *)
  (*             (iso_moncat_assoc S b d c)^-1). *)
  (*   { apply iso_moveL_pV. repeat rewrite associativity. *)
  (*     apply iso_moveL_Vp. repeat rewrite <- associativity. *)
  (*     apply moncat_coh_hex. } *)
  (*   rewrite p. clear p. repeat rewrite compose_sum_r. repeat rewrite compose_sum_l. *)
  (*   repeat rewrite <- sum_idmap. *)
  (*   repeat rewrite associativity. *)
  (*   assert (p : forall x y z w : S, *)
  (*              moncat_assoc S x y (z +' w) = *)
  (*              (1 +^ moncat_assoc S y z w) o (moncat_assoc S x (y +' z) w) o *)
  (*               (moncat_assoc S x y z +^ 1) o (iso_moncat_assoc S (x +' y) z w)^-1). *)
  (*   { intros. apply iso_moveL_pV. apply moncat_coh_pent. } *)
  (*   rewrite p. rewrite p. *)
  (*   repeat rewrite compose_sum_r. repeat rewrite compose_sum_l. *)
  (*   repeat rewrite associativity. *)

  (*   moncat_coh_pent *)
  (*   asser (moncat_sym S b c +^1 = *)
  (*          (iso_moncat_assoc S c b e)^-1 o (1 +^ moncat_sym S b c) *)

  (*   (1 +^ moncat_assoc S x y) = *)

  (*   refine ((associativity _ _ _ _ _ _ _ _)^ @ _). *)
  (*   refine ((associativity _ _ _ _ _ _ _ _)^ @ _). *)

  (*          ) *)

  (*             (moncat_coh_hex S b d c) *)

  (* Definition coh_twist_middle (S : Symmetric_Monoidal_Category)(a b c d e : S) *)
  (*   : twist_middle S a (b +' c) d e = *)
  (*     1 +^ (iso_moncat_assoc S b c e)^-1 o (iso_moncat_assoc S a d (b +' (c +' e)))^-1 o *)
  (*       (1 +^ moncat_assoc S d b (c +' e)) o (1 +^ (moncat_sym S b d +^ 1)) o *)
  (*       (1 +^ twist_middle S b c d e) o (moncat_assoc S a (b +' c) (d +' e)). *)
  (* Proof. *)

  (*   change (binary_op _1 (?f, ?g)) with (f +^ g). *)

  (*   moncat_coh_hex *)

  Lemma natural_moncat_assoc_inv (S : Symmetric_Monoidal_Category) {a b c a' b' c' : S}
               (f : a --> a') (g : b --> b') (h : c --> c')
      : (iso_moncat_assoc S a' b' c')^-1 o (f +^ (g +^ h)) =
        ((f +^ g) +^ h) o (iso_moncat_assoc S a b c)^-1.
  Proof.
    apply iso_moveL_pV.
    rewrite associativity.
    apply iso_moveR_Vp.
    apply inverse. apply natural_moncat_assoc.
  Qed.

  Definition natural_twist_middle (S : Symmetric_Monoidal_Category)
             {a b c d a' b' c' d': S}
             (f : a --> a') (g : b --> b') (h : c --> c') (i : d --> d')
    : (twist_middle S a' b' c' d') o ((f +^ g) +^ (h +^ i)) =
      ((f +^ h) +^ (g +^ i)) o (twist_middle S a b c d).
  Proof.
    simpl. repeat rewrite associativity.
    rewrite natural_moncat_assoc_inv. simpl.
    repeat rewrite <- associativity.
    apply (ap (fun v => v o _)).
    repeat rewrite associativity.
    repeat rewrite <- composition_of. simpl.
    repeat rewrite left_identity. simpl.
    repeat rewrite <- associativity.
    rewrite <- natural_moncat_assoc. simpl.
    repeat rewrite associativity.
    apply (ap (fun v => _ o v)). rewrite <- composition_of. simpl. rewrite right_identity.
    apply (ap (fun v => binary_op _1 v)).
    rewrite natural_moncat_assoc.
    apply (ap (fun v => (v, i))).
    repeat rewrite <- associativity.
    apply (ap (fun v => v o _)).
    rewrite <- natural_moncat_assoc_inv. simpl.
    repeat rewrite associativity. apply (ap (fun v => _ o v)).
    rewrite <- composition_of. simpl. rewrite left_identity.
    rewrite natural_moncat_sym. simpl.
    rewrite <- composition_of. simpl. rewrite right_identity.
    reflexivity.
  Qed.

  Definition sum_group_completion_1' (S : Symmetric_Monoidal_Category)
             {x1 x2 y1 y2 z1 z2 w1 w2 : S}
    :   {s : S & ((diag_act S) _0 (s, (x1, x2)))%object --> (z1, z2)} ->
        {s : S & ((diag_act S) _0 (s, (y1, y2)))%object --> (w1, w2)} ->
        {s : S & ((s +' (x1 +' y1) --> z1 +' w1) * (s +' (x2 +' y2) --> z2 +' w2))%type}.
  Proof.
    intros [s [f1 f2]] [t [g1 g2]]. simpl in *.
    exists (s +' t).            (* perhaps other way? *)
    refine (_ , _).
    - refine (f1 +^ g1 o _).
      apply twist_middle.
    - refine (f2 +^ g2 o _).
      apply twist_middle.
  Defined.

  Lemma welldef_sum_group_completion_1 (S : Symmetric_Monoidal_Category)
             {x1 x2 y1 y2 z1 z2 w1 w2 : S}
             (f f' : {s : S & ((diag_act S) _0 (s, (x1, x2)))%object --> (z1, z2)})
             (g g' : {s : S & ((diag_act S) _0 (s, (y1, y2)))%object --> (w1, w2)})
    : monact_relation (diag_act S) _ _ f f' ->
      monact_relation (diag_act S) _ _  g g' ->
      monact_relation (diag_act S) (_,_) (_,_)
                      (sum_group_completion_1' S f g)
                      (sum_group_completion_1' S f' g').
  Proof.
    intros [sigma p]. intros [tau q].
    destruct f as [s f]. destruct p.
    destruct g as [t g]. destruct q. simpl in *.
    exists (sum_iso sigma tau).
    destruct f' as [s' [f1 f2]]. destruct g' as [g' [g1 g2]].
    cbn. apply path_prod; simpl.
    - rewrite <- sum_idmap. rewrite associativity.
      rewrite natural_twist_middle. rewrite <- associativity.
      apply (ap (fun v => v o _)).
      refine ((composition_of _ _ _ _ _ _)^ ).
    - rewrite <- sum_idmap. rewrite associativity.
      rewrite natural_twist_middle. rewrite <- associativity.
      apply (ap (fun v => v o _)).
      refine ((composition_of _ _ _ _ _ _)^ ).
  Qed.

  (* (* probably needs left cancellation *) *)
  (* Definition sum_group_completion (S : Symmetric_Monoidal_Category) *)
  (*   : Functor ((group_completion_moncat S) * (group_completion_moncat S)) *)
  (*             (group_completion_moncat S). *)
  (* Proof. *)
  (*   srapply @Build_Functor. *)
  (*   - simpl. intros [[x1  x2] [y1 y2]]. *)
  (*     exact (x1 +' y1, x2 +' y2). *)
  (*   - simpl. intros [[x1 x2] [y1 y2]] [[z1 z2] [w1 w2]]. simpl. *)
  (*     intros [f g]. *)
  (*     revert f g. *)
  (*     srapply @set_quotient_rec2'. *)
  (*     + intros f g. apply class_of. simpl. *)
  (*       apply (sum_group_completion_1' S f g). *)
      (* + simpl. intros f f' g H. *)
      (*   apply related_classes_eq. *)
      (*   apply (welldef_sum_group_completion_1 S f f' g g H). *)
      (*   apply refl_monact_relation. *)
      (* + simpl. intros f g g' H. *)
      (*   apply related_classes_eq. *)
      (*   srefine (welldef_sum_group_completion_1 S f f g g' _ H). *)
      (*   apply refl_monact_relation. *)
  (*   - simpl. intros [[a1 a2] [b1 b2]] [[c1 c2] [d1 d2]] [[e1 e2] [f1 f2]]. *)
  (*     simpl. intros [alpha betta] [gamma dela]. simpl. *)
  (*     revert alpha.  *)
  (*     apply set_quotient_ind_prop. *)
  (*     { intro alpha. exact _. } *)
  (*     intro alpha. revert betta. *)
  (*     apply set_quotient_ind_prop. *)
  (*     { intro betta. exact _. } *)
  (*     intro betta. revert gamma. *)
  (*     apply set_quotient_ind_prop. *)
  (*     { intro gamma. exact _. } *)
  (*     intro gamma. revert dela. *)
  (*     apply set_quotient_ind_prop. *)
  (*     { intro dela. exact _. } *)
  (*     intro dela. simpl. *)
  (*     apply related_classes_eq. *)
  (*     destruct alpha as [s alpha]. *)
  (*     destruct betta as [t betta]. *)
  (*     destruct gamma as [u gamma]. *)
  (*     destruct dela as [v dela]. *)
  (*     srapply @exist. *)
  (*     { simpl. apply (Build_Isomorphic (isiso_twist_middle S _ _ _ _ )). } *)
  (*     cbn. *)
  (*     destruct alpha as [alpha1 alpha2]. destruct betta as [betta1 betta2]. *)
  (*     destruct gamma as [gamma1 gamma2]. destruct dela as [delta1 delta2]. simpl in *. *)
  (*     rewrite compose_sum_r. rewrite compose_sum_r. *)
  (*     rewrite (composition_of binary_op (_,_) (_,_) (_,_) (_,_) (gamma1, delta1)) . *)
  (*     rewrite (composition_of binary_op (_,_) (_,_) (_,_) (_,_) (gamma2, delta2)) . *)
  (*     rewrite (composition_of binary_op (_,_) (_,_) (_,_) (_,_) (_, _)). *)
  (*     rewrite (composition_of binary_op (_,_) (_,_) (_,_) (_,_) (_, _)). *)
  (*     admit. *)
  (*   - admit. *)
  (* Abort. *)

End Group_Completion.

(* Definition functor_monoidal_action_cat (M N : Monoidal_1Type) (X Y : 1-Type) *)
(*              (act1 : monoidal_action M X) (left_cancel1 : left_faithful act1) *)
(*              (act2 : monoidal_action N Y) (left_cancel2 : left_faithful act2) *)
(*              (f : Monoidal_Map M N) *)
(*              (g : X -> Y) *)
(*              (act_mult : forall (a : M) (x : X), *)
(*                  g (act1 a x) = act2 (f a) (g x)) *)
(*              (act_mult_assoc : forall (a b : M) (x : X), *)
(*                  ap g (montype_act_mult act1 a b x) = *)
(*                  act_mult _ x @ ap011 act2 (montype_map_mult f a b) idpath *)
(*                           @ montype_act_mult act2 (f a) (f b) (g x) *)
(*                           @ (ap011 act2 idpath (act_mult b x))^ *)
(*                           @ (act_mult a _)^) *)
(*              (act_mult_lid : forall (x : X), *)
(*                  ap g (montype_act_id act1 x) = *)
(*                  act_mult montype_id x *)
(*                           @ ap011 act2 (montype_map_id f) idpath *)
(*                           @ montype_act_id act2 (g x)) *)
(*     : Functor (monoidal_action_cat M X act1 left_cancel1) *)
(*               (monoidal_action_cat N Y act2 left_cancel2). *)
(*   Proof. *)
(*     srapply @Build_Functor. *)
(*     - exact g. *)
(*     - simpl. intros x y. *)
(*       intros [s p]. *)
(*       exists (f s). *)
(*       refine (_ @ ap g p). *)
(*       apply inverse. apply act_mult. *)
(*     - intros x y z. *)
(*       intros [s p] [t q]. simpl. *)
(*       destruct q. destruct p. simpl. *)
(*       repeat rewrite concat_p1. *)
(*       apply (path_sigma _ (_;_) (_;_) (montype_map_mult f t s)). *)
(*       simpl. *)
(*       refine (transport_paths_Fl (montype_map_mult f t s) _ @ _). *)
(*       rewrite act_mult_assoc. *)
(*       repeat rewrite concat_p_pp. apply whiskerR. *)
(*       rewrite ap_V. apply whiskerR. *)
(*       apply moveR_pM. rewrite concat_pV. *)
(*       apply moveR_pM. rewrite concat_1p. *)
(*       apply moveR_pM. apply whiskerR. destruct (montype_map_mult f t s). *)
(*       reflexivity. *)
(*     - simpl. intro x. *)
(*       apply (path_sigma _ (_;_) (_;_) (montype_map_id f)). *)
(*       refine (transport_paths_Fl (montype_map_id f) _ @ _). *)
(*       rewrite act_mult_lid. simpl. *)
(*       repeat rewrite concat_pp_p. apply moveR_Vp. apply moveR_Vp. *)
(*       apply whiskerL. apply whiskerR. *)
(*       generalize (montype_map_id f). intro p. destruct p. *)
(*       reflexivity. *)
(*   Defined. *)

(*   Definition left_cancel_localize (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*     : left_faithful (act_on_prod M M X (act_on_self M) act). *)
(*   Proof. *)
(*     unfold left_faithful. *)
(*     intros s t p q [a x]. *)
(*     intro H. apply (left_cancel s t p q a).  *)
(*     refine ((ap_fst_path_prod (z := (s ⊗ a, act s x )) (z' := (t ⊗ a, act t x )) *)
(*                 (ap (fun m : M => m ⊗ a) p) (ap (fun m : M => act m x) p))^ @ _ @ *)
(*              ap_fst_path_prod (z := (s ⊗ a, act s x )) (z' := (t ⊗ a, act t x )) *)
(*                 (ap (fun m : M => m ⊗ a) q) (ap (fun m : M => act m x) q)).  *)
(*     apply (ap (ap fst)). *)
(*     refine (_ @ H @ _). *)
(*     - destruct p. reflexivity. *)
(*     - destruct q. reflexivity. *)
(*   Defined. *)

(*   Definition localize_action (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*     : PreCategory. *)
(*   Proof. *)
(*     apply (monoidal_action_cat M (BuildTruncType 1 (M*X)) (act_on_prod M M X (act_on_self M) act)). *)
(*     apply left_cancel_localize. apply left_cancel. *)
(*   Defined. *)

(*   Definition include_in_localize_action (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*              (x0 : X) *)
(*     : Functor (groupoid_category M) (localize_action M X act left_cancel). *)
(*   Proof. *)
(*     apply include_in_monoidal_action_cat. *)
(*     intro a. exact (a,x0). *)
(*   Defined. *)

(*   (** The group completion of a monoidal category. *) *)
(*   Definition group_completion_moncat (M : Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*     : PreCategory := *)
(*     localize_action M M (act_on_self M) left_cancel. *)

(*   Definition contr_self_category (M : Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*              (* (left_cancel : forall (s t : M) (p q : s = t) (a : M), *) *)
(*              (*     ap (fun x => x ⊗ a) p = ap (fun x => x ⊗ a) q -> p = q) *) *)
(*     : forall x : object (monoidal_action_cat M M (act_on_self M) left_cancel), *)
(*       Contr (morphism (monoidal_action_cat M M (act_on_self M) left_cancel) montype_id x). *)
(*   Proof. *)
(*     simpl. intro a. unfold monoidal_action_morphism. unfold act_on_self. simpl. *)
(*     apply (contr_equiv' {s : M & s = a}). *)
(*     - srapply @equiv_functor_sigma'. *)
(*       { exact equiv_idmap. } *)
(*       intro m. simpl. *)
(*       apply equiv_concat_l. apply montype_moncat_rid. *)
(*     - apply contr_basedpaths'. *)
(*   Defined. *)

(*   (** Given a : M, get an endofunctor +a on the group completion  *) *)
(*   Definition act_on_grp_compl (M : Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*     : M -> Functor (group_completion_moncat M left_cancel) (group_completion_moncat M left_cancel). *)
(*   Proof. *)
(*     intro a. *)
(*     srapply @Build_Functor. *)
(*     - intros [x1 x2]. exact (montype_mult x1 a, x2). *)
(*     - intros [x1 x2] y. *)
(*       intros [s p]. *)
(*       exists s. *)
(*       apply (path_prod); simpl. *)
(*       + refine (_ @ ap (fun m => montype_mult m a) (ap fst p)). *)
(*         apply inverse. apply montype_assoc. *)
(*       + apply (ap snd p). *)
(*     - intros [x1 x2] y z. *)
(*       intros [s p]. intros [t q]. destruct q. destruct p. *)
(*       simpl. repeat rewrite concat_p1. *)
(*       srapply @path_sigma. *)
(*       { reflexivity. } *)
(*       simpl. *)
(*       rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. *)
(*       rewrite ap_functor_prod. *)
(*       rewrite <- path_prod_pp. rewrite <- path_prod_pp. *)
(*       rewrite concat_p1. simpl. rewrite concat_p1. *)
(*       apply (ap (fun p => path_prod _ _ p _)). *)
(*       rewrite montype_pentagon. *)
(*       repeat rewrite concat_p_pp. *)
(*       apply whiskerR. rewrite ap_V. apply whiskerR. rewrite concat_Vp. *)
(*       apply concat_1p. *)
(*     - intros [x1 x2]. simpl. *)
(*       srapply @path_sigma. *)
(*       { reflexivity. } simpl. *)
(*       rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. *)
(*       apply (ap (fun p => path_prod _ _ p _)). *)
(*       rewrite montype_triangle1. *)
(*       destruct (montype_lid (x1 ⊗ a)). rewrite concat_p1. *)
(*       apply concat_Vp. *)
(*   Defined. *)

(*   (** The action preserves the monoid multiplication.  *) *)
(*   Definition act_on_grp_compl_mult (M : Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*              (a b : M) (x : M * M) *)
(*     : act_on_grp_compl M left_cancel (montype_mult a b) x = *)
(*       ((act_on_grp_compl M left_cancel b) ((act_on_grp_compl M left_cancel a) x)). *)
(*   Proof. *)
(*     destruct x as [x1 x2]. simpl. *)
(*     apply path_prod; simpl. *)
(*     + apply inverse. apply montype_assoc. *)
(*     + reflexivity. *)
(*   Defined. *)

(*   (** The following results implies that the action is an equivalence after taking the 1-type completion.  *) *)
(*   Definition act_on_grp_compl_inv (M : Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult M)) *)
(*     : M -> Functor (group_completion_moncat M left_cancel) (group_completion_moncat M left_cancel). *)
(*   Proof. *)
(*     intro a. *)
(*     srapply @Build_Functor. *)
(*     - intros [x1 x2]. exact (x1, montype_mult x2 a). *)
(*     - intros [x1 x2] y. *)
(*       intros [s p]. *)
(*       exists s. *)
(*       apply (path_prod); simpl. *)
(*       + apply (ap fst p). *)
(*       + refine (_ @ ap (fun m => montype_mult m a) (ap snd p)). *)
(*         apply inverse. apply montype_assoc. *)
(*     - intros [x1 x2] y z. *)
(*       intros [s p]. intros [t q]. destruct q. destruct p. *)
(*       simpl. repeat rewrite concat_p1. *)
(*       srapply @path_sigma. *)
(*       { reflexivity. } *)
(*       simpl. *)
(*       rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. *)
(*       rewrite ap_functor_prod. *)
(*       rewrite <- path_prod_pp. rewrite <- path_prod_pp. *)
(*       rewrite concat_p1. simpl. rewrite concat_p1. *)
(*       apply (ap (fun p => path_prod _ _ _ p)). *)
(*       rewrite montype_pentagon. *)
(*       repeat rewrite concat_p_pp. *)
(*       apply whiskerR. rewrite ap_V. apply whiskerR. rewrite concat_Vp. *)
(*       apply concat_1p. *)
(*     - intros [x1 x2]. simpl. *)
(*       srapply @path_sigma. *)
(*       { reflexivity. } simpl. *)
(*       rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. *)
(*       apply (ap (fun p => path_prod _ _ _ p)). *)
(*       rewrite montype_triangle1. *)
(*       destruct (montype_lid (x2 ⊗ a)). rewrite concat_p1. *)
(*       apply concat_Vp. *)
(*   Defined. *)

(*   Definition act_on_grp_compl_is_sect (M : Symmetric_Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult M)) (a : M): *)
(*     NaturalTransformation *)
(*       1%functor *)
(*       ((act_on_grp_compl_inv M left_cancel a) o (act_on_grp_compl M left_cancel a))%functor. *)
(*   Proof. *)
(*     srapply @Build_NaturalTransformation. *)
(*     - intros [x1 x2]. simpl. *)
(*       exists a. *)
(*       apply path_prod; *)
(*         apply smontype_sym. *)
(*     - intros [x1 x2] y. intros [s p]. *)
(*       simpl. destruct p. simpl. *)
(*       rewrite concat_p1. rewrite concat_p1. *)
(*       srapply @path_sigma. *)
(*       { apply smontype_sym. } *)
(*       refine (transport_paths_Fl (smontype_sym a s) _ @ _). simpl. *)
(*       rewrite ap_functor_prod. *)
(*       rewrite <- path_prod_pp. *)
(*       rewrite <- path_prod_pp. *)
(*       rewrite <- path_prod_pp. *)
(*       rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. simpl. rewrite concat_p1. *)
(*       apply moveR_pM. *)
(*       rewrite <- path_prod_VV. *)
(*       rewrite <- path_prod_pp. unfold functor_prod. simpl. *)
(*       transitivity (path_prod (_,_) (_,_) *)
(*                               (ap (fun x : M => smontype_mult x x1) (smontype_sym a s)) *)
(*                               (ap (fun x : M => smontype_mult x x2) (smontype_sym a s)))^. *)
(*       { destruct (smontype_sym a s). reflexivity. } *)
(*       apply (equiv_inj inverse). rewrite inv_V. *)
(*       rewrite <- path_prod_VV. *)
(*       rewrite inv_pV. rewrite inv_pV. *)
(*       rewrite inv_pV. rewrite inv_pV. *)
(*       rewrite smontype_hexagon. rewrite smontype_hexagon. *)
(*       rewrite inv_pp. rewrite inv_pp. *)
(*       repeat rewrite concat_p_pp. *)
(*       reflexivity. *)
(*   Defined. *)

(*   Definition act_on_grp_compl_is_retr (M : Symmetric_Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult M)) (a : M): *)
(*     NaturalTransformation *)
(*       1%functor *)
(*       ((act_on_grp_compl M left_cancel a) o (act_on_grp_compl_inv M left_cancel a))%functor. *)
(*   Proof. *)
(*     srapply @Build_NaturalTransformation. *)
(*     - intros [x1 x2]. simpl. *)
(*       exists a. *)
(*       apply path_prod; *)
(*         apply smontype_sym. *)
(*     - intros [x1 x2] y. intros [s p]. *)
(*       simpl. destruct p. simpl. *)
(*       rewrite concat_p1. rewrite concat_p1. *)
(*       srapply @path_sigma. *)
(*       { apply smontype_sym. } *)
(*       refine (transport_paths_Fl (smontype_sym a s) _ @ _). simpl. *)
(*       rewrite ap_functor_prod. *)
(*       rewrite <- path_prod_pp. *)
(*       rewrite <- path_prod_pp. *)
(*       rewrite <- path_prod_pp. *)
(*       rewrite ap_fst_path_prod. rewrite ap_snd_path_prod. simpl. rewrite concat_p1. *)
(*       apply moveR_pM. *)
(*       rewrite <- path_prod_VV. *)
(*       rewrite <- path_prod_pp. unfold functor_prod. simpl. *)
(*       transitivity (path_prod (_,_) (_,_) *)
(*                               (ap (fun x : M => smontype_mult x x1) (smontype_sym a s)) *)
(*                               (ap (fun x : M => smontype_mult x x2) (smontype_sym a s)))^. *)
(*       { destruct (smontype_sym a s). reflexivity. } *)
(*       apply (equiv_inj inverse). rewrite inv_V. *)
(*       rewrite <- path_prod_VV. *)
(*       rewrite inv_pV. rewrite inv_pV. *)
(*       rewrite inv_pV. rewrite inv_pV. *)
(*       rewrite smontype_hexagon. rewrite smontype_hexagon. *)
(*       rewrite inv_pp. rewrite inv_pp. *)
(*       repeat rewrite concat_p_pp. *)
(*       reflexivity. *)
(*   Defined. *)

(*   Definition to_groupcompletion (S : Monoidal_1Type) *)
(*              (left_cancel : left_faithful (@montype_mult S)) *)
(*              : Functor (groupoid_category S) (group_completion_moncat S left_cancel). *)
(*   Proof. *)
(*     apply include_in_monoidal_action_cat. *)
(*     simpl. intro a. exact (a, montype_id). *)
(*   Defined. *)

(* End Localize. *)

(* Section Univalent_GroupGompletion. *)
(*   (** We show when the group completion is a univalent category.  *) *)
(*   Context (M : Monoidal_1Type) (X : 1-Type) (act : monoidal_action M X) *)
(*           (left_cancel_act : left_faithful act). *)

(*   Lemma idtoiso_is_concat (x y : monoidal_action_cat M X act left_cancel_act) : *)
(*     forall (p : x = y), *)
(*       (@idtoiso _ x y p) = *)
(*       (montype_id; montype_act_id _ x @ p) :> morphism _ x y. *)
(*   Proof. *)
(*     intros []. simpl. *)
(*     srapply @path_sigma. { reflexivity. } *)
(*     simpl. apply (concat_p1 _)^. *)
(*   Defined. *)

(*   Definition equiv_path_isomorphic {C : PreCategory} (x y : C) (f g : (x <~=~> y)%category) : *)
(*     (f = g :> morphism C x y) <~> f = g *)
(*     := BuildEquiv _ _ (path_isomorphic f g) _. *)

(*   Lemma fiber_idtoiso (x y : monoidal_action_cat M X act left_cancel_act) (f : (x <~=~> y) %category) : *)
(*     hfiber (@idtoiso _ x y) f <~> *)
(*            ((morphism_isomorphic (Isomorphic := f)).1 = montype_id). *)
(*   Proof. *)
(*     unfold hfiber. *)
(*     transitivity {p : x = y & (montype_id; montype_act_id _ x @ p) = f :> morphism _ x y}. *)
(*     - apply equiv_functor_sigma_id. *)
(*       intro p. *)
(*       refine (_ oE (equiv_path_isomorphic *)
(*                       x y *)
(*                       _ *)
(*                       f)^-1).       *)
(*       apply equiv_concat_l. *)
(*       apply inverse. apply idtoiso_is_concat. *)
(*     - destruct f as [[s q] isiso]. simpl. *)
(*       transitivity {p : x = y & *)
(*                         {r : montype_id = s & *)
(*                              (montype_act_id act x)^ @ ap (fun a : M => act a x) r @ q = p}}. *)
(*       { apply equiv_functor_sigma_id. intro p. *)
(*         refine (_ oE (equiv_path_sigma _ _ _ )). simpl. *)
(*         apply equiv_functor_sigma_id. intro r. *)
(*         destruct r. simpl. destruct p.  *)
(*         refine (_ oE equiv_moveL_Vp _ _ _). *)
(*         refine (equiv_path_inverse _ _ oE _). *)
(*         apply equiv_concat_r. apply whiskerR. apply inverse. apply concat_p1. } *)
(*       transitivity {r : montype_id = s & *)
(*                         {p : x = y & *)
(*                              ((montype_act_id act x)^ @ ap (fun a : M => act a x) r) @ q = p}}. *)
(*       { srapply @equiv_adjointify. *)
(*         - intros [p [r h]]. exact (r; (p; h)). *)
(*         - intros [r [p h]]. exact (p; (r; h)). *)
(*         - intros [r [p h]]. reflexivity. *)
(*         - intros [p [r h]]. reflexivity. } *)
(*       refine (equiv_path_inverse _ _ oE _). *)
(*       apply equiv_sigma_contr. intro r. *)
(*       apply contr_basedpaths. *)
(*   Defined. *)

(*   Context (unit_is_id : forall s t: M, montype_mult s t = montype_id -> s = montype_id) *)
(*           (contr_component_id : forall (a : M), IsHProp (montype_id = a)). *)

(*   Definition univalent_monactcat (x y : monoidal_action_cat M X act left_cancel_act) : *)
(*     IsEquiv (@Category.idtoiso _ x y). *)
(*   Proof. *)
(*     apply isequiv_fcontr. intro f. *)
(*     srefine (contr_equiv' _ (equiv_inverse (fiber_idtoiso x y f))). *)
(*     destruct f as [[s p] isiso]. simpl. *)
(*     apply (contr_equiv' (montype_id = s)). *)
(*     { apply equiv_path_inverse. } *)
(*     apply contr_inhabited_hprop. *)
(*     { apply contr_component_id. } *)
(*     apply inverse. *)
(*     destruct isiso as [[t q] ]. simpl in *. *)
(*     apply (unit_is_id s t). *)
(*     apply ((equiv_path_sigma _ _ _) right_inverse). *)
(*   Defined. *)
(* End Univalent_GroupGompletion. *)


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Bool.Bool.
From Coq Require Import Reals.Reals. Import Rdefinitions. Import RIneq.
From Coq Require Import ZArith.Zdiv.
From Coq Require Import ZArith.Int.
From Coq Require Import ZArith.Znat.
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import micromega.Lia.
From Coq Require Import micromega.Zify.

Require Import Ltac2.Ltac2.
Require Import Ltac2.Option.

From ATL Require Import ATL Tactics Common CommonTactics Div IdentParsing
     GenPushout Reshape LetLifting.

Open Scope string_scope.

Set Default Proof Mode "Classic".

Theorem trunc_r_gen {X} `{TensorElem X} : forall f n s k,
    (0 < n)%Z ->
    0 < k ->
    (Z.of_nat k < n)%Z ->
    (forall x, consistent (f x) s) ->
    trunc_r k (GEN [ i < n ] f i) = GEN [ i < Z.of_nat k ] f i.
Proof.
  unfold trunc_r.
  intros. rw @get_gen_some. reflexivity.
Qed.

Theorem trunc_r_sum {X} `{TensorElem X} : forall f n s k,
    (0 < n)%Z ->
    0 < k ->
    (Z.of_nat k < n)%Z ->
    (forall x, consistent (f x) s) ->
    trunc_r k (SUM [ i < n ] f i) = SUM [ i < n ] (trunc_r k (f i)).
Proof.
  unfold trunc_r.
  intros.
  rw<- @get_sum.
  rw @sum_gen_swap.
  reflexivity.
Qed.

Theorem trunc_r_guard {X} `{TensorElem X} : forall p e k,
    trunc_r k (|[ p ]| e) = |[ p ]| (trunc_r k e).
Proof.
  unfold trunc_r.
  intros.
  rw @gp_iverson.
  rw<- @gp_gen_iverson.
  reflexivity.
Qed.

Theorem normalize_gen {X} `{TensorElem X} : forall (l : list X) n s,
    consistent l (n,s) ->
    l = GEN [ i < Z.of_nat n ] l _[i].
Proof.
  intros.
  rewrite gen_get_id. auto.
  inversion H0.
  rewrite Nat2Z.id. auto.
Qed.

Theorem normalize_bin {X} `{TensorElem X} : forall (x y : list X) n s,
    consistent x (n,s) ->
    consistent y (n,s) ->
    tensor_add x y = GEN [ i < Z.of_nat n ] (x _[i]) <+> (y _[i]).
Proof.
  intros.
  unfold tensor_add.
  inversion H0. inversion H1. subst.
  rewrite H13. rewrite max_id.
  reflexivity.
Qed.

Theorem let_extensionality {X Y} `{TensorElem X} `{TensorElem Y} :
  forall (x : X) (f g : X -> Y) s,
    consistent x s ->
    (forall x, consistent x s -> f x = g x) ->
    let_binding x f = let_binding x g.
Proof.
  intros.
  unfold let_binding.
  apply H2. auto.
Qed.

Ltac normalize_rec :=
  repeat (unfold bin;
          lazymatch goal with
          | |- transpose _ = _ =>
            apply transpose_eq
          | |- (let_binding ?x ?f) = _ =>
            match type of x with
            | Z =>
              eapply tlet_eq_body; intros
            | ?tx =>
            let ex := fresh "ex" in
            let H := fresh "H" in
            evar (ex : tx);
            assert (x = ?ex) as H by
                  (normalize_rec);
            try rewrite H;
            eapply let_extensionality;
            [ consistent_shape; try reflexivity; eauto | intros ]
            end
          | |- GEN [ i < ?n ] @?f i = _ =>
            apply gen_eq_bound; intros
          | |- GEN [ _ <= _ < _ ] _ = _ =>
            apply genr_eq_bound; intros
          | |- SUM [ i < ?n ] @?f i = _ =>
            apply sum_eq_bound; intros
          | |- (|[ _ ]| _) = _ =>
            apply iverson_weak
          | |- tensor_add ?x ?y = _ =>
            lift_evar;
            erewrite normalize_bin by
                (consistent_shape; eauto with crunch);
            drop_evar
          | |- (?a + ?b)%R = _ =>
             let ae := fresh "ae" in
             let Ha := fresh "Ha" in
             evar (ae : R);
             assert (a = ?ae) as Ha by normalize_rec;
             lift_evar;
             try rewrite Ha;
             drop_evar;
             let be := fresh "be" in
             let Hb := fresh "Hb" in
             evar (be : R);
             assert (b = ?be) as Hb by normalize_rec;
             lift_evar;
             try rewrite Hb;
             drop_evar;
             reflexivity
          | |- ?a <++> ?b = _ =>
             let ae := fresh "ae" in
             let Ha := fresh "Ha" in
             let t := type of a in
             evar (ae : t);
             assert (a = ?ae) as Ha by normalize_rec;
             lift_evar;
             try rewrite Ha;
             drop_evar;
             let be := fresh "be" in
             let Hb := fresh "Hb" in
             evar (be : t);
             assert (b = ?be) as Hb by normalize_rec;
             lift_evar;
             try rewrite Hb;
             drop_evar;
             reflexivity
          | |- (?a * ?b)%R = _ =>
             let ae := fresh "ae" in
             let Ha := fresh "Ha" in
             evar (ae : R);
             assert (a = ?ae) as Ha by normalize_rec;
             lift_evar;
             try rewrite Ha;
             drop_evar;
             let be := fresh "be" in
             let Hb := fresh "Hb" in
             evar (be : R);
             assert (b = ?be) as Hb by normalize_rec;
             lift_evar;
             try rewrite Hb;
             drop_evar;
             reflexivity
          | |- trunc_r _ _ = _ =>
            apply trunc_r_eq
          | |- pad_l _ _ = _ =>
            apply pad_l_eq
          | |- flatten_trunc _ _ = _ =>
            apply flatten_trunc_eq
          | |- flatten _ = _ =>
            apply flatten_eq
          | |- transpose _ = _ =>
            apply transpose_eq
          | |- ?etc = _ =>
            lazymatch type of etc with
            | list _ =>
              lift_evar;
              erewrite (normalize_gen etc) by
                  (consistent_shape; eauto with crunch);
              drop_evar
            | _ => reflexivity
            end
          end).

Ltac normalize_types :=
  unfold bin; simpl;
  etransitivity; [ normalize_rec; auto with crunch | ]; simpl; lazy beta.

Ltac normalize_in_expr :=
  lazymatch goal with
  | |- ?v _[ _ ] = _ =>
    apply get_eq_index;
    normalize_in_expr
  | |- (?a * ?b)%R = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (normalize_in_expr; try reflexivity);
    lift_evar;
    try rewrite Ha;
    try clear Ha;
    try rewrite ll_mult_l;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (normalize_in_expr; try reflexivity);
    lift_evar;
    try rewrite Hb;
    try rewrite ll_mult_r;
    try clear Hb;
    drop_evar;
    reflexivity
  | |- (?a / ?b)%R = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (normalize_in_expr; try reflexivity);
    lift_evar;
    try rewrite Ha;
    try rewrite ll_div_l;
    try clear Ha;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (normalize_in_expr; try reflexivity);
    lift_evar;
    try rewrite Hb;
    try rewrite ll_div_r;
    try clear Hb;
    drop_evar;
    reflexivity
  | |- (?a + ?b)%R = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (normalize_in_expr; try reflexivity);
    lift_evar;
    try rewrite Ha;
    try rewrite ll_plus_l;
    try clear Ha;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (normalize_in_expr; try reflexivity);
    lift_evar;
    try rewrite Hb;
    try rewrite ll_plus_r;
    try clear Hb;
    drop_evar;
    reflexivity
  | |- ?v = _ =>
    match v with
    | _ => is_var v; reflexivity
    | _ => (* Not the recursive case and not a var *)
      replace v with (tlet x := v in x) by
          (unfold let_binding; reflexivity)
    end
  end.

Ltac normalize_get :=
  match goal with
  | |- flatten _ = _ =>
    apply flatten_eq;
    normalize_get
  | |- flatten_trunc _ _ = _ =>
    apply flatten_trunc_eq;
    normalize_get
  | |- transpose _ = _ =>
    apply transpose_eq;
    normalize_get
  | |- pad_r _ _ = _ =>
    apply pad_r_eq;
    normalize_get
  | |- pad_l _ _ = _ =>
    apply pad_l_eq;
    normalize_get
  | |- trunc_l _ _ = _ =>
    apply trunc_l_eq;
    normalize_get
  | |- trunc_r _ _ = _ =>
    apply trunc_r_eq;
    normalize_get
  | |- GEN [ _ < _ ] _ = _ =>
    apply gen_eq_bound; intros;
    normalize_get
  | |- GEN [ _ <= _ < _ ] _ = _ =>
    apply genr_eq_bound; intros;
    normalize_get
  | |- SUM [ _ < _ ] _ = _ =>
    apply sum_eq_bound; intros;
    normalize_get
  | |- (|[ _ ]| _) = _ =>
    apply iverson_weak;
    normalize_get
  | |- let_binding ?e ?f = _ =>
    let ee := fresh "ee" in
    let He := fresh "He" in
    let t := type of e in
    evar (ee : t);
    assert (e = ?ee) as He by (normalize_get; try reflexivity);
    lift_evar;
    try rewrite He;
    try clear He;
    drop_evar;
    eapply tlet_eq_body; intros;
    normalize_get
  | |- ?a <++> ?b = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (normalize_get; try reflexivity);
    lift_evar;
    try rewrite Ha;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (normalize_get; try reflexivity);
    lift_evar;
    try rewrite Hb;
    drop_evar;
    reflexivity
  | |- (?a + ?b)%R = _ =>
    normalize_in_expr
  | |- (?a / ?b)%R = _ =>
    normalize_in_expr
  | |- (?a * ?b)%R = _ =>
    normalize_in_expr
  | |- _ _[_] = _ =>
    normalize_in_expr
  | |- _ = _ => try reflexivity
  end.

Ltac let_lift :=
  match goal with
  | |- flatten _ = _ =>
    apply flatten_eq;
    normalize_get
  | |- flatten_trunc _ _ = _ =>
    apply flatten_trunc_eq;
    normalize_get
  | |- transpose _ = _ =>
    apply transpose_eq;
    normalize_get
  | |- pad_r _ _ = _ =>
    apply pad_r_eq;
    normalize_get
  | |- pad_l _ _ = _ =>
    apply pad_l_eq;
    normalize_get
  | |- trunc_l _ _ = _ =>
    apply trunc_l_eq;
    normalize_get
  | |- trunc_r _ _ = _ =>
    apply trunc_r_eq;
    normalize_get
  | |- GEN [ _ < _ ] _ = _ =>
    apply gen_eq_bound; intros;
    let_lift
  | |- GEN [ _ <= _ < _ ] _ = _ =>
    apply genr_eq_bound; intros;
    let_lift
  | |- SUM [ _ < _ ] _ = _ =>
    apply sum_eq_bound; intros;
    let_lift
  | |- (|[ _ ]| _) = _ =>
    apply iverson_weak;
    let_lift
  | |- let_binding ?e ?f = _ =>
    let ee := fresh "ee" in
    let He := fresh "He" in
    let t := type of e in
    evar (ee : t);
    assert (e = ?ee) as He by (let_lift; try reflexivity);
    lift_evar;
    try rewrite He;
    try clear He;
    drop_evar;
    eapply tlet_eq_body; intros;
    let_lift
  | |- ?a <++> ?b = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Ha;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Hb;
    drop_evar;
    repeat rewrite ll_concat_r;
    repeat rewrite ll_concat_l;
    try reflexivity
  | |- (?a + ?b)%R = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Ha;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Hb;
    drop_evar;
    repeat rewrite ll_plus_r;
    repeat rewrite ll_plus_l;
    try reflexivity
  | |- (?a / ?b)%R = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Ha;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Hb;
    drop_evar;
    repeat rewrite ll_div_r;
    repeat rewrite ll_div_l;
    try reflexivity
  | |- (?a * ?b)%R = _ =>
    let ae := fresh "ae" in
    let Ha := fresh "Ha" in
    evar (ae : R);
    assert (a = ?ae) as Ha by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Ha;
    drop_evar;
    let be := fresh "be" in
    let Hb := fresh "Hb" in
    evar (be : R);
    assert (b = ?be) as Hb by (let_lift; try reflexivity);
    lift_evar;
    try rewrite Hb;
    drop_evar;
    repeat rewrite ll_mult_r;
    repeat rewrite ll_mult_l;
    try reflexivity
  | |- _ _[_] = _ =>
    repeat rewrite ll_get;
    reflexivity
  | |- _ = _ =>
    try reflexivity
  end.

Ltac normalize_ssa :=
  etransitivity; [ normalize_get; try reflexivity | ];
  etransitivity; [ let_lift; try reflexivity | ]; lazy beta.

Ltac normalize := normalize_types; normalize_ssa.

Goal forall (f : list R) n m,
      consistent f (m,tt) ->
      (1 < n)%Z ->
      (tlet buf := GEN [ i < n ] f _[i] in
           GEN [ i < n ] (|[ 0 <=? i-1 ]| buf _[i-1]) <+> buf _[i])
      = @nil _.
Proof.
  intros. normalize.
Abort.

Goal forall n i j m c,
    ((GEN [ - m + 1 <= k < n ]
                               (|[ k =? 2 + (- m + 1) ]| 1)) _[ i - j ] *
     c _[ j ])%R = 0%R.
Proof. intros.
       normalize.
Abort.

Goal forall N M (v : list (list R)),
    2 < N ->
    2 < M ->
    consistent v (N,(M,tt)) ->
(tlet blurx'
:= (GEN [ i < 1 ]
    GEN [ j < Z.of_nat M ]
    0%R) <++>
   (GEN [ y < Z.of_nat N ]
    GEN [ x < Z.of_nat M ]
    0%R) <++>
   (GEN [ y < 1 ]
    GEN [ x < Z.of_nat M ]
    0%R)
 in GEN [ y < Z.of_nat N ]
GEN [ x < Z.of_nat M ]
blurx' _[ y; x])
   = @nil _.
Proof.
  intros. normalize.
Abort.

Goal forall (v : list (list R)) n m,
    0 < n ->
    0 < m ->
    consistent v (n,(m,tt)) ->
    (GEN [ i < Z.of_nat n ] v _[i]) <++> (GEN [ i < Z.of_nat n ] v _[i])
    = @nil _.
Proof. intros. normalize.
Abort.

Goal forall m n (v : list (list R)),
    0 < n ->
    0 < m ->
    consistent v (n,(m,tt)) ->
    v = v.
Proof.
  intros. normalize.
Abort.

Goal forall n m (v : list (list R)),
    0 < n ->
    0 < m ->
    consistent v (n,(m,tt)) ->
    (tlet x := v _[0] <+> v _[1] in
      x _[0]) <+> 0%R = 0%R.
Proof.
  intros. normalize.
Abort.

Goal forall n m (v : list (list R)),
    0 < n ->
    0 < m ->
    consistent v (n,(m,tt)) ->
    (tlet x := v _[0] in
      tensor_add x x) = @nil _.
Proof.
  intros. normalize.
Abort.

Goal forall n m (x2 : list (list R)) k,
    0 < k ->
    0 < n ->
    0 < m ->
    consistent x2 (n,(m,tt)) ->
                   (
           (GEN [ i2 < Z.of_nat k ]
                (|[ 3 * Z.of_nat k  <? Z.of_nat n ]|
                     0%R)))

 = @nil _.
Proof. intros. normalize. Abort.


Set Implicit Arguments.
Require Import List Arith Lia.
From Undecidability.HOU Require Import std.std calculus.calculus.
Import ListNotations.
From Undecidability.HOU.second_order Require Import diophantine_equations dowek.encoding.
Require Import Undecidability.HOU.unification.nth_order_unification.
Import ArsInstances.
(* ** Equivalences *)
Section EquationEquivalences.

  Variable (X: Const) (sigma: fin -> exp X).
  Hypothesis (N: forall x, normal (sigma x)).

  Section Variables.

    Lemma forward_vars x n:
      sigma x = enc n -> sigma • fst (varEQ x) ≡ sigma • snd (varEQ x).
    Proof.
      intros; unfold varEQ, fst, snd.
      cbn. unfold shift, var_zero, funcomp; rewrite H; asimpl.
      rewrite !enc_app.
      change (var 0 (var 1)) with (@AppL X (repeat (var 0) 1) (var 1)).
      now rewrite <-AppL_app, <-repeated_plus, Nat.add_comm.
    Qed.

    Lemma backward_vars x:
      sigma • fst (varEQ x) ≡ sigma • snd (varEQ x) ->  exists n, sigma x = enc n.
    Proof using N.
      intros ?. eapply enc_characteristic; trivial.
      cbn in H. asimpl. asimpl in H.
      unfold shift in *. unfold funcomp at 5 in H.
      asimpl in H. rewrite <-H.
      unfold funcomp at 4. asimpl.
      reflexivity.
    Qed.

  End Variables.

  Section Constants.
    Variable (x n c: nat).
    Hypothesis (EQx: sigma x = enc n).

    Lemma forward_consts:
      n = 1 -> sigma • fst (constEQ x) ≡ sigma • snd (constEQ x).
    Proof using EQx.
      intros; unfold constEQ, fst, snd. subst.
      asimpl; now rewrite EQx.
    Qed.

    Lemma backward_consts:
      sigma • fst (constEQ x) ≡ sigma • snd (constEQ x) -> n = 1.
    Proof using EQx.
      intros EQ; unfold constEQ, fst, snd in EQ.
      asimpl in EQ. rewrite EQx in EQ.
      eapply enc_equiv_injective; eauto.
    Qed.

  End Constants.

  Section Addition.
    Variable (x y z n m p c: nat).
    Hypothesis (EQx: sigma x = enc m) (EQy: sigma y = enc n) (EQz: sigma z = enc p).

    Lemma forward_add:
      m + n = p -> sigma • fst (addEQ x y z) ≡ sigma • snd (addEQ x y z).
    Proof using EQz EQy EQx.
      intros; unfold addEQ, fst, snd; asimpl.
      now rewrite EQx, EQy, EQz, <-enc_add, H.
    Qed.

    Lemma backward_add:
      sigma • fst (addEQ x y z) ≡ sigma • snd (addEQ x y z) -> m + n = p.
    Proof using EQz EQy EQx.
      intros EQ; unfold addEQ, fst, snd in EQ; asimpl in EQ.
      rewrite EQx, EQy, EQz, <-enc_add in EQ.
      eauto using enc_equiv_injective.
    Qed.

  End Addition.

  Section Multiplication.
    Variable (x y z n m p c: nat).
    Hypothesis (EQx: sigma x = enc m) (EQy: sigma y = enc n) (EQz: sigma z = enc p).

    Lemma forward_mult :
      m * n = p -> sigma • fst (mulEQ x y z) ≡ sigma • snd (mulEQ x y z).
    Proof using EQz EQy EQx.
      intros; unfold mulEQ, fst, snd; asimpl.
      now rewrite EQx, EQy, EQz, <-enc_mul, H.
    Qed.

    Lemma backward_mult:
      sigma • fst (mulEQ x y z) ≡ sigma • snd (mulEQ x y z) -> m * n = p.
    Proof using EQz EQy EQx.
      intros EQ; unfold mulEQ, fst, snd in EQ; asimpl in EQ.
      rewrite EQx, EQy, EQz, <-enc_mul in EQ.
      eauto using enc_equiv_injective.
    Qed.

  End Multiplication.
End  EquationEquivalences.

(* ** Forward Direction **)
Section Forward.
  Variable (X: Const) (E: list deq).

  Implicit Types (x y z: nat) (c: nat).

  Definition encs theta: fin -> exp X := theta >> enc.

  Lemma forward_typing theta:
    nil ⊩( 3) encs theta : Gamma__dwk E.
  Proof.
    intros ?? <- % nth_error_In % repeated_in.
    eapply typing_enc.
  Qed.

  Lemma H10_DWK : H10 E -> SOU X 3 (H10_to_DWK X E).
  Proof.
    intros [theta H].
    exists []. exists (encs theta). split.
    now eapply forward_typing.
    intros s t H'; cbn.
    change s with (fst (s, t)); change t with (snd (s, t)) at 2.
    remember (s,t) as q. clear Heqq.
    cbn in *. eapply in_Equations in H' as (e & ? & ?).
    eapply H in H0.
    destruct e; cbn in *; intuition idtac; subst.
    all: try eapply forward_add. all: try eapply forward_consts.
    all: try eapply forward_mult. all: try eapply forward_vars.
    all: unfold encs, funcomp; eauto. try eapply enc_sol_encodes.
    all: inv H0; eauto.
  Qed.

End Forward.

(* ** Backward Direction **)
Section Backward.
  Variable (X: Const).
  Implicit Types (sigma: nat -> exp X) (x y z c n: nat).

  Definition sub_sol sigma x :=
    match dec_enc (sigma x) with
    | inl (exist _ k _) => k
    | inr _ => 0
    end.

  Lemma sub_sol_enc sigma x n:
    sigma x = enc n -> sub_sol sigma x = n.
  Proof.
    intros H; unfold sub_sol; destruct dec_enc as [[m H']|H'].
    rewrite H' in H; eapply enc_injective in H; trivial.
    eapply H' in H; intuition.
  Qed.

  Lemma DWK_H10 E: SOU X 3 (H10_to_DWK X E) -> H10 E.
  Proof.
    rewrite SOU_NSOU; eauto. intros (Delta & tau & T & EQ & N).
    exists (sub_sol tau).
    assert (forall e, e ∈ Eqs E -> tau • fst e ≡ tau • snd e) as H by now intros []; eauto.
    intros e Hin. destruct e; econstructor.
    all: edestruct (@in_Equations X (varEQ x) E) as [_ EQx]; mp EQx;
      [eexists; intuition eauto; cbn; intuition | eapply H in EQx].
    2, 3: edestruct (@in_Equations X (varEQ y) E) as [_ EQy]; mp EQy;
      [eexists; intuition eauto; cbn; intuition| eapply H in EQy].
    2, 3: edestruct (@in_Equations X (varEQ z) E) as [_ EQz]; mp EQz;
      [eexists; intuition eauto; cbn; intuition| eapply H in EQz].
    all: eapply backward_vars in EQx as [n]; eauto.
    2 - 3: eapply backward_vars in EQy as [m]; eauto.
    2 - 3: eapply backward_vars in EQz as [p]; eauto.
    all: repeat (erewrite sub_sol_enc; [|eauto]).
    - eapply backward_consts; [eauto|].
      eapply H, in_Equations; eexists; intuition eauto.
      cbn; intuition.
    - eapply backward_add; [eauto..|].
      eapply H, in_Equations; eexists; intuition eauto.
      cbn; intuition.
    - eapply backward_mult; [eauto..|].
      eapply H, in_Equations; eexists; intuition eauto.
      cbn; intuition.
  Qed.
End Backward.

Lemma Dowek X : H10 ⪯ SOU X 3.
Proof.
  exists (H10_to_DWK X). intros E.
  split; eauto using H10_DWK, DWK_H10.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(* -------------------------------------------------------------------- *)
From Coq      Require Import Uint63 BinNat.
From mathcomp Require Import all_ssreflect all_algebra.
Require Import int63.
Require Import NArith PArith BinNatDef BinPosDef.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Section Misc.
Lemma peano_modE m n: m %% n = PeanoNat.Nat.modulo m n.
Proof.
case: n=> [|n] //.
rewrite [in RHS](divn_eq m n.+1).
rewrite addnC PeanoNat.Nat.mod_add //.
rewrite PeanoNat.Nat.mod_small //.
by apply/ssrnat.ltP/ltn_pmod.
Qed.
End Misc.

Section Int63Ordinal.

Definition ord63 := 'Z_(int63_threshold).

Lemma Zp_trunc_ord63E: (Zp_trunc int63_threshold).+2 = int63_threshold.
Proof.
rewrite /Zp_trunc !prednK //;
  [rewrite ltn_predRL; exact:int63_threshold1|exact:int63_threshold0].
Qed.

Program Definition int63_to_ord63 (x : int63) : ord63 := @Ordinal _ (int63_to_nat x) _.
Next Obligation. rewrite Zp_trunc_ord63E; exact: int63_thresholdP. Qed.

Definition ord63_to_int63 (x : ord63):= nat_to_int63 x.

Lemma int63_to_ord63K: forall x : int63, x = ord63_to_int63 (int63_to_ord63 x).
Proof.
by move=> x /=; rewrite /ord63_to_int63 /int63_to_ord63 /= int63_to_natK.
Qed.

Lemma int63_to_ord63K_sym: forall x : int63, ord63_to_int63 (int63_to_ord63 x) = x.
Proof. by move=> ?; rewrite -int63_to_ord63K. Qed.

Lemma ord63_to_int63K: forall x : ord63, int63_to_ord63 (ord63_to_int63 x) = x.
Proof.
move=> x; apply/val_inj=> /=; case: x=> x ? /=.
by rewrite nat_to_int63K //= inE -Zp_trunc_ord63E.
Qed.

Lemma ord63_to_int63K_sym: forall x : ord63, x = int63_to_ord63 (ord63_to_int63 x).
Proof. by move=> ?; rewrite ord63_to_int63K. Qed.

Definition ord63_eqb (x y : ord63): bool := x == y.

Lemma ord63_eqbP: forall x y : int63, (x =? y)%uint63 =
  ord63_eqb (int63_to_ord63 x) (int63_to_ord63 y).
Proof. by move=> x y; rewrite eqEint63 /ord63_eqb -val_eqE /=. Qed.

Lemma int63_eqbP: forall x y : ord63,
  ord63_eqb x y = (ord63_to_int63 x =? ord63_to_int63 y)%uint63.
Proof.
move=> x y; rewrite -[in LHS](ord63_to_int63K x) -[in LHS](ord63_to_int63K y).
by rewrite ord63_eqbP.
Qed.

Lemma ord63_eqP: forall x y : int63, x = y <-> int63_to_ord63 x = int63_to_ord63 y.
Proof.
move=> x y; split; first by move=> ->.
by move/(congr1 val)/int63_to_nat_inj.
Qed.

Lemma int63_eqP: forall x y : ord63, x = y <-> ord63_to_int63 x = ord63_to_int63 y.
Proof.
move=> x y; split; first by move=> ->.
by rewrite -[x]ord63_to_int63K -[y]ord63_to_int63K -!int63_to_ord63K => ->.
Qed.

Lemma ord63_addP: forall x y : int63,
  int63_to_ord63 (x + y)%uint63 = ((int63_to_ord63 x) + (int63_to_ord63 y))%R.
Proof.
move=> x y; apply/val_inj=> /=.
rewrite /int63_to_nat Zp_trunc_ord63E add_spec.
rewrite Znat.Z2Nat.inj_mod //;
  first by (apply:BinInt.Z.add_nonneg_nonneg; exact:int63_to_Z_ge0).
rewrite Znat.Z2Nat.inj_add; try exact:int63_to_Z_ge0.
by rewrite wB_def plusE peano_modE.
Qed.

Lemma int63_addP: forall x y : ord63,
  ord63_to_int63 (x + y)%R = (ord63_to_int63 x + ord63_to_int63 y)%uint63.
Proof.
move=> x y.
by rewrite -[x]ord63_to_int63K -[y]ord63_to_int63K -ord63_addP -!int63_to_ord63K.
Qed.

Lemma ord63_mulP: forall x y : int63,
  int63_to_ord63 (x * y)%uint63 = ((int63_to_ord63 x) * (int63_to_ord63 y))%R.
Proof.
move=> x y; apply/val_inj=> /=; rewrite Zp_trunc_ord63E.
rewrite /int63_to_nat mul_spec Znat.Z2Nat.inj_mod;
  last rewrite wB_def peano_modE Znat.Z2Nat.inj_mul //.
- apply/Ztac.mul_le; exact: int63_to_Z_ge0.
- exact/BinInt.Z.lt_le_incl/wB_pos.
- exact: int63_to_Z_ge0.
- exact: int63_to_Z_ge0.
Qed.

Lemma int63_mulP: forall x y : ord63,
  ord63_to_int63 (x * y)%R =
  (ord63_to_int63 x * ord63_to_int63 y)%uint63.
Proof.
move=> x y.
by rewrite -[x]ord63_to_int63K -[y]ord63_to_int63K -ord63_mulP -!int63_to_ord63K.
Qed.

Lemma ord63_0P: int63_to_ord63 0%uint63 = (ord0 : ord63).
Proof. exact/val_inj. Qed.
Lemma int63_0P: ord63_to_int63 ord0 = 0%int63.
Proof. by []. Qed.

Lemma ord63_1P: int63_to_ord63 1%uint63 = (1%R : ord63).
Proof. exact/val_inj. Qed.
Lemma int63_1P: ord63_to_int63 (1%R : ord63) = 1%uint63.
Proof. by []. Qed.

Lemma ord63_leP: forall x y : int63,
  (x <=? y)%uint63 = ((int63_to_ord63 x) <= (int63_to_ord63 y))%nat.
Proof. by move=> x y /=; rewrite -leEint63. Qed.

Lemma ord63_ltP: forall x y : int63,
  (x <? y)%uint63 = ((int63_to_ord63 x) < (int63_to_ord63 y))%nat.
Proof. by move=> x y /=; rewrite -ltEint63. Qed.

Lemma int63_leP: forall x y : ord63,
  (x <= y)%nat = (ord63_to_int63 x <=? ord63_to_int63 y)%uint63.
Proof.
move=> x y.
by rewrite -[x]ord63_to_int63K -[y]ord63_to_int63K ord63_leP -!int63_to_ord63K.
Qed.

Lemma int63_ltP: forall x y : ord63,
  (x < y)%nat = (ord63_to_int63 x <? ord63_to_int63 y)%uint63.
Proof.
move=> x y.
by rewrite -[x]ord63_to_int63K -[y]ord63_to_int63K ord63_ltP -!int63_to_ord63K.
Qed.

Fixpoint int63_exp_ (fuel : nat) (x n : int63):=
  if (n =? 0)%uint63 then 1%uint63 else
    if fuel is k.+1 then
      if is_even n then
        (int63_exp_ k x (n >> 1)%uint63 * int63_exp_ k x (n >> 1))%uint63 else
      (x * (int63_exp_ k x (n >> 1)) * (int63_exp_ k x (n >> 1)))%uint63
    else x.

Definition int63_exp (x n : int63):=
  int63_exp_ Uint63.size x n.

Lemma ord63_expP (x n : int63):
  int63_to_ord63 (int63_exp x n) = ((int63_to_ord63 x) ^ (int63_to_ord63 n))%R.
Proof.
apply/val_inj=> /=.
rewrite /int63_exp.
Admitted.

Lemma int63_expP (x : ord63) (n : N):
  ord63_to_int63 (x ^ n)%R = int63_exp (ord63_to_int63 x) n.
Proof.
Admitted.

End Int63Ordinal.


From iris.program_logic Require Import language ectx_language ectxi_language.
From st.prelude Require Export autosubst generic lang_base.
From stdpp Require Import gmap prelude.
From st.STLCmuVS Require lang.

(* Local Open Scope Z_scope. *)

(** Locations are defined as positive numbers *)
Definition loc := positive.

Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

(** The litterals of the language *)
Inductive base_lit : Set :=
| LitInt (n : Z) | LitBool (b : bool) | LitUnit | LitLoc (l : loc).

(* Inductive bin_op : Set := *)
(* | PlusOp | MinusOp | LeOp | LtOp | EqOp. *)

(** The syntax of expressions *)
Inductive expr :=
| Var (x : var)
| LetIn (e1 : expr) (e2 : {bind 1 of expr})
| Lam (e : {bind 1 of expr})
(* | Fix (e : expr) *)
(* | Rec (e : {bind 2 of expr}) *)
| App (e1 e2 : expr)
(* Base Types *)
| Lit (l : base_lit)
| BinOp (op : bin_op) (e1 e2 : expr)
| If (e0 e1 e2 : expr)
| Seq (e1 e2 : expr)
(* Products *)
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
(* Sums *)
| InjL (e : expr)
| InjR (e : expr)
| Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
(* Recursive Types *)
| Fold (e : expr)
| Unfold (e : expr)
(** Polymorphic Types *)
(* | TLam (e : expr) *)
(* | TApp (e : expr) *)
(* Kleisli *)
| Return (e: expr)
| Bind (e1: expr) (e2: expr)
| RunST (e: expr)
(* Reference Types *)
| Alloc (e : expr)
| Read (e : expr)
| Write (e1 : expr) (e2 : expr)
| Compare (e1 : expr) (e2 : expr).

Coercion LitInt : Z >-> base_lit.
Coercion LitBool : bool >-> base_lit.
Coercion LitLoc : loc >-> base_lit.
Coercion Lit : base_lit >-> expr.
Coercion App : expr >-> Funclass.
Coercion Var : var >-> expr.

Declare Scope expr_st_scope.
Delimit Scope expr_st_scope with Eₛₜ.
Notation "% x" := (Var x%nat) (at level 8, format "% x") : expr_st_scope.

Notation "()" := (Lit LitUnit) : expr_st_scope.
Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_st_scope.

Notation "e1 + e2" := (BinOp PlusOp e1%Eₛₜ e2%Eₛₜ) : expr_st_scope.
Notation "e1 - e2" := (BinOp MinusOp e1%Eₛₜ e2%Eₛₜ) : expr_st_scope.
Notation "e1 ≤ e2" := (BinOp LeOp e1%Eₛₜ e2%Eₛₜ) : expr_st_scope.
Notation "e1 < e2" := (BinOp LtOp e1%Eₛₜ e2%Eₛₜ) : expr_st_scope.
Notation "e1 = e2" := (BinOp EqOp e1%Eₛₜ e2%Eₛₜ) : expr_st_scope.

Instance Var_Inj : Inj eq eq Var. intros x1 x2 eq. by inversion eq. Qed.

Instance Ids_expr : Ids expr. derive. Defined.
Instance Rename_expr : Rename expr. derive. Defined.
Instance Subst_expr : Subst expr. derive. Defined.
Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

Lemma Var_closed_n_lt (x : var) n (p : Closed_n n (Var x)) : x < n.
Proof. apply ids_lt_Closed_n. apply p. Qed.

(** Values for STLang *)
Inductive val :=
| LamV (e : {bind 1 of expr})
(* | RecV (e : {bind 2 of expr}) *)
(* | TLamV (e : {bind 1 of expr}) *)
| LitV (v : base_lit)
| PairV (v1 v2 : val)
| InjLV (v : val)
| InjRV (v : val)
| FoldV (v : val)
(* ST *)
| ReturnV (v: val)
| BindV (v1 v2: val)
| AllocV (v : val)
| ReadV (v : val)
| WriteV (v1 v2 : val).

Declare Scope val_st_scope.
Delimit Scope val_st_scope with Vₛₜ.

Notation "()" := (LitV LitUnit) : val_st_scope.
Notation "( v1 , v2 , .. , vn )" := (PairV .. (PairV v1 v2) .. vn) : val_st_scope.
Coercion LitV : base_lit >-> val.

Fixpoint of_val (v : val) : expr :=
 match v with
 | LamV e => Lam e
 (* | RecV e => Rec e *)
 (* | TLamV e => TLam e *)
 | LitV v => Lit v
 | PairV v1 v2 => Pair (of_val v1) (of_val v2)
 | InjLV v => InjL (of_val v)
 | InjRV v => InjR (of_val v)
 | FoldV v => Fold (of_val v)
 (* ST *)
 | ReturnV v => Return (of_val v)
 | BindV v1 v2 => Bind (of_val v1) (of_val v2)
 | AllocV v => Alloc (of_val v)
 | ReadV v => Read (of_val v)
 | WriteV v v' => Write (of_val v) (of_val v')
 end.

Coercion of_val : val >-> expr.

Definition subst_list_val (vs : list val) : var → expr := subst_list (map of_val vs).

Lemma subst_list_val_cons v vs : of_val v .: subst_list_val vs = subst_list_val (v :: vs).
Proof. intros. by asimpl. Qed.

(* Lemma var_subst_list_val_lt_length (vs : list val) (x : var) (p : x < length vs) : *)
(*   (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v). *)
(* Proof. *)
(*   destruct (vs !! x) eqn:eq. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=. *)
(*   assert (length vs ≤ x). by apply lookup_ge_None. lia. *)
(* Qed. *)
Lemma Var_subst_list_closed_n_length (vs : list val) (x : var) (p : Closed_n (length vs) (Var x)) :
  (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v).
Proof.
  destruct (vs !! x) eqn:eq. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=.
  assert (length vs ≤ x). by apply lookup_ge_None.
  assert (x < length vs). by apply ids_lt_Closed_n. lia.
Qed.

Lemma Var_subst_list_val_lookup (x : var) (ts : list val) t (H : ts !! x = Some t) :
  (ids x).[subst_list_val ts] = t.
Proof. rewrite /subst_list_val. apply ids_subst_list_lookup. by rewrite list_lookup_fmap H. Qed.

Fixpoint to_val (e : expr) : option val :=
 match e with
 | Lam e => Some (LamV e)
 (* | Rec e => Some (RecV e) *)
 (* | TLam e => Some (TLamV e) *)
 | Lit e => Some (LitV e)
 | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
 | InjL e => InjLV <$> to_val e
 | InjR e => InjRV <$> to_val e
 | Fold e => v ← to_val e; Some (FoldV v)
   (* ST  *)
 | Return e => v ← to_val e; Some (ReturnV v)
 | Bind e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (BindV v1 v2)
 | Alloc e => v ← to_val e; Some (AllocV v)
 | Read e => v ← to_val e; Some (ReadV v)
 | Write e e' => v ← to_val e; v' ← to_val e'; Some (WriteV v v')
 | _ => None
 end.

(** Contexts for the effectful language are of the form [Bind (Bind [] v2) v1] *)
Inductive eff_ectx_item := BindECtx (v : val).

(** A function that fills a context with an expression: *)
Definition eff_fill_item (Ki : eff_ectx_item) (e : expr) : expr :=
 match Ki with BindECtx v => Bind e (of_val v) end.

(** The state is defined as finite map from [loc] to [val]: *)
Definition state := gmap loc val.

(** Reduction relation for the effectful language *)
Inductive eff_head_step :
expr -> state -> list Empty_set → expr -> state → list expr → Prop :=
| Read_loc_eff_head_step l σ v :
   σ !! l = Some v ->
   eff_head_step (Read (Lit (LitLoc l))) σ [] (Return (of_val v)) σ []
| Write_loc_val_eff_head_step σ l e v :
   is_Some (σ !! l) -> to_val e = Some v ->
   eff_head_step (Write (Lit (LitLoc l)) e)
                  σ [] (Return (Lit LitUnit)) (<[l:=v]>σ) []
| Alloc_val_eff_head_step σ l e v :
   (σ !! l) = None -> to_val e = Some v ->
   eff_head_step (Alloc e) σ [] (Return (Lit (LitLoc l))) (<[l:=v]>σ) []
| Return_Bind_eff_head_step σ v1 v2 e1 e2 :
   to_val e1 = Some v1 -> to_val e2 = Some v2 ->
   eff_head_step (Bind (Return e1) e2) σ [] (App e2 e1) σ [].

Lemma to_of_val v : to_val (of_val v) = Some v.
Proof.
 by induction v; try simplify_option_eq; repeat f_equal; try apply (proof_irrel _).
Qed.
Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof.
 revert v; induction e; intros v ?; simplify_option_eq; auto with f_equal.
Qed.

(** Values for the effectful language: *)
(* values that we would expect inside a runST block *)
Inductive eff_val :=
| ReturnEV (v : val)
| AppCtxEV (K : list eff_ectx_item) (v1 v2 : val).

Definition of_eff_val (ev : eff_val) : expr :=
match ev with
| ReturnEV w => Return (of_val w)
| AppCtxEV K v1 v2 => fold_right eff_fill_item (App (of_val v1) (of_val v2)) K
end.

Instance maybe_AppCtxEV : Maybe3 AppCtxEV := λ ev,
 match ev with AppCtxEV K e1 e2 => Some (K, e1, e2) | _ => None end.

Fixpoint to_eff_val (e : expr) : option eff_val :=
 match e with
 | Return e => v ← to_val e; Some (ReturnEV v)
 | App e e' => v ← to_val e; v' ← to_val e'; Some (AppCtxEV [] v v')
 | Bind e e' => '(K, v1, v2) ← to_eff_val e ≫= maybe3 AppCtxEV; v' ← to_val e';
                 Some (AppCtxEV (BindECtx v' :: K) v1 v2)
 | _ => None
 end.

Lemma to_of_eff_val v : to_eff_val (of_eff_val v) = Some v.
Proof.
 destruct v as [|K v1 v2]; first by rewrite /= to_of_val.
 induction K as [|[]]; first rewrite /= !to_of_val //.
 rewrite /= IHK /= to_of_val //.
Qed.

Lemma of_to_eff_val e v : to_eff_val e = Some v → of_eff_val v = e.
  revert v. induction e => v; rewrite //=.
  - destruct (to_val e1) eqn:Heq1; rewrite //=;
    destruct (to_val e2) eqn:Heq2; rewrite //=.
    inversion 1; subst; simpl; erewrite !of_to_val; eauto.
 - destruct (to_val e) eqn:Heq1; rewrite //=.
   inversion 1; subst; simpl; erewrite !of_to_val; eauto.
 - destruct (to_eff_val e1) as [[]|] eqn:Heq1; rewrite //=.
   destruct (to_val e2) eqn:Heq2; rewrite //=. inversion 1; subst; simpl.
   specialize (IHe1 (AppCtxEV K _ _) eq_refl). simpl in *. rewrite IHe1.
   erewrite !of_to_val; eauto.
Qed.

(** Equality and other typeclass stuff *)
Instance of_val_inj : Inj (=) (=) of_val.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.
Instance eff_of_val_inj : Inj (=) (=) of_eff_val.
Proof.
 intros v; induction v => w.
 - destruct w; simpl.
   + inversion 1; subst; f_equal; by apply of_val_inj.
   + destruct K as [|[]]; done.
 - revert v1 v2 w. induction K as [|[] K'] => v1 v2 w; (destruct w; first done).
   + destruct K as [|[] K]; inversion 1; f_equal; eauto using of_val_inj.
   + destruct K as [|[]]; first done.
     inversion 1 as [[Hb1 Hb2]].
     specialize (IHK' _ _ (AppCtxEV K _ _) Hb1). inversion IHK'; subst.
     erewrite of_val_inj; eauto.
Qed.

Instance base_lit_eq_dec : EqDecision base_lit.
Proof. solve_decision. Defined.
(* Instance bin_op_eq_dec : EqDecision lang.bin_op. *)
(* Proof. solve_decision. Defined. *)
Instance expr_eq_dec : EqDecision expr.
Proof. solve_decision. Defined.
Instance val_eq_dec : EqDecision val.
Proof.
 refine (λ v v', cast_if (decide (of_val v = of_val v')));
   abstract naive_solver.
Defined.
Instance eff_val_eq_dec : EqDecision eff_val.
Proof.
 refine (λ v v', cast_if (decide (of_eff_val v = of_eff_val v')));
   abstract naive_solver.
Defined.

Instance expr_inhabited : Inhabited expr := populate (Lit LitUnit).
Global Instance val_inhabited : Inhabited val := populate (LitV LitUnit).
Canonical Structure stateC := leibnizO state.
Canonical Structure valC := leibnizO val.
Canonical Structure eff_valC := leibnizO eff_val.
Canonical Structure exprC := leibnizO expr.

Instance eff_fill_item_inj Ki : Inj (=) (=) (eff_fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.
Lemma eff_fill_item_val Ki e :
 is_Some (to_eff_val (eff_fill_item Ki e)) → is_Some (to_eff_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.
Lemma eff_val_stuck e1 σ1 κ e2 σ2 efs :
 eff_head_step e1 σ1 κ e2 σ2 efs → to_eff_val e1 = None.
Proof. destruct 1; try done. simpl; rewrite H H0; done. Qed.
Lemma eff_head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
 eff_head_step (eff_fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_eff_val e).
Proof. destruct Ki; inversion_clear 1; simplify_option_eq; by eauto. Qed.
Lemma eff_fill_item_no_val_inj Ki1 Ki2 e1 e2 :
 to_eff_val e1 = None → to_eff_val e2 = None →
 eff_fill_item Ki1 e1 = eff_fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
 destruct Ki1, Ki2; intros; try discriminate; simplify_eq/=;
  repeat match goal with
  | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
  end; auto.
Qed.

(** Both languages share the same syntax: *)
Definition eff_expr := expr.

(** We declare that the effectful language is a language to Iris by giving the
 expressions, values, contexts and operations and lemmas on those. *)

Lemma eff_ectxi_lang_mixin : EctxiLanguageMixin of_eff_val to_eff_val eff_fill_item eff_head_step.
  split; eauto using to_of_eff_val, of_to_eff_val,
  eff_val_stuck, eff_fill_item_val, eff_fill_item_no_val_inj,
  eff_head_ctx_step_val, eff_fill_item_inj.
Qed.

Definition eff_ectxi_lang : ectxiLanguage := EctxiLanguage eff_ectxi_lang_mixin.
Definition eff_ectx_lang : ectxLanguage := EctxLanguageOfEctxi eff_ectxi_lang.
Definition eff_lang : language := LanguageOfEctx eff_ectx_lang.

(* Canonical Structure eff_ectxi_lang : ectxiLanguage := EctxiLanguage eff_ectxi_lang_mixin. *)
(* Canonical Structure eff_ectx_lang : ectxLanguage := EctxLanguageOfEctxi eff_ectxi_lang. *)
(* Canonical Structure eff_lang : language := LanguageOfEctx eff_ectx_lang. *)

Definition eff_fill : list (eff_ectx_item) → eff_expr → eff_expr := @fill eff_ectxi_lang.
Definition eff_prim_step := @prim_step eff_ectxi_lang.

Lemma eff_fill_val K e :
 is_Some (to_eff_val (eff_fill K e)) → is_Some (to_eff_val e).
Proof.
  apply (@fill_val eff_ectxi_lang).
Qed.

Lemma eff_head_step_val σ (e : eff_expr) κ σ' e' efs :
  eff_prim_step e σ κ e' σ' efs → is_Some (to_val e).
Proof.
  intros Hps. eapply prim_step_ind; eauto.
  intros K; revert e σ e' σ' Hps.
  induction K as [|Ki K IHK] using rev_ind; intros e σ e' σ' Hps e1' e2' He He' Hps'.
  - inversion Hps' as []; subst; simpl; eauto;
    repeat match goal with
    | H : to_val _ = _ |- _ => rewrite H
    end; simpl; eauto.
 - destruct Ki. simpl; intros; subst. rewrite /= fill_app /= to_of_val /=.
   edestruct (IHK (ectx_language.fill K e1')) as [? Heq]; eauto.
   by apply Ectx_step'. simpl in *; rewrite Heq; eauto.
Qed.

(** Evaluation contexts *)
Inductive ectx_item :=
(* | FixCtx *)
| LetInCtx (e2 : expr)
| AppLCtx (e2 : expr)
| AppRCtx (v1 : val)
(* | TAppCtx *)
| PairLCtx (e2 : expr)
| PairRCtx (v1 : val)
| FstCtx
| SndCtx
| InjLCtx
| InjRCtx
| CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
| IfCtx (e2 : expr) (e3 : expr)
| BinOpLCtx (op : bin_op) (e2 : expr)
| BinOpRCtx (op : bin_op) (v1 : val)
| SeqCtx (e2 : expr)
| FoldCtx
| UnfoldCtx
(* ST *)
| AllocCtx
| ReadCtx
| WriteLCtx (e2 : expr)
| WriteRCtx (v1 : val)
| ReturnCtx
| BindLCtx (e2: expr)
| BindRCtx (v1: val)
| RunSTCtx
| CompLCtx (e2 : expr)
| CompRCtx (v1 : val).

Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
 match Ki with
 (* | FixCtx => Fix e *)
 | LetInCtx e2 => LetIn e e2
 | AppLCtx e2 => App e e2
 | AppRCtx v1 => App (of_val v1) e
 (* | TAppCtx => TApp e *)
 | PairLCtx e2 => Pair e e2
 | PairRCtx v1 => Pair (of_val v1) e
 | FstCtx => Fst e
 | SndCtx => Snd e
 | InjLCtx => InjL e
 | InjRCtx => InjR e
 | CaseCtx e1 e2 => Case e e1 e2
 | IfCtx e1 e2 => If e e1 e2
 | BinOpLCtx op e2 => BinOp op e e2
 | BinOpRCtx op v1 => BinOp op (of_val v1) e
 | SeqCtx e2 => Seq e e2
 | FoldCtx => Fold e
 | UnfoldCtx => Unfold e
 (* ST *)
 | AllocCtx => Alloc e
 | ReadCtx => Read e
 | WriteLCtx e2 => Write e e2
 | WriteRCtx v1 => Write (of_val v1) e
 | ReturnCtx => Return e
 | BindLCtx e2 => Bind e e2
 | BindRCtx v1 => Bind (of_val v1) e
 | RunSTCtx => RunST e
 | CompLCtx e2 => Compare e e2
 | CompRCtx v1 => Compare (of_val v1) e
 end.

(** The stepping relation *)

Definition bin_op_eval (op : bin_op) (z1 z2 : Z) : val :=
 match op with
 | PlusOp => LitV $ LitInt (z1 + z2)%Z
 | MinusOp => LitV $ LitInt (z1 - z2)
 | LeOp => LitV $ LitBool $ bool_decide (z1 ≤ z2)%Z
 | LtOp => LitV $ LitBool $ bool_decide (z1 < z2)%Z
 | EqOp => LitV $ LitBool $ bool_decide (z1 = z2)
 end.

(** Reduction relation for STLang: *)
Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
(* Embedding of the effectful language into STLang *)
| RunST_eff_head_step σ σ' (e : eff_expr) e' :
   eff_prim_step e σ [] e' σ' [] ->
   head_step (RunST e) σ [] (RunST e') σ' []
| RunST_Return_head_step σ e v :
    to_val e = Some v ->
    head_step (RunST (Return e)) σ [] e σ []
| Compare_suc_head_step σ l :
    head_step
      (Compare (Lit (LitLoc l)) (Lit (LitLoc l))) σ [] (Lit (LitBool true)) σ []
| Compare_fail_head_step σ l l' :
    l ≠ l' →
    head_step
      (Compare (Lit (LitLoc l)) (Lit (LitLoc l'))) σ [] (Lit (LitBool false)) σ []
(* β *)
| LetIn_head_step e1 v1 e2 σ :
   to_val e1 = Some v1 →
   head_step (LetIn e1 e2) σ [] e2.[e1/] σ []
| App_Lam_head_step e1 e2 v2 σ :
   to_val e2 = Some v2 →
   head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
(* | App_Rec_head_step e1 e2 v2 σ : *)
   (* to_val e2 = Some v2 → *)
   (* head_step (App (Rec e1) e2) σ [] e1.[(Rec e1), e2/] σ [] *)
(* fix *)
(* | Fix_head_step e σ : *)
    (* head_step (Fix (Lam e)) σ [] e.[Fix (Lam e)/] σ [] *)
(* binary operation *)
| BinOp_head_step op e1 e2 z1 z2 σ :
   to_val e1 = Some (LitV $ LitInt z1) → to_val e2 = Some (LitV $ LitInt z2) →
   head_step (BinOp op e1 e2) σ [] (of_val (bin_op_eval op z1 z2)) σ []
(* if *)
| If_True_head_step e1 e2 σ :
   head_step (If (Lit $ LitBool true) e1 e2) σ [] e1 σ []
| If_False_head_step e1 e2 σ :
   head_step (If (Lit $ LitBool false) e1 e2) σ [] e2 σ []
(* seq *)
| Seq_Unit_head_step e1 e2 σ :
    to_val e1 = Some ()%Vₛₜ →
    head_step (Seq e1 e2) σ [] e2 σ []
(* Products *)
| Fst_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 → to_val e2 = Some v2 →
   head_step (Fst (Pair e1 e2)) σ [] e1 σ []
| Snd_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 → to_val e2 = Some v2 →
   head_step (Snd (Pair e1 e2)) σ [] e2 σ []
(* Sums *)
| Case_InjL_head_step e0 v0 e1 e2 σ :
   to_val e0 = Some v0 →
   head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
| Case_InjR_head_step e0 v0 e1 e2 σ :
   to_val e0 = Some v0 →
   head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ []
(* Recursive Types *)
| Unfold_Fold_head_step e v σ :
   to_val e = Some v →
   head_step (Unfold (Fold e)) σ [] e σ [].
(* Polymorphic Types *)
(* | TBeta e σ : *)
   (* head_step (TApp (TLam e)) σ [] e σ []. *)

Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.
Lemma fill_item_val Ki e :
 is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.
Lemma val_stuck e1 σ1 κ e2 σ2 efs :
 head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
Proof. destruct 1; done. Qed.
Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
 head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e).
Proof.
 destruct Ki; inversion_clear 1; simplify_option_eq; eauto.
  eauto using eff_head_step_val.
Qed.
Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
 to_val e1 = None → to_val e2 = None →
 fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
 destruct Ki1, Ki2; intros; try discriminate; simplify_eq/=;
  repeat match goal with
  | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
  end; auto.
Qed.

Lemma STLCmuST_ectxi_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
Proof.
  split; eauto using to_of_val, of_to_val,
  val_stuck, fill_item_val, fill_item_no_val_inj,
 head_ctx_step_val, fill_item_inj.
Qed.

Canonical Structure STLCmuST_ectxi_lang : ectxiLanguage := EctxiLanguage STLCmuST_ectxi_lang_mixin.
Canonical Structure STLCmuST_ectx_lang : ectxLanguage := EctxLanguageOfEctxi STLCmuST_ectxi_lang.
Canonical Structure STLCmuST_lang : language := LanguageOfEctx STLCmuST_ectx_lang.

Lemma ST_step_no_spawn e1 e2 σ1 κ σ2 nt:
  @language.prim_step STLCmuST_lang e1 σ1 κ e2 σ2 nt -> nt = [].
Proof. elim=> ? ? ? ? ? H. by elim: H. Qed.
Lemma ST_step_no_obs e1 e2 σ1 κ σ2 nt:
  @language.prim_step STLCmuST_lang e1 σ1 κ e2 σ2 nt -> κ = [].
Proof. elim=> ? ? ? ? ? H. by elim: H. Qed.

Lemma eff_step_no_spawn e1 e2 σ1 κ σ2 nt:
  @language.prim_step eff_lang e1 σ1 κ e2 σ2 nt -> nt = [].
Proof. elim=> ? ? ? ? ? H. by elim: H. Qed.
Lemma eff_step_no_obs e1 e2 σ1 κ σ2 nt:
  @language.prim_step eff_lang e1 σ1 κ e2 σ2 nt -> κ = [].
Proof. elim=> ? ? ? ? ? H. by elim: H. Qed.

Lemma fill_val (e : expr) (K : list ectx_item):
  is_Some (to_val (fill K e)) -> is_Some (to_val e).
Proof.
  move=> [v h]. destruct (to_val e) eqn:eq.
    by exists v0.
    have fill_not_val: to_val (fill K e) = None. eauto using fill_not_val.
    congruence.
Qed.

Arguments val_stuck {_ _ _ _ _} _.
Arguments eff_head_step_val {_ _ _ _ _} _.
Arguments eff_step_no_spawn {_ _ _ _ _} _.
Arguments ST_step_no_spawn {_ _ _ _ _} _.
Arguments fill_val {_ _} _.

Definition STLCmuST_step (p1 p2 : state * expr) : Prop :=
  match (p1 , p2) with
  | ((σ1, e1), (σ2, e2)) => @prim_step STLCmuST_ectx_lang e1 σ1 [] e2 σ2 []
  end.

Lemma head_step_no_forks e σ κ e' σ' efs : head_step e σ κ e' σ' efs → efs = [].
Proof. intros H. by inversion H. Qed.

Lemma prim_step_no_forks (e : expr) σ κ e' σ' efs : @prim_step STLCmuST_ectx_lang e σ κ e' σ' efs → efs = [].
Proof. intros H. inversion H. by eapply head_step_no_forks. Qed.

Lemma head_step_no_obs e σ κ e' σ' efs : head_step e σ κ e' σ' efs → κ = [].
Proof. intros H. by inversion H. Qed.

Lemma prim_step_no_obs (e : expr) σ κ e' σ' efs : @prim_step STLCmuST_ectx_lang e σ κ e' σ' efs → κ = [].
Proof. intros H. inversion H. by eapply head_step_no_obs. Qed.

Lemma prim_to_STLCmuST_step σ1 e1 σ2 e2 κ efs : @prim_step STLCmuST_ectx_lang e1 σ1 κ e2 σ2 efs → STLCmuST_step (σ1, e1) (σ2, e2).
Proof.
  intros Hprim.
  assert (efs = []) as ->. by eapply prim_step_no_forks.
  assert (κ = []) as ->. by eapply prim_step_no_obs.
  apply Hprim.
Qed.

Lemma prim_STLCmuST σ1 e1 σ2 e2 : @prim_step STLCmuST_ectx_lang e1 σ1 [] e2 σ2 [] <-> STLCmuST_step (σ1, e1) (σ2, e2).
Proof.
  split. apply prim_to_STLCmuST_step. auto.
Qed.

Canonical Structure valO := valO STLCmuST_lang.
Canonical Structure exprO := exprO STLCmuST_lang.

Lemma fill_STLCmuST_step_rtc (K : list ectx_item) e1 σ1 e2 σ2
  (H : rtc STLCmuST_step (σ1, e1) (σ2, e2)) :
  rtc STLCmuST_step (σ1, fill K e1) (σ2, fill K e2).
Proof.
  change (?σ, fill K ?e) with ((fun p => (p.1, fill K p.2)) (σ, e)).
  eapply rtc_congruence; eauto.
  intros p p' Hs. apply fill_step. by destruct p, p'.
Qed.

Definition STLCmuST_halts (e : STLCmuST.lang.expr) : Prop :=
  ∃ (v : STLCmuST.lang.val) (σ : STLCmuST.lang.state), rtc STLCmuST_step (∅, e) (σ, STLCmuST.lang.of_val v).

(* Lemma step_runst_noval e σ1 κ e2 σ2 efs: *)
(*   to_eff_val e = None -> *)
(*   @language.prim_step ST_lang (RunST e) σ1 κ e2 σ2 efs -> *)
(*   reducible (e: eff_expr) σ1 -> *)
(*   ∃ e', e2 = RunST e' ∧ @language.prim_step eff_lang e σ1 κ e' σ2 efs. *)
(* Proof. *)
(*   intros enotval ps reduc. inversion ps; subst. *)
(*   revert e1' H e2' H1 ps. *)
(*   inversion reduc as [efs' [x H]]. destruct H as [σ' [efse Heffstep]]. *)
(*   have eval := eff_head_step_val _ Heffstep. *)
(*   destruct K; simpl in *; subst; intros; subst. *)
(*   - inversion H1; subst. *)
(*     + exists e'. split; auto. *)
(*     + simpl in *. rewrite H0 in enotval. discriminate. *)
(*   - destruct e0. inversion H. elim H2. discriminate_list K. *)
(*     have fill_val:= fill_val eval. *)
(*     have hhh := val_stuck H1. rewrite hhh /is_Some in fill_val. *)
(*     by destruct fill_val. *)
(* Qed. *)

(* Arguments step_runst_noval {_ _ _ _ _} _ _ _. *)

(* Lemma alloc_fresh e v σ κ : *)
(* 	let l := fresh (dom _ σ) in *)
(* 	to_val e = Some v → *)
(*         eff_head_step (Alloc e) σ κ (Return (Lit (LitLoc l))) (<[l:=v]>σ) []. *)
(* Proof. *)
(*   intros; apply: AllocES => //. *)
(*     by apply (not_elem_of_dom (D:=gset _)), is_fresh. *)
(* Qed. *)