(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                                                                                *)
(************************************************************************************)

Set Implicit Arguments.

Require Import Relations List Arith.

Require Import ListFacts Mem OrderedSet.

(** * Permutation over lists, and finite multisets. *)

Inductive _permut (A B : Type) (R : A -> B -> Prop) : (list A -> list B -> Prop) :=
  | Pnil : _permut R nil nil
  | Pcons : forall a b l l1 l2, R a b -> _permut R l (l1 ++ l2) ->
                   _permut R (a :: l) (l1 ++ b :: l2).

(** * Generalization of Pcons, the second constructor of _permut *)
Lemma _permut_strong :
  forall (A B : Type) (R : A -> B -> Prop) a1 a2 l1 k1 l2 k2,
    R a1 a2 -> _permut R (l1 ++ k1) (l2 ++ k2) ->
    _permut R (l1 ++ a1 :: k1) (l2 ++ a2 :: k2).
Proof.
intros A B R a1 a2; fix h 1.
intro l1; case l1; clear l1; [ | intros u1 l1]; intros k1 l2 k2 a1_R_a2 P.
- apply (@Pcons _ _ R a1 a2 k1 l2 k2); trivial.
- inversion P as [ | b1 b2 l k k' b1_R_b2 Q H17 H18]; clear P; subst.
  destruct (split_list _ _ _ _ H18) as [l [[H1 H2] | [H1 H2]]]; clear H18.
  + subst l2.
    revert H2; case l; clear l.
    * intro H2; simpl in H2; subst k2; rewrite <- ass_app; simpl.
      assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) (k ++ a2 :: nil) k' b1_R_b2).
      rewrite <- 2 ass_app in Q'; simpl in Q'.
      apply Q'.
      apply h; assumption.
    * intros _b2 l2 H2; simpl in H2.
      injection H2; clear H2; do 2 intro; subst _b2 k'; simpl; rewrite <- ass_app.
      assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) k (l2 ++ a2 :: k2) b1_R_b2).
      rewrite ass_app in Q'.
      apply Q'.
      apply (h _ _ _ _ a1_R_a2).
      rewrite <- ass_app; assumption.
  + subst k k2.
    assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) (l2 ++ a2 :: l) k' b1_R_b2).
      rewrite <- 2 ass_app in Q'; simpl in Q'.
      apply Q'.
      apply (h _ _ _ _ a1_R_a2).
      rewrite ass_app; assumption.
Qed.

(** * Inclusion of permutation relations *)
Lemma _permut_incl :
  forall (A B : Type) (R R' : A -> B -> Prop) l1 l2,
  (forall a b, R a b -> R' a b) -> _permut R l1 l2 -> _permut R' l1 l2.
Proof.
intros A B R R'.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l2 H P.
inversion P; apply Pnil.
inversion P as [ | a b k k1 k2 a_R_b Q]; subst.
apply Pcons.
apply (H _ _ a_R_b).
apply (h _ _ H Q).
Qed.

(** * Swapping the lists in _permut *)
Lemma _permut_rel_aux :
forall (A B : Type) (R : A -> B -> Prop) l1 l2,
  _permut R l1 l2 -> _permut (fun b a => R a b) l2 l1.
Proof.
intros A B R.
fix h 1.
intro l1; case l1; clear l1.
- intros l2 P.
  inversion P; subst.
  apply Pnil.
- intros a l1 l2 P.
  inversion P; clear P; subst.
  apply (_permut_strong (R := fun b a => R a b) b a l0 l3 nil l1 H1).
  simpl.
  apply h; assumption.
Qed.

Lemma _permut_rel :
forall (A B : Type) (R : A -> B -> Prop) l1 l2,
  _permut R l1 l2 <-> _permut (fun b a => R a b) l2 l1.
Proof.
intros A B R l1 l2; split; intro P.
- apply _permut_rel_aux; assumption.
- generalize (_permut_rel_aux P).
  apply _permut_incl.
  exact (fun _ _ h => h).
Qed.

(** * Various inversion lemmata *)
Lemma _permut_inv_right_strong :
  forall (A B : Type) (R : A -> B -> Prop) b l1 l2' l2'',
  _permut R l1 (l2' ++ b :: l2'') -> exists a, exists l1', exists l1'',
   (R a b /\ l1 = l1' ++ a :: l1'' /\ _permut R (l1' ++ l1'') (l2' ++ l2'')).
Proof.
intros A B R.
fix h 2.
intros b l1; case l1; clear l1; [ | intros a1 l1]; intros l2' l2'' P.
- revert P; case l2'; clear l2'; [intro P | intros a2' l2' P]; inversion P.
- inversion P as [ | a b' l' l1' k2 a_R_b' Q H K]; subst.
  destruct (split_list _ _ _ _ K) as [l [[H1 H2] | [H1 H2]]]; clear K.
  + destruct l as [ | _b' l].
    * simpl in H2; injection H2; clear H2; do 2 intro.
      rewrite <- app_nil_end in H1.
      subst l2' l2'' b'.
      exists a1; exists nil; exists l1; split; [ | split]; trivial.
    * simpl in H2; injection H2; clear H2; do 2 intro.
      subst l2' k2 _b'.
      rewrite ass_app in Q.
      destruct (h b _ _ _ Q) as [a [k1' [k1'' [a_R_b [H Q']]]]]; subst.
      exists a; exists (a1 :: k1'); exists k1''; split; [assumption | ].
      split; [rewrite app_comm_cons; apply refl_equal | ].
      rewrite <- ass_app; simpl; apply Pcons; [assumption | ].
      rewrite ass_app; assumption.
  + destruct l as [ | _b l].
    * simpl in H2; injection H2; clear H2; do 2 intro.
      rewrite <- app_nil_end in H1.
      subst l2' l2'' b'.
      exists a1; exists nil; exists l1; split; [ | split]; trivial.
    * simpl in H2; injection H2; clear H2; do 2 intro.
      subst l1' l2'' _b.
      rewrite <- ass_app in Q; simpl in Q.
      destruct (h b _ _ _ Q) as [a [k1' [k1'' [a_R_b [H Q']]]]]; subst.
      exists a; exists (a1 :: k1'); exists k1''; split; [assumption | ].
      split; [rewrite app_comm_cons; apply refl_equal | ].
      rewrite ass_app; simpl; apply Pcons; [assumption | ].
      rewrite <- ass_app; assumption.
Qed.

Lemma _permut_inv_right :
  forall (A B : Type) (R : A -> B -> Prop) b l1 l2, _permut R l1 (b :: l2) ->
  exists a, exists l1', exists l1'', (R a b /\ l1 = l1' ++ a :: l1'' /\ _permut R (l1' ++ l1'') l2).
Proof.
intros A B R b l1 l2 P.
apply (_permut_inv_right_strong (R := R) b (l1 := l1) nil l2 P).
Qed.

Lemma _permut_inv_left_strong :
  forall (A B : Type) (R : A -> B -> Prop) a l1' l1'' l2,
  _permut R (l1' ++ a :: l1'') l2 -> exists b, exists l2', exists l2'',
   (R a b /\ l2 = l2' ++ b :: l2'' /\ _permut R (l1' ++ l1'') (l2' ++ l2'')).
Proof.
intros A B R a l1' l1'' l2 P.
rewrite _permut_rel in P.
destruct (_permut_inv_right_strong _ _ _ P) as [b [l2' [l2'' [H1 [H2 H3]]]]].
exists b; exists l2'; exists l2''.
split; [assumption | ].
split; [assumption | ].
rewrite _permut_rel; assumption.
Qed.

(** * Compatibility of _permut *)
(** Permutation is compatible with length and size. *)
Lemma _permut_length :
  forall (A : Type) (R : relation A) l1 l2, _permut R l1 l2 -> length l1 = length l2.
Proof.
intros A R; fix h 1.
intro l; case l; clear l; [ | intros a l]; intros l' P.
inversion P; apply refl_equal.
inversion P as [ | _a b _l l1 l2 H1 H2]; clear P; subst _a _l l'.
rewrite app_length; simpl; rewrite plus_comm; simpl; rewrite plus_comm.
rewrite <- app_length; rewrite (h l (l1 ++ l2)); trivial.
Qed.

Lemma _permut_size :
  forall (A B : Type) (R : A -> B -> Prop) size size' l1 l2,
  (forall a a', In a l1 -> In a' l2 -> R a a' -> size a = size' a') ->
  _permut R l1 l2 -> list_size size l1 = list_size size' l2.
Proof.
intros A B R size size'.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l2 E P.
- (* 1/2 *)
  inversion P; apply refl_equal.
- (* 1/1 *)
  inversion P as [ | a b l1' l2' l2'' a_R_b P']; subst.
  rewrite list_size_app; simpl.
  rewrite (E a1 b); trivial.
  + rewrite (h _ (l2' ++ l2'')); [ | | apply P'].
    * rewrite list_size_app; simpl.
      rewrite plus_comm.
      rewrite <- plus_assoc.
      apply (f_equal (fun n => list_size size' l2' + n)).
      apply plus_comm.
    * intros a a' a_in_la a_in_l'; apply E; trivial.
      right; trivial.
      apply in_app; trivial.
  + left; trivial.
  + apply in_or_app; right; left; trivial.
Qed.

Lemma _permut_map :
  forall (A B A' B': Type) (R : A -> B -> Prop) (R' : A' -> B' -> Prop) f1 f2 l1 l2,
    (forall a b, In a l1 -> In b l2 -> R a b -> R' (f1 a) (f2 b)) ->
    _permut R l1 l2 -> _permut R' (map f1 l1) (map f2 l2).
Proof.
intros A B A' B' R R' f1 f2.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l2 Compat P.
(* 1/1 *)
inversion P; apply Pnil.
(* 1/2 *)
inversion P as [ | a' b l1' l2' l2'' a_R_b P' H]; clear P; subst.
rewrite map_app; simpl; apply Pcons.
apply Compat; trivial.
left; trivial.
apply in_or_app; right; left; trivial.
rewrite <- map_app; apply h; trivial.
intros a b' a_in_l1 b'_in_l2; apply Compat.
right; trivial.
apply in_app; trivial.
Qed.

Lemma _permut_app :
  forall (A B : Type) (R : A -> B -> Prop) l1 l1' l2 l2',
   _permut R l1 l2 -> _permut R l1' l2' -> _permut R (l1 ++ l1') (l2 ++ l2').
Proof.
intros A B R.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l1' l2 l2' P P'.
inversion P; subst; trivial.
inversion P as [ | a b l1'' l2'' l2''' a_R_b Q]; clear P; subst.
simpl; rewrite <- ass_app; simpl; apply Pcons; trivial.
rewrite ass_app; apply h; trivial.
Qed.

Lemma _permut_swapp :
  forall (A B : Type) (R : A -> B -> Prop) l1 l1' l2 l2',
   _permut R l1 l2 -> _permut R l1' l2' -> _permut R (l1 ++ l1') (l2' ++ l2).
Proof.
intros A B R.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l1' l2 l2' P P'.
inversion P; subst; rewrite <- app_nil_end; trivial.
inversion P as [ | a b l1'' l2'' l2''' a_R_b Q]; clear P; subst.
simpl; rewrite ass_app; apply Pcons; trivial.
rewrite <- ass_app; apply h; trivial.
Qed.

Lemma in_permut_in :
   forall (A : Type) l1 l2, _permut (@eq A) l1 l2 -> (forall a, In a l1 <-> In a l2).
Proof.
assert (H : forall (A : Type) l1 l2, _permut (@eq A) l1 l2 -> forall a, In a l2 -> In a l1).
intros A l1 l2 P a a_in_l2;
destruct (In_split _ _ a_in_l2) as [l2' [l2'' H]]; subst.
destruct (_permut_inv_right_strong (R := @eq A) _ _ _ P)  as [a' [l1' [l1'' [a_eq_a' [H _]]]]]; subst.
apply in_or_app; right; left; trivial.
intros A l1 l2 P a; split; apply H; trivial.
rewrite _permut_rel.
revert P; apply _permut_incl.
exact (fun _ _ h => sym_eq h).
Qed.

(** * Permutation is an equivalence, whenever the underlying relation is *)
Lemma _permut_refl :
   forall (A : Type) (R : A -> A -> Prop) l,  (forall a, In a l -> R a a) -> _permut R l l.
Proof.
intros A R.
fix h 1.
intro l; case l; clear l; [ | intros a l]; intro R_refl.
(* 1/2 *)
apply Pnil.
(* 1/1 *)
apply (@Pcons _ _ R a a l nil l).
apply R_refl; left; apply refl_equal.
simpl; apply (h l (fun x h => R_refl x (or_intror _ h))).
Qed.

Lemma _permut_sym :
  forall (A : Type) (R : A -> A -> Prop) l1 l2,
    (forall a b, In a l1 -> In b l2 -> R a b -> R b a) ->
    _permut R l1 l2 -> _permut R l2 l1.
Proof.
intros A R; fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l2 R_sym P.
(* 1/2 *)
inversion P; apply Pnil.
(* 1/1 *)
inversion P as [ | a b l1' l2' l2'' a_R_b Q]; subst.
apply (_permut_strong (R := R) b a1 l2' l2'' (@nil A) l1).
apply R_sym; trivial; [left | apply in_or_app; right; left]; trivial.
simpl; apply h; trivial.
intros; apply R_sym; trivial; [right | apply in_app]; trivial.
Qed.

Lemma _permut_trans :
  forall (A : Type) (R : A -> A -> Prop) l1 l2 l3,
   (forall a b c, In a l1 -> In b l2 -> In c l3 -> R a b -> R b c -> R a c) ->
   _permut R l1 l2 -> _permut R l2 l3 -> _permut R l1 l3.
Proof.
intros A R; fix h 2.
intros l1 l2; case l2; clear l2; [ | intros a2 l2]; intros l3 R_trans P1 P2.
(* 1/2 *)
inversion P2; exact P1.
(* 1/1 *)
destruct (_permut_inv_right P1) as [a1 [l1' [l1'' [a1_R_a2 [H Q1]]]]]; clear P1; subst l1.
inversion P2 as [ | a2' a3 l2' l3' l3'' a2_R_a3 Q2]; subst.
apply _permut_strong.
apply R_trans with a2; trivial.
apply in_or_app; right; left; apply refl_equal.
left; apply refl_equal.
apply in_or_app; right; left; apply refl_equal.
apply h with l2; trivial.
intros a b c; intros; apply R_trans with b; trivial.
apply in_app; trivial.
right; trivial.
apply in_app; trivial.
Qed.

Lemma _permut_rev :
   forall (A : Type) (R : A -> A -> Prop) l,  (forall a, In a l -> R a a) -> _permut R l (rev l).
Proof.
intros A R.
fix h 1.
intro l; case l; clear l; [ | intros a l]; intro R_refl.
- (* 1/2 *)
 apply Pnil.
- (* 1/1 *)
  apply (@Pcons _ _ R a a l (rev l) nil).
  + apply R_refl; left; apply refl_equal.
  + rewrite <- app_nil_end; apply h.
    intros; apply R_refl; right; assumption.
Qed.

(** * Removing elements in permutated lists *)

Lemma _permut_cons_inside :
  forall (A B : Type) (R : A -> B -> Prop) a b l l1 l2,
  (forall a1 b1 a2 b2, In a1 (a :: l) -> In b1 (l1 ++ b :: l2) ->
                   In a2 (a :: l) -> In b2 (l1 ++ b :: l2) ->
                   R a1 b1 -> R a2 b1 -> R a2 b2 -> R a1 b2) ->
  R a b -> _permut R (a :: l) (l1 ++ b :: l2) -> _permut R l (l1 ++ l2).
Proof.
intros A B R a b l l1 l2 trans_R a_R_b P;
destruct (_permut_inv_right_strong (R := R) _ _ _ P) as [a' [l1' [l1'' [a'_R_b [H P']]]]].
destruct l1' as [ | a1' l1']; injection H; clear H; intros; subst; trivial.
inversion P' as [ | a'' b' l' k1' k2' a''_R_b' P'' H17 H18]; subst.
apply _permut_strong; trivial.
apply trans_R with b a1'; trivial.
right; apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
left; trivial.
apply in_app; rewrite <- H18; apply in_or_app; right; left; trivial.
Qed.

Lemma _permut_add_inside :
   forall (A B : Type) (R : A -> B -> Prop) a b l1 l1' l2 l2',
  (forall a1 b1 a2 b2, In a1 (l1 ++ a :: l1') -> In b1 (l2 ++ b :: l2') ->
                   In a2 (l1 ++ a :: l1') -> In b2 (l2 ++ b :: l2') ->
                   R a1 b1 -> R a2 b1 -> R a2 b2 -> R a1 b2) ->
  R a b -> _permut R (l1 ++ a :: l1') (l2 ++ b :: l2') -> _permut R (l1 ++ l1') (l2 ++ l2').
Proof.
intros A B R a b l1 l1' l2 l2' trans_R a_R_b P.
destruct (_permut_inv_left_strong (R := R) _ _ _ P) as [b' [k2 [k2' [a_R_b' [H P']]]]].
destruct (split_list _ _ _ _ H) as [l [[H1 H2] | [H1 H2]]]; clear H.
- destruct l as [ | b1 l].
  + simpl in H1; injection H2; clear H2; do 2 intro.
    subst b' k2'.
    rewrite <- app_nil_end in H1; subst k2.
    assumption.
  + simpl in H2; injection H2; clear H2; do 2 intro.
    subst l2' k2 b1.
    rewrite <- ass_app in P'; simpl in P'.
    destruct (_permut_inv_right_strong (R := R) _ _ _ P') as [a' [k1' [k1'' [a'_R_b' [H P'']]]]].
    rewrite H, ass_app.
    apply _permut_strong.
    * {
        apply trans_R with b a; trivial.
        - apply in_app; rewrite H.
          apply in_or_app; right; left; apply refl_equal.
        - apply in_or_app; right; left; apply refl_equal.
        - apply in_or_app; right; left; apply refl_equal.
        - apply in_or_app; do 2 right.
          apply in_or_app; right; left; apply refl_equal.
      }
    * rewrite <- ass_app; assumption.
- destruct l as [ | b1 l].
  + simpl in H1; injection H2; clear H2; do 2 intro.
    subst b' k2'.
    rewrite <- app_nil_end in H1; subst k2.
    assumption.
  + simpl in H2; injection H2; clear H2; do 2 intro.
    subst l2 k2' b1.
    rewrite ass_app in P'.
    destruct (_permut_inv_right_strong (R := R) _ _ _ P') as [a' [k1' [k1'' [a'_R_b' [H P'']]]]].
    rewrite H, <- ass_app; simpl.
    apply _permut_strong.
    * {
        apply trans_R with b a; trivial.
        - apply in_app; rewrite H.
          apply in_or_app; right; left; apply refl_equal.
        - apply in_or_app; right; left; apply refl_equal.
        - apply in_or_app; right; left; apply refl_equal.
        - apply in_or_app; left.
          apply in_or_app; right; left; apply refl_equal.
      }
    * rewrite ass_app; assumption.
Qed.

Lemma _permut_app1 :
  forall (A : Type) (R : relation A), equivalence _ R ->
  forall l l1 l2, _permut R l1 l2 <-> _permut R (l ++ l1) (l ++ l2).
Proof.
intros A R E l l1 l2; split; intro P.
(* -> case *)
induction l as [ | u l]; trivial.
simpl; apply (@Pcons _ _ R u u (l ++ l1) (@nil A) (l ++ l2)); trivial.
apply (equiv_refl _ _ E).
(* <- case *)
induction l as [ | u l]; trivial.
apply IHl.
apply (@_permut_cons_inside A A R u u (l ++ l1) (@nil _) (l ++ l2)); trivial.
intros a1 b1 a2 b2 _ _ _ _ a1_R_b1 a2_R_b1 a2_R_b2.
apply (equiv_trans _ _ E) with b1; trivial.
apply (equiv_trans _ _ E) with a2; trivial.
apply (equiv_sym _ _ E); trivial.
apply (equiv_refl _ _ E).
Qed.

Lemma _permut_app2 :
  forall (A : Type) (R : relation A), equivalence _ R ->
  forall l l1 l2, _permut R l1 l2 <-> _permut R (l1 ++ l) (l2 ++ l).
Proof.
intros A R E l l1 l2; split; intro P.
(* -> case *)
induction l as [ | u l].
do 2 rewrite <- app_nil_end; trivial.
apply _permut_strong; trivial.
apply (equiv_refl _ _ E).

(* <- case *)
induction l as [ | u l].
do 2 rewrite <- app_nil_end in P; trivial.
apply IHl.
apply (@_permut_add_inside A A R u u); trivial.
intros a1 b1 a2 b2 _ _ _ _ a1_R_b1 a2_R_b1 a2_R_b2;
apply (equiv_trans _ _ E) with b1; trivial.
apply (equiv_trans _ _ E) with a2; trivial.
apply (equiv_sym _ _ E); trivial.
apply (equiv_refl _ _ E).
Qed.

(** * A function to decide wether 2 lists are in relation by _permut *)

Definition _remove_common_bool := fun (A : Type) (equiv_bool : A -> A -> bool) =>
fix _remove_common (l l' : list A) : ((list A) * (list A)) :=
match l with
| nil => (l, l')
| h :: tl =>
  match remove_bool equiv_bool h l' with
  | Some l'' => _remove_common tl l''
  | None => match _remove_common tl l' with (k, k') => (h :: k, k')  end
  end
end.

Lemma _remove_common_bool_is_sound :
  forall (A : Type) equiv_bool (l1 l2 l1' l2': list A),
    _remove_common_bool equiv_bool l1 l2 =  (l1',l2') ->
              {ll : list (A * A) | (forall t1 t2, In (t1,t2) ll -> equiv_bool t1 t2 = true) /\
                _permut (@eq A) l1 (l1' ++ (map (fun st => fst st) ll)) /\
                _permut (@eq A) l2 (l2' ++ (map (fun st => snd st) ll)) /\
                (forall t1 t2, In t1 l1' -> In t2 l2' -> equiv_bool t1 t2 = false)}.
Proof.
intros A equiv_bool.
fix h 1.
intros l1 l2 l1' l2'; case l1; clear l1; [ | intros a1 l1]; simpl.
- intro H; injection H; clear H; intros; subst.
  exists nil; split; [intros; contradiction | ].
  split; [apply Pnil | ].
  split.
  + simpl; rewrite <- app_nil_end; apply _permut_refl; intros; apply refl_equal.
  + intros; contradiction.
- case_eq (remove_bool equiv_bool a1 l2).
  + intros k2 H2 H.
    assert (K2 := remove_bool_some_is_sound _ _ _ H2).
    case K2; clear K2.
    intros [[a1' k2'] k2''] [K1 [K2 K3]].
    assert (IH := h _ _ _ _ H).
    case IH; clear IH.
    intros ll [Hll [J1 [J2 J3]]].
    exists ((a1, a1') :: ll); split; [ | split; [ | split]].
    * intros t1 t2 Ht; simpl in Ht.
      destruct Ht as [Ht | Ht]; [injection Ht; clear Ht; intros; subst; assumption | ].
      apply Hll; assumption.
    * rewrite map_unfold; simpl fst.
      apply Pcons; [apply refl_equal | assumption].
    * rewrite map_unfold; simpl snd.
      rewrite K2; apply _permut_strong; [apply refl_equal | ].
      rewrite <- K3; assumption.
    * assumption.
  + intros H2 H.
    assert (K2 := remove_bool_none_is_sound _ _ _ H2).
    case_eq (_remove_common_bool equiv_bool l1 l2).
    intros k k' K; rewrite K in H.
    injection H; clear H; do 2 intro; subst l1' l2'.
    assert (IH := h _ _ _ _ K).
    case IH; clear IH.
    intros ll [Hll [J1 [J2 J3]]].
    exists ll; split; [ | split; [ | split]].
    * assumption.
    * simpl.
      apply (@Pcons _ _ _ a1 a1 l1 nil (k ++ map (fun st : A * A => fst st) ll) (refl_equal _)).
      apply J1.
    * assumption.
    * intros t1 t2 Ht1 Ht2; simpl in Ht1.
      destruct Ht1 as [Ht1 | Ht1]; [ | apply J3; assumption].
      subst t1.
      apply K2.
      rewrite (in_permut_in J2).
      apply in_or_app; left; assumption.
Qed.

Definition _permut_bool := fun (A : Type) (equiv_bool : A -> A -> bool) =>
fix _permut_bool (l1 l2 : list A) : bool :=
match l1 with
| nil =>
  match l2 with
  | nil => true
  | _ => false
  end
| t1 :: k1 =>
    match remove_bool equiv_bool t1 l2 with
   | Some k2 => _permut_bool k1 k2
   | None => false
   end
end.

Lemma _permut_bool_true_is_sound :
  forall (A : Type) (equiv_bool : A -> A -> bool) (l1 l2 : list A),
    _permut_bool equiv_bool l1 l2 = true -> _permut (fun x y => equiv_bool x y = true) l1 l2.
Proof.
intros A equiv_bool.
fix h 1.
intro l1; case l1; clear l1.
- intros l2; case l2; clear l2.
  + intros _; simpl; apply Pnil.
  + intros a2 l2 P; discriminate P.
- intros a1 l1 l2.
  simpl.
  case_eq (remove_bool equiv_bool a1 l2).
  + intros k2 Hl2 P.
    case (remove_bool_some_is_sound _ _ _ Hl2).
    intros [[a' k] k'] [K1 [K2 K3]].
    subst l2 k2.
    apply Pcons; [assumption | ].
    apply (h l1 (k ++ k') P).
  + intros _ Abs; discriminate Abs.
Qed.

Lemma _permut_bool_is_sound :
  forall (A : Type) (equiv_bool : A -> A -> bool) (l1 l2 : list A),
    (forall a3 b1 a4 b2 : A,
       In a3 l1 -> In b1 l2 -> In a4 l1 -> In b2 l2 ->
       equiv_bool a3 b1 = true -> equiv_bool a4 b1 = true -> equiv_bool a4 b2 = true ->
       equiv_bool a3 b2 = true) ->
    match _permut_bool equiv_bool l1 l2 with
      | true => _permut (fun x y => equiv_bool x y = true) l1 l2
      | false => ~_permut (fun x y => equiv_bool x y = true) l1 l2
    end.
Proof.
intros A equiv_bool l1 l2 H.
case_eq (_permut_bool equiv_bool l1 l2); intro P.
- apply (_permut_bool_true_is_sound _ _ _ P).
- revert l1 l2 H P.
  fix h 1.
  + intro l1; case l1; clear l1.
    * {
        intros l2; case l2; clear l2.
        - intros _ Abs; discriminate Abs.
        - intros a2 l2 _ _ P; inversion P.
      }
    * intros a1 l1 l2 H P Q.
      simpl in P.
      {
        case_eq (remove_bool equiv_bool a1 l2).
        - intros k2 H2; rewrite H2 in P.
          case (remove_bool_some_is_sound _ _ _ H2); clear H2.
          intros [[a1' k2'] k2''] [K1 [K2 K3]].
          subst l2 k2.
          assert (H' : forall a3 b1 a4 b2 : A,
                     In a3 l1 ->
                     In b1 (k2' ++ k2'') ->
                     In a4 l1 ->
                     In b2 (k2' ++ k2'') ->
                     equiv_bool a3 b1 = true ->
                     equiv_bool a4 b1 = true ->
                     equiv_bool a4 b2 = true -> equiv_bool a3 b2 = true).
          {
            do 8 intro; apply H.
            - right; assumption.
            - apply in_app; assumption.
            - right; assumption.
            - apply in_app; assumption.
          }
          apply (h _ _ H' P).
          apply _permut_cons_inside with a1 a1'; trivial.
        - intro H2.
          inversion Q; clear Q; subst.
          assert (Aux : In b (l0 ++ b :: l3)).
          {
            apply in_or_app; right; left; apply refl_equal.
          }
          assert (Abs := remove_bool_none_is_sound _ _ _ H2 b Aux).
          rewrite H3 in Abs; discriminate Abs.
      }
Qed.

Lemma permut_filter :
  forall (A : Type) (R : relation A) (f : A -> bool) (l1 l2 : list A),
    (forall x1 x2, In x1 l1 -> R x1 x2 -> f x1 = f x2) ->
    _permut R l1 l2 -> _permut R (filter f l1) (filter f l2).
Proof.
intros A R f l1; induction l1 as [ | x1 l1]; intros l2 H P.
- inversion P; apply Pnil.
- inversion P; subst; rewrite filter_app; simpl.
  assert (Hx1 := H x1 b (or_introl _ (refl_equal _)) H2); rewrite <- Hx1.
  destruct (f x1).
  + apply Pcons; [assumption | ].
    rewrite <- filter_app.
    apply IHl1.
    * intros y1 y2 Hy; apply H; right; assumption.
    * assumption.
  + rewrite <- filter_app.
    apply IHl1.
    * intros y1 y2 Hy; apply H; right; assumption.
    * assumption.
Qed.

Section Sec.
Hypothesis A : Type.
Hypothesis EDS : Oeset.Rcd A.

Notation permut := (_permut (fun x y => Oeset.compare EDS x y = Eq)).

(** ** Permutation is a equivalence relation.
      Reflexivity. *)
  Theorem permut_refl :  forall (l : list A), permut l l.
  Proof.
  intro l; apply _permut_refl.
  intros a _; apply Oeset.compare_eq_refl.
  Qed.

Lemma permut_refl_alt :
  forall l1 l2, comparelA (Oeset.compare EDS) l1 l2 = Eq -> permut l1 l2.
Proof.
intro l1; induction l1 as [ | a1 l1]; intros [ | a2 l2] H; try discriminate H.
- apply Pnil.
- simpl in H.
  case_eq (Oeset.compare EDS a1 a2); intro Ha; rewrite Ha in H; try discriminate H.
  apply (Pcons (R := fun x y => Oeset.compare EDS x y = Eq) a1 a2 nil l2 Ha (IHl1 _ H)).
Qed.

Lemma permut_refl_alt2 :
  forall l1 l2, l1 = l2 -> permut l1 l2.
  Proof.
    intros l1 l2 H; subst l2; apply permut_refl.
  Qed.

  (** Symetry. *)
  Theorem permut_sym : forall l1 l2 : list A, permut l1 l2 -> permut l2 l1.
  Proof.
  intros l1 l2 P; apply _permut_sym; trivial.
  intros a b _ _ H.
  rewrite Oeset.compare_lt_gt, H; apply refl_equal.
  Qed.

  (** Transitivity. *)
  Theorem permut_trans :
    forall l1 l2 l3 : list A, permut l1 l2 -> permut l2 l3 -> permut l1 l3.
  Proof.
  intros l1 l2 l3 P1 P2; apply _permut_trans with l2; trivial.
  intros a b c _ _ _; apply Oeset.compare_eq_trans.
  Qed.

(** ** Compatibility Properties.
      Permutation is compatible with mem. *)
Lemma mem_permut_mem :
  forall l1 l2 e, permut l1 l2 -> Oeset.mem_bool EDS e l1 = Oeset.mem_bool EDS e l2.
Proof.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l2 e P.
- inversion P; subst; apply refl_equal.
- inversion P; clear P; subst.
  rewrite Oeset.mem_bool_unfold, Oeset.mem_bool_app.
  rewrite (Oeset.mem_bool_unfold EDS e (b :: l3)).
  case_eq (Oeset.compare EDS e a1); intro He.
  + rewrite (Oeset.compare_eq_trans _ _ _ _ He H1), Bool.orb_true_r.
    apply refl_equal.
  + rewrite Bool.orb_false_l.
    rewrite (h _ _ _ H3), Oeset.mem_bool_app.
    rewrite (Oeset.compare_lt_eq_trans EDS _ _ _ He H1).
    apply refl_equal.
  + rewrite Bool.orb_false_l.
    rewrite (h _ _ _ H3), Oeset.mem_bool_app.
    rewrite Oeset.compare_lt_gt.
    rewrite Oeset.compare_lt_gt, CompOpp_iff in H1, He.
    rewrite (Oeset.compare_eq_lt_trans EDS _ _ _ H1 He).
    apply refl_equal.
Qed.

Lemma mem_permut_mem_strong :
  forall l1 l2 e, _permut (@eq A) l1 l2 -> Oeset.mem_bool EDS e l1 = Oeset.mem_bool EDS e l2.
Proof.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l2 e P.
- inversion P; subst; apply refl_equal.
- inversion P; clear P; subst.
  rewrite Oeset.mem_bool_unfold, Oeset.mem_bool_app.
  rewrite (Oeset.mem_bool_unfold EDS e (b :: l3)).
  case_eq (Oeset.compare EDS e b); intro He.
  + rewrite Bool.orb_true_r; apply refl_equal.
  + rewrite 2 Bool.orb_false_l.
    rewrite (h _ _ _ H3), Oeset.mem_bool_app.
    apply refl_equal.
  + rewrite 2 Bool.orb_false_l.
    rewrite (h _ _ _ H3), Oeset.mem_bool_app.
    apply refl_equal.
Qed.

Lemma mem_morph :
  forall x y, Oeset.compare EDS x y = Eq ->
  forall l1 l2, permut l1 l2 -> (Oeset.mem_bool EDS x l1 = Oeset.mem_bool EDS y l2).
Proof.
  intros e1 e2 e1_eq_e2 l1 l2 P.
  rewrite (mem_permut_mem e1 P).
  clear l1 P.
  induction l2 as [ | a l]; simpl; [trivial | ].
  unfold Oeset.eq_bool; rewrite IHl; apply f_equal2; [ | apply refl_equal].
  case_eq (Oeset.compare EDS e2 a); intro H.
  - rewrite (Oeset.compare_eq_trans _ _ _ _ e1_eq_e2 H).
    apply refl_equal.
  - rewrite (Oeset.compare_eq_lt_trans _ _ _ _ e1_eq_e2 H).
    apply refl_equal.
  - rewrite Oeset.compare_lt_gt, CompOpp_iff in e1_eq_e2, H.
    rewrite Oeset.compare_lt_gt.
    rewrite (Oeset.compare_lt_eq_trans _ _ _ _ H e1_eq_e2).
    apply refl_equal.
Qed.

 (** Permutation is compatible with addition and removal of common elements *)

Lemma permut_cons :
  forall e1 e2 l1 l2,
    Oeset.compare EDS e1 e2 = Eq ->
    (permut l1 l2 <-> permut (e1 :: l1) (e2 :: l2)).
Proof.
intros e1 e2 l1 l2 e1_eq_e2; split; intro P.
- apply (@Pcons _ _ _ e1 e2 l1 (@nil A) l2); trivial.
- replace l2 with (nil ++ l2); trivial;
    apply _permut_cons_inside with e1 e2; trivial.
  intros a1 b1 a2 b2 _ _ _ _ a1_eq_b1 a2_eq_b1 a2_eq_b2.
    apply Oeset.compare_eq_trans with a2; trivial.
    apply Oeset.compare_eq_trans with b1; trivial.
    rewrite Oeset.compare_lt_gt, a2_eq_b1; apply refl_equal.
Qed.

Lemma cons_permut_mem :
  forall l1 l2 e1 e2,
    Oeset.compare EDS e1 e2 = Eq -> permut (e1 :: l1) l2 ->
    Oeset.mem_bool EDS e2 l2 = true.
Proof.
  intros l1 l2 e1 e2 e1_eq_e2 P.
  rewrite <- (mem_morph _ _ e1_eq_e2 P), Oeset.mem_bool_unfold, Oeset.compare_eq_refl.
  apply refl_equal.
Qed.

Lemma permut_add_inside :
    forall e1 e2 l1 l2 l3 l4, Oeset.compare EDS e1 e2 = Eq ->
      (permut (l1 ++ l2) (l3 ++ l4) <-> permut (l1 ++ e1 :: l2) (l3 ++ e2 :: l4)).
Proof.
  intros e1 e2 l1 l2 l3 l4 e1_eq_e2; split; intro P.
  apply _permut_strong; trivial.
  apply _permut_add_inside with e1 e2; trivial.
  intros a1 b1 a2 b2 _ _ _ _ a1_eq_b1 a2_eq_b1 a2_eq_b2;
  apply Oeset.compare_eq_trans with a2; trivial.
  apply Oeset.compare_eq_trans with b1; trivial.
  rewrite Oeset.compare_lt_gt, a2_eq_b1; apply refl_equal.
Qed.

Lemma permut_cons_inside :
  forall e1 e2 l l1 l2, Oeset.compare EDS e1 e2 = Eq ->
    (permut l (l1 ++ l2) <-> permut (e1 :: l) (l1 ++ e2 :: l2)).
Proof.
  intros e1 e2 l l1 l2 e1_eq_e2; apply (permut_add_inside _ _ nil l l1 l2 e1_eq_e2).
Qed.

(** Permutation is compatible with append. *)
Lemma permut_app1 :
  forall l l1 l2, permut l1 l2 <-> permut (l ++ l1) (l ++ l2).
Proof.
intros l l1 l2; apply _permut_app1.
split.
- intro; apply Oeset.compare_eq_refl.
- do 3 intro; apply Oeset.compare_eq_trans.
- do 2 intro; intro H; rewrite Oeset.compare_lt_gt, H.
  apply refl_equal.
Qed.

 Lemma permut_app2 :
  forall l l1 l2, permut l1 l2 <-> permut (l1 ++ l) (l2 ++ l).
Proof.
intros l l1 l2; apply _permut_app2.
split.
- intro; apply Oeset.compare_eq_refl.
- do 3 intro; apply Oeset.compare_eq_trans.
- do 2 intro; intro H; rewrite Oeset.compare_lt_gt, H.
  apply refl_equal.
Qed.

(** ** Link with AC syntactic decomposition.*)
Lemma ac_syntactic_aux :
 forall (l1 l2 l3 l4 : list A),
 permut (l1 ++ l2) (l3 ++ l4) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut l1 (u1 ++ u2) /\
 permut l2 (u3 ++ u4) /\
 permut l3 (u1 ++ u3) /\
 permut l4 (u2 ++ u4)).
Proof.
fix h 1.
intro l1; case l1; clear l1; [ | intros a1 l1]; intros l2 l3 l4 P.
- exists (nil : list A); exists (nil : list A); exists l3; exists l4.
  split; [apply permut_refl | ].
  split; [assumption | split; apply permut_refl].
- simpl in P.
  inversion P; clear P; subst.
  destruct (split_list _ _ _ _ H1) as [l [[K1 K2] | [K1 K2]]]; clear H1.
  + destruct l as [ | _b l].
    * rewrite <- app_nil_end in K1; simpl in K2; subst l3 l4.
      destruct (h _ _ _ _ H3) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]].
      {
        exists u1; exists (b :: u2); exists u3; exists u4; repeat split.
        - apply Pcons; assumption.
        - assumption.
        - assumption.
        - assert (H := @Pcons _ _
                              (fun x y => Oeset.compare EDS x y = Eq) b b l5 nil (u2 ++ u4)
                              (Oeset.compare_eq_refl _ _) P4).
          simpl; simpl in H; apply H.
      }
    * simpl in K2; injection K2; clear K2.
      do 2 intro; subst l3 l5 _b.
      rewrite ass_app in H3.
      destruct (h _ _ _ _ H3) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]].
      {
        exists (b :: u1); exists u2; exists u3; exists u4; repeat split.
        - assert (H := @Pcons _ _
                              (fun x y => Oeset.compare EDS x y = Eq) a1 b l1 nil (u1 ++ u2)
                              H2 P1).
          simpl; simpl in H; apply H.
        - assumption.
        - simpl.
          assert (H := permut_add_inside b b l0 l nil (u1 ++ u3) (Oeset.compare_eq_refl _ _)).
          rewrite H in P3; apply P3.
        - assumption.
      }
  + subst l0 l4.
    rewrite <- ass_app in H3.
    destruct (h _ _ _ _ H3) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]].
    exists u1; exists (b :: u2); exists u3; exists u4; repeat split.
    * apply Pcons; assumption.
    * assumption.
    * assumption.
    * assert (H := permut_add_inside b b l l5 nil (u2 ++ u4) (Oeset.compare_eq_refl _ _)).
      rewrite H in P4; apply P4.
Qed.

Lemma ac_syntactic :
 forall (l1 l2 l3 l4 : list A),
 permut (l2 ++ l1) (l4 ++ l3) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut l1 (u1 ++ u2) /\
 permut l2 (u3 ++ u4) /\
 permut l3 (u1 ++ u3) /\
 permut l4 (u2 ++ u4)).
Proof.
intros l1 l2 l3 l4 P; apply ac_syntactic_aux.
apply permut_trans with (l2 ++ l1).
apply _permut_swapp; apply permut_refl.
apply permut_trans with (l4 ++ l3); trivial.
apply _permut_swapp; apply permut_refl.
Qed.

Lemma nb_occ_permut :
 forall l1 l2, (forall x, Oeset.nb_occ EDS x l1 = Oeset.nb_occ EDS x l2) -> permut l1 l2.
Proof.
intros l1; induction l1 as [ | a1 l1]; intros l2 Hl.
- destruct l2 as [ | a2 l2].
  + apply Pnil.
  + apply False_rec.
    assert (Ha2 := Hl a2); simpl in Ha2.
    rewrite Oeset.compare_eq_refl in Ha2.
    destruct (Oeset.nb_occ EDS a2 l2); discriminate Ha2.
- assert (Ha1 : Oeset.mem_bool EDS a1 l2 = true).
  {
    generalize (Oeset.not_mem_nb_occ EDS a1 l2).
    destruct (Oeset.mem_bool EDS a1 l2); [trivial | ].
    intro Abs; assert (Ha1 := Hl a1); simpl in Ha1.
    rewrite Oeset.compare_eq_refl, (Abs (refl_equal _)) in Ha1.
    destruct (Oeset.nb_occ EDS a1 l1); discriminate Ha1.
  }
  rewrite Oeset.mem_bool_true_iff in Ha1.
  destruct Ha1 as [b1 [Ha1 Hb1]].
  destruct (in_split _ _ Hb1) as [k1 [k2 K]]; subst l2.
  apply Pcons; [assumption | ].
  apply IHl1.
  intros x; generalize (Hl x).
  rewrite 2 Oeset.nb_occ_app, 2 (Oeset.nb_occ_unfold _ _ (_ :: _)).
  case_eq (Oeset.compare EDS x a1); intro Ka1.
  + rewrite (Oeset.compare_eq_trans _ _ _ _ Ka1 Ha1); intro H.
    apply (BinNat.Nplus_reg_l BinNat.N.one). fold BinNat.N.one in H. rewrite H, BinNat.N.add_comm, <- BinNat.N.add_assoc.
    apply f_equal; apply BinNat.N.add_comm.
  + rewrite (Oeset.compare_lt_eq_trans _ _ _ _ Ka1 Ha1); exact (fun h => h).
  + rewrite (Oeset.compare_gt_eq_trans _ _ _ _ Ka1 Ha1); exact (fun h => h).
Qed.

Lemma permut_nb_occ :
  forall x l1 l2, permut l1 l2 -> Oeset.nb_occ EDS x l1 = Oeset.nb_occ EDS x l2.
Proof.
intros x l1 l2 H.
rewrite 2 Oeset.nb_occ_list_size; apply f_equal.
apply (_permut_size (R := (fun x y => Oeset.compare EDS x y = Eq))); [ | apply H].
intros a1 a2 _ _ K.
case_eq (Oeset.compare EDS x a1); intro H1.
- rewrite (Oeset.compare_eq_trans _ _ _ _ H1 K); apply refl_equal.
- rewrite (Oeset.compare_lt_eq_trans _ _ _ _ H1 K); apply refl_equal.
- rewrite (Oeset.compare_gt_eq_trans _ _ _ _ H1 K); apply refl_equal.
Qed.

Definition permut_bool :=
  _permut_bool (fun x y =>
                  match Oeset.compare EDS x y with
                    | Eq => true
                    | _ => false
                  end).

Lemma permut_bool_is_sound :
  forall (l1 l2 : list A),
    match permut_bool l1 l2 with
      | true => permut l1 l2
      | false => ~permut l1 l2
    end.
Proof.
intros l1 l2.
unfold permut_bool.
generalize (_permut_bool_is_sound
              (fun x y => match Oeset.compare EDS x y with Eq => true | _ => false end)
              l1 l2).
case (_permut_bool
         (fun x y : A =>
          match Oeset.compare EDS x y with
          | Eq => true
          | Lt => false
          | Gt => false
          end) l1 l2).
- intro H.
  apply _permut_incl with (fun x y : A =>
         match Oeset.compare EDS x y with
         | Eq => true
         | Lt => false
         | Gt => false
         end = true).
  + intros a b K.
    rewrite compare_eq_true in K; apply K.
  + apply H.
    intros a3 b1 a4 b2 _ _ _ _ H1 H2 H3.
    rewrite compare_eq_true in H1, H2, H3.
    rewrite Oeset.compare_lt_gt, CompOpp_iff in H2.
    rewrite (Oeset.compare_eq_trans _ _ _ _ H1 (Oeset.compare_eq_trans _ _ _ _ H2 H3)).
    apply refl_equal.
- intros H H'.
  apply H.
  + intros a3 b1 a4 b2 _ _ _ _ H1 H2 H3.
    rewrite compare_eq_true in H1, H2, H3.
    rewrite Oeset.compare_lt_gt, CompOpp_iff in H2.
    rewrite (Oeset.compare_eq_trans _ _ _ _ H1 (Oeset.compare_eq_trans _ _ _ _ H2 H3)).
    apply refl_equal.
  + revert H'; apply _permut_incl.
    intros a b K; rewrite K.
    apply refl_equal.
Qed.

End Sec.

Section PermutiSi.

Hypothesis A : Type.
Hypothesis R : A -> A -> Prop.
Hypothesis ER : equivalence _ R.

Inductive _permut_i_Si : (list A -> list A -> Prop) :=
  | PiSi : forall l1 a1 a2 b1 b2 l2,
      R a1 a2 -> R b1 b2 -> _permut_i_Si (l1 ++ a1 :: b1 :: l2) (l1 ++ b2 :: a2 :: l2).

Inductive permut_i_Si : (list A -> list A -> Prop) :=
  | ReflStep : forall l1 l2, Forall2 R l1 l2 -> permut_i_Si l1 l2
  | SwappStep : forall l1 l2, _permut_i_Si l1 l2 -> permut_i_Si l1 l2
  | TransStep : forall l1 l2 l3, permut_i_Si l1 l2 -> permut_i_Si l2 l3 -> permut_i_Si l1 l3.

Lemma _permut_i_Si_permut :
  forall l1 l2, _permut_i_Si l1 l2 -> _permut R l1 l2.
Proof.
intros k1 k2 H.
inversion H; subst.
apply _permut_app1; [assumption | ].
apply (Pcons (R := R) a1 a2 (l := b1 :: l2) (b2 :: nil) l2).
- assumption.
- apply (Pcons (R := R) b1 b2 (l := l2) nil l2).
  + assumption.
  + apply _permut_refl; intros; destruct ER; apply equiv_refl.
Qed.

Lemma permut_i_Si_strong :
  forall l1 l1' a1 a2 b1 b2 l2 l2',
    Forall2 R l1 l1' -> R a1 a2 -> R b1 b2 -> Forall2 R l2 l2' ->
    permut_i_Si (l1 ++ a1 :: b1 :: l2) (l1' ++ b2 :: a2 :: l2').
Proof.
destruct ER.
intros l1 l1' a1 a2 b1 b2 l2 l2' H1 Ha Hb H2.
constructor 3 with (l1 ++ a1 :: b1 :: l2').
- constructor 1; clear H1.
  revert l2 l2' H2; induction l1 as [ | x1 l1]; intros l2 l2' H2.
    * simpl; repeat (constructor 2; trivial).
    * simpl; constructor 2; trivial.
      apply IHl1; trivial.
- constructor 3 with (l1' ++ a1 :: b1 :: l2').
  + constructor 1; clear H2.
    revert l1' l2' H1; induction l1 as [ | x1 l1]; intros [ | y1 l1'] l2' H1.
    * simpl; repeat (constructor 2; trivial).
      induction l2' as [ | y2 l2']; simpl; [constructor 1 | ].
      constructor 2; trivial.
    * inversion H1.
    * inversion H1.
    * inversion H1; subst; simpl; constructor 2; trivial.
      apply IHl1; trivial.
  + constructor 2.
    apply PiSi; trivial.
Qed.

Lemma permut_i_Si_cons :
  forall a1 a2 l1 l2, R a1 a2 -> permut_i_Si l1 l2 -> permut_i_Si (a1 :: l1) (a2 :: l2).
Proof.
destruct ER.
intros c1 c2 l1 l2 Hc Hl; revert c1 c2 Hc; induction Hl; intros c1 c2 Hc.
- constructor 1; constructor 2; assumption.
- inversion H as [k a1 a2 b1 b2 k']; subst.
  rewrite 2 app_comm_cons; apply permut_i_Si_strong; trivial.
  + constructor 2; trivial.
    clear H; induction k as [ | x k]; [constructor 1 | constructor 2; trivial].
  + clear H; induction k' as [ | x k']; [constructor 1 | constructor 2; trivial].
- constructor 3 with (c1 :: l2); [ | apply IHHl2; trivial].
  apply IHHl1; trivial.
Qed.

Lemma permut_i_Si_permut :
  forall l1 l2, permut_i_Si l1 l2 <-> _permut R l1 l2.
Proof.
destruct ER.
intros l1 l2; split; intro H.
- induction H.
  + revert l2 H; induction l1 as [ | a1 l1]; intros [ | a2 l2] H.
    * apply _permut_refl; intros a Ha; contradiction Ha.
    * inversion H.
    * inversion H.
    * inversion H; subst.
      apply (Pcons (R := R) a1 a2 (l := l1) nil l2); [assumption | ].
      apply IHl1; assumption.
  + apply _permut_i_Si_permut; assumption.
  + apply _permut_trans with l2; trivial.
    do 6 intro; apply equiv_trans.
- induction H.
  + constructor 1; constructor 1.
  + constructor 3 with (a :: (l1 ++ l2)); [apply permut_i_Si_cons; trivial | ].
    clear H0 IH_permut.
    revert l2; induction l1 as [ | a1 l1]; intro l2; simpl.
    * constructor 1; constructor 2; trivial.
      induction l2 as [ | a2 l2]; [constructor 1 | constructor 2; trivial].
    * {
        constructor 3 with (a1 :: a :: l1 ++ l2).
        - constructor 2; apply (@PiSi nil); trivial.
        - apply permut_i_Si_cons; trivial.
      }
Qed.

End PermutiSi.

Lemma partition_spec3_strong :
  forall (A : Type) (f : A -> bool) l l1 l2, partition f l = (l1, l2) -> _permut (@eq A) l (l1 ++ l2).
Proof.
intros A f l; induction l as [ | a1 l]; intros l1 l2 Hl; simpl in Hl.
- injection Hl; clear Hl; do 2 intro; subst l1 l2; apply _permut_refl; intros; apply refl_equal.
- case_eq (partition f l); intros k1 k2 Kl; rewrite Kl in Hl.
  case_eq (f a1); intro Ha1; rewrite Ha1 in Hl; injection Hl; clear Hl; do 2 intro; subst l1 l2.
  + simpl; apply (Pcons a1 a1 nil (k1 ++ k2)); [apply refl_equal | ].
    simpl; apply IHl; apply Kl.
  + apply Pcons; [apply refl_equal | ].
    apply IHl; apply Kl.
Qed.

Lemma partition_spec3 :
  forall (A : Type) (OA : Oeset.Rcd A) (f : A -> bool) l l1 l2,
    partition f l = (l1, l2) -> _permut (fun x y => Oeset.compare OA x y = Eq) l (l1 ++ l2).
Proof.
intros A OA f l l1 l2 H.
generalize (partition_spec3_strong _ _ H).
apply _permut_incl.
intros a b K; subst b; apply Oeset.compare_eq_refl.
Qed.

Lemma partition_permut :
  forall (A : Type) (OA : Oeset.Rcd A) (f1 f2 : A -> bool) l,
    (forall x y, List.In x l -> Oeset.compare OA x y = Eq -> f1 x = f2 y) ->
    forall l1 l2 k k1 k2, partition f1 l = (l1, l2) -> partition f2 k = (k1, k2) ->
    _permut (fun x y => Oeset.compare OA x y = Eq) l k ->
    _permut (fun x y => Oeset.compare OA x y = Eq) l1 k1 /\
    _permut (fun x y => Oeset.compare OA x y = Eq) l2 k2.
Proof.
intros A OA f1 f2 l; induction l as [ | a1 l]; intros Hl l1 l2 k k1 k2 Pl Pk H.
- inversion H; subst k; simpl in Pl, Pk; injection Pl; injection Pk; do 4 intro; subst.
  split; apply permut_refl.
- simpl in Pl.
  case_eq (partition f1 l); intros ll1 ll2; intro Pll; rewrite Pll in Pl.
  inversion H; clear H; subst.
  assert (Hb := sym_eq (Hl a1 b (or_introl _ (refl_equal _)) H2)).
  assert (Pk1 := partition_app1 f2 l3 (b :: l4)); rewrite Pk in Pk1.
  assert (Pk2 := partition_app2 f2 l3 (b :: l4)); rewrite Pk in Pk2.
  simpl in Pk1, Pk2; rewrite Hb in Pk1, Pk2.
  case_eq (partition f2 l3); intros l3' l3'' Hl3; rewrite Hl3 in Pk1, Pk2.
  case_eq (partition f2 l4); intros l4' l4'' Hl4; rewrite Hl4 in Pk1, Pk2.
  assert (Pkk : partition f2 (l3 ++ l4) = (l3' ++ l4', l3'' ++ l4'')).
  {
    generalize (partition_app1 f2 l3 l4); rewrite Hl3, Hl4; simpl.
    generalize (partition_app2 f2 l3 l4); rewrite Hl3, Hl4; simpl.
    destruct (partition f2 (l3 ++ l4)); simpl; do 2 intro; subst; apply refl_equal.
  }
  assert (IH := IHl (fun x y h => Hl x y (or_intror _ h)) _ _ _ _ _ Pll Pkk H4).
  destruct IH as [IH1 IH2].
  case_eq (f1 a1); intro Ha1; rewrite Ha1 in Hb, Pl, Pk1, Pk2;
  injection Pl; clear Pl; do 2 intro; subst l1 l2; simpl in Pk1, Pk2; subst k1 k2.
  + split; [apply Pcons; [apply H2 | apply IH1] | apply IH2].
  + split; [apply IH1 | apply Pcons; [apply H2 | apply IH2]].
Qed.

Definition cartesian_product (A B C : Type) (f : A -> B -> C) l1 l2 :=
  flat_map (fun e1 => map (fun e2 => f e1 e2) l2) l1.

Lemma cartesian_product_app_1 :
  forall (A B C : Type) (f : A -> B -> C) l1 l1' l2,
    cartesian_product f (l1 ++ l1') l2 = cartesian_product f l1 l2 ++ cartesian_product f l1' l2.
Proof.
intros A B C f l1; induction l1 as [ | a1 l1]; intros l1' l2; simpl; trivial.
- rewrite <-ass_app; apply f_equal.
  apply IHl1.
Qed.

Lemma cartesian_product_app_2 :
  forall (A B C : Type) (f : A -> B -> C) l1 l2 l2',
    _permut eq (cartesian_product f l1 (l2 ++ l2')) (cartesian_product f l1 l2 ++ cartesian_product f l1 l2').
Proof.
intros A B C f l1; induction l1 as [ | a1 l1]; intros l2 l2'; simpl.
- constructor 1.
- apply _permut_trans with (map (fun e2 : B => f a1 e2) (l2 ++ l2') ++
                             (cartesian_product f l1 l2 ++ cartesian_product f l1 l2')).
  + intros; subst; trivial.
  + apply _permut_app1; [ | apply IHl1].
    split; [unfold reflexive | unfold transitive | unfold symmetric ]; intros; subst; trivial.
  + rewrite map_app, <- 2 ass_app; apply _permut_app1.
    * split; [unfold reflexive | unfold transitive | unfold symmetric ]; intros; subst; trivial.
    * rewrite 2 ass_app; apply _permut_app2;
        [ | apply _permut_swapp; apply _permut_refl; intros; subst; trivial].
    split; [unfold reflexive | unfold transitive | unfold symmetric ]; intros; subst; trivial.
Qed.

Lemma permut_flat_map :
    forall (A B C : Type) (f : A -> B -> C) (lb1 : list (list A)) (lb2 : list (list B)),
      _permut eq (cartesian_product f (flat_map (fun x => x) lb1) (flat_map (fun x => x) lb2))
             (flat_map (fun x => x) (cartesian_product (cartesian_product f) lb1 lb2)).
Proof.
intros A B C f lb1; induction lb1 as [ | b1 lb1]; intros lb2; simpl.
- constructor 1.
- rewrite cartesian_product_app_1, flat_map_app.
  apply _permut_app; [ | apply IHlb1].
  clear lb1 IHlb1.
  revert b1; induction lb2 as [ | b2 lb2]; simpl.
  + intro b1; induction b1 as [ | x1 b1]; simpl.
    * constructor 1.
    * assumption.
  + intro b1; simpl.
    apply _permut_trans with
        (cartesian_product f b1 b2 ++
          (cartesian_product f b1 (flat_map (fun x : list B => x) lb2))).
    * intros; subst; trivial.
    * apply cartesian_product_app_2.
    * apply _permut_app1; [ | apply IHlb2].
    split; [unfold reflexive | unfold transitive | unfold symmetric ]; intros; subst; trivial.
Qed.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.
Require Export notations.

(** * Setoids and equality.

      This module introduces setoids, which consist of a type packaged together with
      an equivalence relation.  We roughly follow the techniques described in the paper
      _Packaging Mathematical Structures_ by Garillot et al. (TPHOLS 2009).  The mainstay
      of this technique is using canonoical structures to automatically infer structures
      given the carrier type.

      We use the symbol ≈ to indicate the equality relation on setoids.  For the vast
      majority of this development, ≈ will be the notion of equivalence of interest.
  *)

Delimit Scope equiv_scope with eq.
Open Scope equiv_scope.

Module Eq.
  Record mixin_of (T:Type) :=
    Mixin
    { eq : T -> T -> Prop
    ; refl : forall x, eq x x
    ; symm : forall x y, eq x y -> eq y x
    ; trans : forall x y z,
             eq x y -> eq y z -> eq x z
    }.
  Structure type : Type :=
    Pack { carrier :> Type ; mixin : mixin_of carrier }.

End Eq.
Definition eq_op T := Eq.eq _ (Eq.mixin T).
Notation "x ≈ y" := (@eq_op _ x y) : equiv_scope.
Notation "x ≉ y" := (~(@eq_op _ x y)) : equiv_scope.
Coercion Eq.carrier : Eq.type >-> Sortclass.

Lemma eq_refl : forall (T:Eq.type) (x:T), x ≈ x.
Proof.
  intros. destruct T. destruct mixin. apply refl.
Qed.

Lemma eq_trans : forall (T:Eq.type) (x y z:T), x ≈ y -> y ≈ z -> x ≈ z.
Proof.
  intros. destruct T. destruct mixin. eapply trans; eauto.
Qed.

Lemma eq_symm : forall (T:Eq.type) (x y:T), x ≈ y -> y ≈ x.
Proof.
  intros. destruct T. destruct mixin. eapply symm; eauto.
Qed.

Hint Resolve eq_refl eq_symm eq_trans.

Add Parametric Relation (T:Eq.type) : (Eq.carrier T) (@eq_op T)
  reflexivity proved by (@eq_refl T)
  symmetry proved by (@eq_symm T)
  transitivity proved by (@eq_trans T)
  as eq_op_rel.

Record eq_dec (T:Eq.type) :=
    EqDec
    { eqdec :> forall x y:T, {x ≈ y}+{x ≉ y} }.

Arguments eqdec [T] [e] x y.


Require Import ProofIrrelevance JMeq.
Require Export Graph Paths.
Require Import Common StructureEquality Notations FEqualDep.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Section Graphs.
  Context `(G : Graph v).
  Context `(H : Graph w).

  Record GraphTranslation := {
    VertexOf' : v -> w;
    EdgeOf' : forall s d, G.(Edge') s d -> H.(Edge') (VertexOf' s) (VertexOf' d)
  }.

  Section GraphInterface.
    Context `(T : GraphTranslation).

    Definition VertexOf : G -> H := Eval cbv beta delta [VertexOf'] in T.(VertexOf').
    Definition EdgeOf : forall s d : G, G.(Edge) s d -> H.(Edge) (VertexOf s) (VertexOf d) :=
      Eval cbv beta delta [EdgeOf'] in T.(EdgeOf').
  End GraphInterface.
End Graphs.

Coercion VertexOf : GraphTranslation >-> Funclass.

Arguments VertexOf {v G w H} T x : simpl nomatch.
Arguments EdgeOf {v G w H} T [s d] p : simpl nomatch.

Section GraphTranslations_Equal.
  Lemma GraphTranslations_Equal v G w H : forall (T U : @GraphTranslation v G w H),
    VertexOf T = VertexOf U
    -> (VertexOf T = VertexOf U -> EdgeOf T == EdgeOf U)
    -> T = U.
  Proof.
    destruct T, U; simpl; intros; specialize_all_ways; repeat subst;
      reflexivity.
  Qed.

  Lemma GraphTranslations_JMeq v G w H v' G' w' H' :
    forall (T : @GraphTranslation v G w H) (U : @GraphTranslation v' G' w' H'),
      v = v'
      -> w = w'
      -> (v = v' -> G == G')
      -> (w = w' -> H == H')
      -> (v = v' -> G == G'
        -> w = w' -> H == H'
        -> VertexOf T == VertexOf U)
      -> (v = v' -> G == G'
        -> w = w' -> H == H'
        -> VertexOf T == VertexOf U
        -> EdgeOf T == EdgeOf U)
      -> T == U.
  Proof.
    simpl; intros; intuition; repeat subst; destruct T, U; simpl in *.
      repeat subst; reflexivity.
  Qed.
End GraphTranslations_Equal.

Ltac graph_translation_eq_step_with tac :=
  structures_eq_step_with_tac ltac:(apply GraphTranslations_Equal || apply GraphTranslations_JMeq) tac.

Ltac graph_translation_eq_with tac := repeat graph_translation_eq_step_with tac.

Ltac graph_translation_eq_step := graph_translation_eq_step_with idtac.
Ltac graph_translation_eq := graph_translation_eq_with idtac.

Section GraphTranslationComposition.
  Context `(B : @Graph vertB).
  Context `(C : @Graph vertC).
  Context `(D : @Graph vertD).
  Context `(E : @Graph vertE).

  Definition ComposeGraphTranslations (G : GraphTranslation D E) (F : GraphTranslation C D) : GraphTranslation C E :=
    {| VertexOf' := (fun c => G (F c));
      EdgeOf' := (fun _ _ m => G.(EdgeOf) (F.(EdgeOf) m)) |}.
End GraphTranslationComposition.

Section IdentityGraphTranslation.
  Context `(C : @Graph vertC).

  (* There is an identity graph translation.  It does the obvious thing. *)
  Definition IdentityGraphTranslation : GraphTranslation C C :=
    {| VertexOf' := (fun x => x);
      EdgeOf' := (fun _ _ x => x) |}.
End IdentityGraphTranslation.

Section GraphTranslationCompositionLemmas.
  Context `(B : @Graph vertB).
  Context `(C : @Graph vertC).
  Context `(D : @Graph vertD).
  Context `(E : @Graph vertE).

  Lemma ComposeGraphTranslationsAssociativity (F : GraphTranslation B C) (G : GraphTranslation C D) (H : GraphTranslation D E) :
    ComposeGraphTranslations (ComposeGraphTranslations H G) F = ComposeGraphTranslations H (ComposeGraphTranslations G F).
  Proof.
    reflexivity.
  Qed.
End GraphTranslationCompositionLemmas.


Require Import coqutil.Map.Interface bedrock2.Lift1Prop. Import map.

Section Sep.
  Context {key value} {map : map key value}.
  Definition emp (P : Prop) := fun m : map => m = empty /\ P.
  Definition sep (p q : map -> Prop) m :=
    exists mp mq, split m mp mq /\ p mp /\ q mq.
  Definition ptsto k v := fun m : map => m = put empty k v.
  Definition read k (P : value -> rep -> Prop) := (ex1 (fun v => sep (ptsto k v) (P v))).

  Fixpoint seps (xs : list (rep -> Prop)) : rep -> Prop :=
    match xs with
    | cons x nil => x
    | cons x xs => sep x (seps xs)
    | nil => emp True
    end.
End Sep.

Declare Scope sep_scope.
Delimit Scope sep_scope with sep.
Infix "*" := sep (at level 40, left associativity) : sep_scope.
Infix "⋆" := sep (at level 40, left associativity) : sep_scope.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Simplification_B.

Coq < Goal forall m t s r:Prop, ((m \/ t) /\ (s -> r)) -> (m \/ t).
1 subgoal

  ============================
   forall m t s r : Prop, (m \/ t) /\ (s -> r) -> m \/ t

Unnamed_thm < intros.
1 subgoal

  m : Prop
  t : Prop
  s : Prop
  r : Prop
  H : (m \/ t) /\ (s -> r)
  ============================
   m \/ t

Unnamed_thm < apply H.
No more subgoals.

Unnamed_thm < Qed.
intros.
apply H.

Unnamed_thm is defined

Coq <

*)

Section Simplification_B.
Goal forall m t s r:Prop, ((m \/ t) /\ (s -> r)) -> (m \/ t).
intros.
apply H.
Qed.


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** Merge sort. Adapted from the implementation of Hugo Herbelin in the Coq
standard library, but without using the module system. *)
From Coq Require Export Sorted.
From stdpp Require Export orders list.
Set Default Proof Using "Type".

Section merge_sort.
  Context {A} (R : relation A) `{∀ x y, Decision (R x y)}.

  Fixpoint list_merge (l1 : list A) : list A → list A :=
    fix list_merge_aux l2 :=
    match l1, l2 with
    | [], _ => l2
    | _, [] => l1
    | x1 :: l1, x2 :: l2 =>
       if decide (R x1 x2) then x1 :: list_merge l1 (x2 :: l2)
       else x2 :: list_merge_aux l2
    end.
  Global Arguments list_merge !_ !_ / : assert.

  Local Notation stack := (list (option (list A))).
  Fixpoint merge_list_to_stack (st : stack) (l : list A) : stack :=
    match st with
    | [] => [Some l]
    | None :: st => Some l :: st
    | Some l' :: st => None :: merge_list_to_stack st (list_merge l' l)
    end.
  Fixpoint merge_stack (st : stack) : list A :=
    match st with
    | [] => []
    | None :: st => merge_stack st
    | Some l :: st => list_merge l (merge_stack st)
    end.
  Fixpoint merge_sort_aux (st : stack) (l : list A) : list A :=
    match l with
    | [] => merge_stack st
    | x :: l => merge_sort_aux (merge_list_to_stack st [x]) l
    end.
  Definition merge_sort : list A → list A := merge_sort_aux [].
End merge_sort.

(** ** Properties of the [Sorted] and [StronglySorted] predicate *)
Section sorted.
  Context {A} (R : relation A).

  Lemma Sorted_StronglySorted `{!Transitive R} l :
    Sorted R l → StronglySorted R l.
  Proof. by apply Sorted.Sorted_StronglySorted. Qed.
  Lemma StronglySorted_unique `{!AntiSymm (=) R} l1 l2 :
    StronglySorted R l1 → StronglySorted R l2 → l1 ≡ₚ l2 → l1 = l2.
  Proof.
    intros Hl1; revert l2. induction Hl1 as [|x1 l1 ? IH Hx1]; intros l2 Hl2 E.
    { symmetry. by apply Permutation_nil. }
    destruct Hl2 as [|x2 l2 ? Hx2].
    { by apply Permutation_nil in E. }
    assert (x1 = x2); subst.
    { rewrite Forall_forall in Hx1, Hx2.
      assert (x2 ∈ x1 :: l1) as Hx2' by (by rewrite E; left).
      assert (x1 ∈ x2 :: l2) as Hx1' by (by rewrite <-E; left).
      inversion Hx1'; inversion Hx2'; simplify_eq; auto. }
    f_equal. by apply IH, (inj (x2 ::)).
  Qed.
  Lemma Sorted_unique `{!Transitive R, !AntiSymm (=) R} l1 l2 :
    Sorted R l1 → Sorted R l2 → l1 ≡ₚ l2 → l1 = l2.
  Proof. auto using StronglySorted_unique, Sorted_StronglySorted. Qed.

  Global Instance HdRel_dec x `{∀ y, Decision (R x y)} l :
    Decision (HdRel R x l).
  Proof.
   refine
    match l with
    | [] => left _
    | y :: l => cast_if (decide (R x y))
    end; abstract first [by constructor | by inversion 1].
  Defined.
  Global Instance Sorted_dec `{∀ x y, Decision (R x y)} : ∀ l,
    Decision (Sorted R l).
  Proof.
   refine
    (fix go l :=
    match l return Decision (Sorted R l) with
    | [] => left _
    | x :: l => cast_if_and (decide (HdRel R x l)) (go l)
    end); clear go; abstract first [by constructor | by inversion 1].
  Defined.
  Global Instance StronglySorted_dec `{∀ x y, Decision (R x y)} : ∀ l,
    Decision (StronglySorted R l).
  Proof.
   refine
    (fix go l :=
    match l return Decision (StronglySorted R l) with
    | [] => left _
    | x :: l => cast_if_and (decide (Forall (R x) l)) (go l)
    end); clear go; abstract first [by constructor | by inversion 1].
  Defined.

  Context {B} (f : A → B).
  Lemma HdRel_fmap (R1 : relation A) (R2 : relation B) x l :
    (∀ y, R1 x y → R2 (f x) (f y)) → HdRel R1 x l → HdRel R2 (f x) (f <$> l).
  Proof. destruct 2; constructor; auto. Qed.
  Lemma Sorted_fmap (R1 : relation A) (R2 : relation B) l :
    (∀ x y, R1 x y → R2 (f x) (f y)) → Sorted R1 l → Sorted R2 (f <$> l).
  Proof. induction 2; simpl; constructor; eauto using HdRel_fmap. Qed.
  Lemma StronglySorted_fmap (R1 : relation A) (R2 : relation B) l :
    (∀ x y, R1 x y → R2 (f x) (f y)) →
    StronglySorted R1 l → StronglySorted R2 (f <$> l).
  Proof.
    induction 2; csimpl; constructor;
      rewrite ?Forall_fmap; eauto using Forall_impl.
  Qed.
End sorted.

(** ** Correctness of merge sort *)
Section merge_sort_correct.
  Context  {A} (R : relation A) `{∀ x y, Decision (R x y)}.

  Lemma list_merge_cons x1 x2 l1 l2 :
    list_merge R (x1 :: l1) (x2 :: l2) =
      if decide (R x1 x2) then x1 :: list_merge R l1 (x2 :: l2)
      else x2 :: list_merge R (x1 :: l1) l2.
  Proof. done. Qed.
  Lemma HdRel_list_merge x l1 l2 :
    HdRel R x l1 → HdRel R x l2 → HdRel R x (list_merge R l1 l2).
  Proof.
    destruct 1 as [|x1 l1 IH1], 1 as [|x2 l2 IH2];
      rewrite ?list_merge_cons; simpl; repeat case_decide; auto.
  Qed.
  Lemma Sorted_list_merge `{!Total R} l1 l2 :
    Sorted R l1 → Sorted R l2 → Sorted R (list_merge R l1 l2).
  Proof.
    intros Hl1. revert l2. induction Hl1 as [|x1 l1 IH1];
      induction 1 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl;
      repeat case_decide;
      constructor; eauto using HdRel_list_merge, HdRel_cons, total_not.
  Qed.
  Lemma merge_Permutation l1 l2 : list_merge R l1 l2 ≡ₚ l1 ++ l2.
  Proof.
    revert l2. induction l1 as [|x1 l1 IH1]; intros l2;
      induction l2 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl;
      repeat case_decide; auto.
    - by rewrite (right_id_L [] (++)).
    - by rewrite IH2, Permutation_middle.
  Qed.

  Local Notation stack := (list (option (list A))).
  Inductive merge_stack_Sorted : stack → Prop :=
    | merge_stack_Sorted_nil : merge_stack_Sorted []
    | merge_stack_Sorted_cons_None st :
       merge_stack_Sorted st → merge_stack_Sorted (None :: st)
    | merge_stack_Sorted_cons_Some l st :
       Sorted R l → merge_stack_Sorted st → merge_stack_Sorted (Some l :: st).
  Fixpoint merge_stack_flatten (st : stack) : list A :=
    match st with
    | [] => []
    | None :: st => merge_stack_flatten st
    | Some l :: st => l ++ merge_stack_flatten st
    end.

  Lemma Sorted_merge_list_to_stack `{!Total R} st l :
    merge_stack_Sorted st → Sorted R l →
    merge_stack_Sorted (merge_list_to_stack R st l).
  Proof.
    intros Hst. revert l.
    induction Hst; repeat constructor; naive_solver auto using Sorted_list_merge.
  Qed.
  Lemma merge_list_to_stack_Permutation st l :
    merge_stack_flatten (merge_list_to_stack R st l) ≡ₚ
      l ++ merge_stack_flatten st.
  Proof.
    revert l. induction st as [|[l'|] st IH]; intros l; simpl; auto.
    by rewrite IH, merge_Permutation, (assoc_L _), (comm (++) l).
  Qed.
  Lemma Sorted_merge_stack `{!Total R} st :
    merge_stack_Sorted st → Sorted R (merge_stack R st).
  Proof. induction 1; simpl; auto using Sorted_list_merge. Qed.
  Lemma merge_stack_Permutation st : merge_stack R st ≡ₚ merge_stack_flatten st.
  Proof.
    induction st as [|[] ? IH]; intros; simpl; auto.
    by rewrite merge_Permutation, IH.
  Qed.
  Lemma Sorted_merge_sort_aux `{!Total R} st l :
    merge_stack_Sorted st → Sorted R (merge_sort_aux R st l).
  Proof.
    revert st. induction l; simpl;
      auto using Sorted_merge_stack, Sorted_merge_list_to_stack.
  Qed.
  Lemma merge_sort_aux_Permutation st l :
    merge_sort_aux R st l ≡ₚ merge_stack_flatten st ++ l.
  Proof.
    revert st. induction l as [|?? IH]; simpl; intros.
    - by rewrite (right_id_L [] (++)), merge_stack_Permutation.
    - rewrite IH, merge_list_to_stack_Permutation; simpl.
      by rewrite Permutation_middle.
  Qed.
  Lemma Sorted_merge_sort `{!Total R} l : Sorted R (merge_sort R l).
  Proof. apply Sorted_merge_sort_aux. by constructor. Qed.
  Lemma merge_sort_Permutation l : merge_sort R l ≡ₚ l.
  Proof. unfold merge_sort. by rewrite merge_sort_aux_Permutation. Qed.
  Lemma StronglySorted_merge_sort `{!Transitive R, !Total R} l :
    StronglySorted R (merge_sort R l).
  Proof. auto using Sorted_StronglySorted, Sorted_merge_sort. Qed.
End merge_sort_correct.


(** * Pointwise Natural Transformations *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import FunctorCategory.Core NaturalTransformation.Paths Functor.Composition.Core NaturalTransformation.Composition.Core.
Require Import Functor.Pointwise.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** Recall that a "pointwise" functor is a functor [Aᴮ → Cᴰ] induced
    by functors [D → B] and [A → C].  Given two functors [D → B] and a
    natural transformation between them, there is an induced natural
    transformation between the resulting functors between functor
    categories, and similarly for two functors [A → C].  In this file,
    we construct these natural transformations. They will be used to
    construct the pointwise induced adjunction [Fˣ ⊣ Gˣ] of an
    adjunction [F ⊣ G] for all categories [X]. *)

Local Open Scope morphism_scope.
Local Open Scope category_scope.
Local Open Scope functor_scope.
Local Open Scope natural_transformation_scope.

Section pointwise.
  Context `{Funext}.

  Variables C D C' D' : PreCategory.

  Local Ltac t :=
    path_natural_transformation; simpl;
    rewrite <- ?composition_of;
    try apply ap;
    first [ apply commutes
          | symmetry; apply commutes ].

  (** ** [Tˣ] for a natural transformation [T : F → G] and a functor [x : C → D] *)
  Definition pointwise_l
             (F G : Functor C D)
             (T : NaturalTransformation F G)
             (F' : Functor C' D')
  : NaturalTransformation (pointwise F F') (pointwise G F').
  Proof.
    refine (Build_NaturalTransformation
              (pointwise F F') (pointwise G F')
              (fun f : object (D -> C') => (F' o f) oL T)%natural_transformation
              _).
    abstract t.
  Defined.

  (** ** [Fᵀ] for a natural transformation [T : F' → G'] and a functor [F : C → D] *)
  Definition pointwise_r
             (F : Functor C D)
             (F' G' : Functor C' D')
             (T' : NaturalTransformation F' G')
  : NaturalTransformation (pointwise F F') (pointwise F G').
  Proof.
    refine (Build_NaturalTransformation
              (pointwise F F') (pointwise F G')
              (fun f : object (D -> C') => T' oR f oR F)%natural_transformation
              _).
    abstract t.
  Defined.
End pointwise.


Require Export Db.Spec.
Require Export Db.Lemmas.
Require Coq.Setoids.Setoid.

Section WsSnoc.

  Context {X: Type}.
  Context {wsX: Ws X}.

  Lemma ws_snoc (γ₁ γ₂: Dom) (ζ: Sub X) (x: X) :
    ⟨ ζ : γ₁ => γ₂ ⟩ → ⟨ γ₂ ⊢ x ⟩ → ⟨ (ζ · x) : S γ₁ => γ₂ ⟩.
  Proof.
    intros wζ wx i wi.
    inversion wi; eauto.
  Qed.

  Lemma wsi_snoc_sub (γ₁ γ₂: Dom) (ζ: Sub X) (x: X) :
    ⟨ ζ · x : S γ₁ => γ₂ ⟩ → ⟨ ζ : γ₁ => γ₂ ⟩.
  Proof.
    intros wζ i.
    specialize (wζ (S i)).
    eauto using wsIx.
  Qed.

  Lemma wsi_snoc_tm (γ₁ γ₂: Dom) (ζ: Sub X) (x: X) :
    ⟨ ζ · x : S γ₁ => γ₂ ⟩ → ⟨ γ₂ ⊢ x ⟩.
  Proof.
    intros wζ.
    specialize (wζ 0).
    eauto using wsIx.
  Qed.

End WsSnoc.

Lemma wsiS (γ: Dom) (i: Ix) : S γ ∋ S i → γ ∋ i.
Proof. inversion 1; auto. Qed.

#[export]
Hint Constructors wsIx : ws.
#[export]
Hint Resolve wsiS : wsi.
#[export]
Hint Resolve ws_snoc : ws.
#[export]
Hint Resolve wsi_snoc_sub : wsi.
#[export]
Hint Resolve wsi_snoc_tm : wsi.

Ltac crushScopingMatchH :=
  match goal with
    | [ H: 0 ∋ _                 |- _ ] => inversion H
    | [ H: S _    ∋ O            |- _ ] => clear H
    | [ H: S _ ∋ S _             |- _ ] => apply wsiS in H
    | [ H: S _ ∋ wk _             |- _ ] => apply wsiS in H
    (* | [ H: @ws ?X ?wsX (S ?δ) (@wk ?X ?vrX ?wkX ?x) |- _ *)
    (*   ] => apply (@wsiWk X wsX vrX wkX _ δ x) in H *)
    | [H: ∀ i, S _ ∋ i → _ |- _] =>
      let HS := fresh in
      let HO := fresh in
      pose proof (fun i wi => H (S i) (wsS _ i wi)) as HS;
      pose proof (H 0 (ws0 _)) as HO;
      clear H; cbn in HS; cbn in HO
    | [ H: ⟨ _ ⊢ vr _ ⟩ |- _ ] => eapply wsiVr in H

    | [ wi : S _ ∋ ?i
        |- context [match ?i with _ => _ end]
      ] => destruct i
    | [ wi : S _ ∋ ?i
        |- context [(_ · _) ?i]
      ] => destruct i
    | [ |- S _ ∋ 0               ] => apply ws0
    | [ |- S _ ∋ S _             ] => apply wsS
    | [ |- S _ ∋ wk _             ] => apply wsS
    | [ |- WsSub _ _ (_ · _)     ] => eapply ws_snoc

    | [ |- ⟨ S _ ⊢ wk _ ⟩ ] => eapply wsWk
    | [ |- ⟨ _ ⊢ vr _ ⟩ ] => eapply wsVr
    (* | [ |- ⟨ _ ⊢ _[_] ⟩ ] => eapply wsAp *)
  end.

Local Ltac crush :=
  cbn; intros;
  repeat
    (cbn;
     repeat crushScopingMatchH;
     repeat crushDbSyntaxMatchH;
     rewrite ?ap_vr in *);
  eauto with typeclass_instances ws;
  eauto with typeclass_instances wsi.

(* Lemma wsIx_plus_dec {γ δ i} (wi: γ ∪ δ ∋ i) : *)
(*   ∀ (P: Prop), *)
(*     (∀ j, γ ∋ j → wkl δ j = i → P) → *)
(*     (∀ j, δ ∋ j → wkr γ j = i → P) → P. *)
(* Proof with cbn in *; subst; eauto using wsIx. *)
(*   depind wi; destruct δ... *)
(*   eapply IHwi; intros... *)
(* Qed. *)

(* Lemma wsIx_plus_dec' {γ δ i} (wi: γ ∪ δ ∋ i) : *)
(*   (∃ j, γ ∋ j ∧ wkl δ j = i) ∨ *)
(*   (∃ j, δ ∋ j ∧ wkr γ j = i). *)
(* Proof. apply (wsIx_plus_dec wi); eauto. Qed. *)

(* Lemma wsIx_wks (δ: Dom) : *)
(*   ∀ (γ: Dom) (i: Ix), γ ∋ i → (γ ∪ δ) ∋ (wks δ i). *)
(* Proof. induction δ; eauto using wsIx. Qed. *)
(* Hint Resolve wsIx_wks : ws. *)

(* Lemma wsiIx_wks (δ: Dom) : *)
(*   ∀ (γ: Dom) (i: Ix), (γ ∪ δ) ∋ (wks δ i) → γ ∋ i. *)
(* Proof. induction δ; eauto using wsIx, wsiS. Qed. *)
(* Hint Resolve wsiIx_wks : wsi. *)

(* Lemma wsiIx_wks1 : *)
(*   ∀ (γ: Dom) (i: Ix), (S γ) ∋ (wks 1 i) → γ ∋ i. *)
(* Proof. apply (wsiIx_wks 1). Qed. *)
(* Hint Resolve wsiIx_wks : wsi. *)

Section Stuff.

  Context {X: Type}.
  Context {vrX: Vr X}.
  Context {wkX: Wk X}.
  Context {wsX: Ws X}.
  Context {wsVrX: WsVr X}.
  Context {wsWkX: WsWk X}.

  Lemma ws_wks (δ: Dom) :
    ∀ γ (x: X), ⟨ γ ⊢ x ⟩ → ⟨ γ ∪ δ ⊢ wks δ x ⟩.
  Proof. induction δ; crush. Qed.

  (* Lemma wsi_wks (δ: Dom) : *)
  (*   ∀ γ (x: X), ⟨ γ ∪ δ ⊢ wks δ x ⟩ → ⟨ γ ⊢ x ⟩. *)
  (* Proof. induction δ; crush. Qed. *)

  Lemma wsSub_idm (γ: Dom) : ⟨ idm X : γ => γ ⟩.
  Proof. unfold WsSub, idm; crush. Qed.

  Lemma wsSub_wkm (γ: Dom) : ⟨ wkm : γ => S γ ⟩.
  Proof. unfold WsSub; crush. Qed.

  Lemma wsSub_wkms (γ: Dom) d : ⟨ wkms d : γ => d + γ ⟩.
  Proof. unfold WsSub, wkms; induction d; crush. Qed.

  Definition WsSubNatural (γ₁ γ₂: Dom) (ξ₁ ξ₂ : Sub X) : Prop :=
    ∀ (i: Ix), ⟨ γ₁ ⊢ ξ₁ i ⟩ → ⟨ γ₂ ⊢ ξ₂ i ⟩.

  Lemma wsSubNat_comp
    {f₁ f₂ f₃: Dom → Dom} {ξ₁ ξ₂ ξ₃: Sub X}
    (H₁₂: ∀ γ, WsSubNatural (f₁ γ) (f₂ γ) ξ₁ ξ₂)
    (H₂₃: ∀ γ, WsSubNatural (f₂ γ) (f₃ γ) ξ₂ ξ₃) :
    ∀ γ, WsSubNatural (f₁ γ) (f₃ γ) ξ₁ ξ₃.
  Proof. unfold WsSubNatural in *; eauto. Qed.

  Lemma wsSub_natural'
    {f₁ f₂: Dom → Dom} {ξ₁ ξ₂: Sub X}
    (hyp: ∀ γ, WsSubNatural (f₁ γ) (f₂ γ) ξ₁ ξ₂) :
    ∀ γ₁ γ₂,
      WsSub γ₁ (f₁ γ₂) ξ₁ →
      WsSub γ₁ (f₂ γ₂) ξ₂.
  Proof. unfold WsSubNatural, WsSub in *; eauto. Qed.

  Lemma wsSub_up (γ₁ γ₂: Dom) (ξ: Sub X) :
    ⟨ ξ : γ₁ => γ₂ ⟩ → ⟨ ξ↑ : S γ₁ => S γ₂ ⟩.
  Proof. unfold up, WsSub; crush. Qed.
  Hint Resolve wsSub_up : ws.

  (* Lemma wsiSub_up (γ₁ γ₂: Dom) (ξ: Sub X) : *)
  (*   ⟨ ξ↑ : S γ₁ => S γ₂ ⟩ → ⟨ ξ : γ₁ => γ₂ ⟩. *)
  (* Proof. *)
  (*   unfold WsSub; crush. *)
  (*   eauto using wsiWk. *)
  (* Qed. *)
  (* Hint Resolve wsiSub_up : wsi. *)

  Lemma wsSub_ups (γ₁ γ₂ δ: Dom) (ξ: Sub X) :
    WsSub γ₁ γ₂ ξ → WsSub (γ₁ ∪ δ) (γ₂ ∪ δ) (ξ ↑⋆ δ).
  Proof. induction δ; crush. Qed.
  Hint Resolve wsSub_ups : ws.

  (* Lemma wsiSub_ups (γ₁ γ₂ δ: Dom) (ξ: Sub X) : *)
  (*   WsSub (γ₁ ∪ δ) (γ₂ ∪ δ) (ξ ↑⋆ δ) → WsSub γ₁ γ₂ ξ. *)
  (* Proof. induction δ; crush. Qed. *)
  (* Hint Resolve wsiSub_ups : wsi. *)

  Lemma wsSub_closed (ξ: Sub X) (δ: Dom) : ⟨ ξ : 0 => δ ⟩.
  Proof. unfold WsSub; crush. Qed.
  Hint Resolve wsSub_closed : ws.

  Context {apX: Ap X X}.
  Context {apVrX: LemApVr X X}.
  Context {apWkX: LemApWk X X}.
  Context {apCompXXX: LemApComp X X X}.
  Context {wsApX: WsAp X X}.

  Lemma weakening {γ: Dom} {x: X} (wx: ⟨ γ ⊢ x ⟩) :
    ⟨ S γ ⊢ x[wkm] ⟩.
  Proof.
    rewrite <- ap_wk.
    now apply wsWk.
  Qed.

  Lemma weakenings δ {γ: Dom} {x: X} (wx: ⟨ γ ⊢ x ⟩) :
    ⟨ γ ∪ δ ⊢ x[wkms δ] ⟩.
  Proof.
    induction δ.
    - cbn; now rewrite ap_id.
    - rewrite wkms_succ, <- ap_comp.
      now apply weakening.
  Qed.

  Lemma substitution {γ δ: Dom} {ξ: Sub X} (wξ: ⟨ ξ : γ => δ ⟩) :
    ∀ {x: X}, ⟨ γ ⊢ x ⟩ → ⟨ δ ⊢ x[ξ] ⟩.
  Proof. intros; now apply (wsAp wξ). Qed.

  (* Lemma wsSubClosed_beta {δ} {ξ: Sub X} (wξ: ⟨ ξ : δ => 0 ⟩) : *)
  (*   ∀ i, δ ∋ i → ξ i = beta δ ξ i. *)
  (* Proof. *)
  (*   revert ξ wξ. *)
  (*   induction δ; intros ξ wξ i wi. *)
  (*   - crush. *)
  (*   - crush. *)
  (*     apply (IHδ (S >-> ξ)). *)
  (*     + intros j wj. *)
  (*       apply wξ. *)
  (*       now constructor. *)
  (*     + easy. *)
  (* Qed. *)

  Lemma wsClosed_invariant {Y} {vrY : Vr Y} {apXY : Ap X Y} {wsY : Ws Y} {wsApY : WsAp X Y} {x: X} (wx: ⟨ 0 ⊢ x ⟩) :
    ∀ (ξ: Sub Y), x[ξ] = x.
  Proof.
    intros.
    replace x with x[idm Y] at 2 by crush.
    eapply (wsApExt wx).
    inversion 1.
  Qed.

  Lemma closed_invar_sub {d1 d2 t0} (wt0: ⟨ 0 ⊢ t0 ⟩) :
    ∀ t1 ζ,
      t1 = t0[wkms d1] →
      ⟨ ζ : d1 => d2 ⟩ →
      t1[ζ] = t0[wkms d2].
  Proof.
    intros; subst. rewrite ap_comp.
    eapply (wsApExt wt0); inversion 1.
  Qed.

  Lemma wsSub_natural
    {f₁ f₂: Dom → Dom} {ξ₁ ξ₂: Sub X}
    (hyp: ∀ γ, WsSubNatural (f₁ γ) (f₂ γ) ξ₁ ξ₂) (ξ: Sub Ix) :
    ∀ (γ₁ γ₂ : Dom),
      ⟨ ⌈ξ⌉ >=> ξ₁ : γ₁ => f₁ γ₂ ⟩ →
      ⟨ ⌈ξ⌉ >=> ξ₂ : γ₁ => f₂ γ₂ ⟩.
  Proof.
    eapply wsSub_natural'.
    unfold WsSubNatural in *; crush.
    (* rewrite ap_vr in H; crush. *)
  Qed.

  Lemma wsSub_comp {γ₁ γ₂ γ₃: Dom} {ξ₁ ξ₂: Sub X} :
    WsSub γ₁ γ₂ ξ₁ → WsSub γ₂ γ₃ ξ₂ → WsSub γ₁ γ₃ (ξ₁ >=> ξ₂).
  Proof.
    unfold WsSub, comp; crush.
    eapply wsAp; eauto.
  Qed.
  Hint Resolve wsSub_comp : ws.

  Lemma wsSub_beta (γ δ: Dom) :
    ∀ (ξ: Sub X),
      ⟨ ξ : δ => γ ⟩ →
      ⟨ beta δ ξ : γ ∪ δ => γ ⟩.
  Proof. unfold WsSub; induction δ; crush. Qed.
  Hint Resolve wsSub_beta : ws.

  (* Lemma wsSubNatural_up (γ₁ γ₂: Dom) (ξ₁ ξ₂: Sub X) : *)
  (*   WsSubNatural γ₁ γ₂ ξ₁ ξ₂ → *)
  (*   WsSubNatural (S γ₁) (S γ₂) (ξ₁ ↑) (ξ₂ ↑). *)
  (* Proof. intros H i; destruct i; crush. Qed. *)
  (* Hint Resolve wsSubNatural_up : ws. *)

  (* Lemma wsSubNatural_ups (δ: Dom) : *)
  (*   ∀ (γ₁ γ₂: Dom) (f g: Sub X) (wfg: WsSubNatural γ₁ γ₂ f g), *)
  (*     WsSubNatural (γ₁ ∪ δ) (γ₂ ∪ δ) (f ↑⋆ δ) (g ↑⋆ δ). *)
  (* Proof. induction δ; crush. Qed. *)
  (* Hint Resolve wsSubNatural_ups : ws. *)

  Lemma wsSub_sub_beta1 γ t (wt: ⟨ γ ⊢ t ⟩) :
    ⟨ beta1 t : S γ => γ ⟩.
  Proof. apply (wsSub_beta γ 1); crush. Qed.
  Hint Resolve wsSub_sub_beta1 : ws.

  (* Lemma wsSubNatural_wks_id δ : *)
  (*   ∀ γ, WsSubNatural (γ ∪ δ) γ (wkms δ) (idm X). *)
  (* Proof. *)
  (*   unfold WsSubNatural; intros. *)
  (*   (* eapply wsi_wks. *) *)
  (*   rewrite ap_wks, ap_vr; simpl; eauto. *)
  (* Qed. *)
  (* Hint Resolve wsSubNatural_wks_id : wsi. *)

  (* Lemma wsiSub_comp_wkms δ ξ : *)
  (*   ∀ γ₁ γ₂, *)
  (*     WsSub γ₁ (γ₂ ∪ δ) (ξ >=> wkms δ) → *)
  (*     WsSub γ₁ γ₂        ξ. *)
  (* Proof. apply (wsSub_natural (wsSubNatural_wkl_id δ)). Qed. *)
  (* Hint Resolve wsiSub_comp_wkl : wsi. *)

  (* Lemma wsSub_natural *)
  (*   {f₁ f₂: Dom → Dom} {ξ₁ ξ₂: Ren} *)
  (*   (hyp: ∀ γ, WsSubNatural (f₁ γ) (f₂ γ) ξ₁ ξ₂) : *)
  (*   ∀ γ₁ γ₂ ζ, *)
  (*     WsSub γ₁ (f₁ γ₂) (sub_comp_ren ζ ξ₁) → *)
  (*     WsSub γ₁ (f₂ γ₂) (sub_comp_ren ζ ξ₂). *)
  (* Proof. unfold WsSub, sub_comp_ren in *; eauto using wsTm_natural. Qed. *)

  (* Lemma wsiSub_comp_wks' ζ δ γ₁ γ₂ : *)
  (*   WsSub γ₁ (γ₂ ∪ δ) (sub_comp_ren ζ (wks δ)) → *)
  (*   WsSub γ₁ γ₂       (sub_comp_ren ζ ren_id). *)
  (* Proof. apply (wsSub_natural (wsSubNatural_wks_id δ)). Qed. *)

  (* Lemma wsiSub_comp_wks ζ δ γ₁ γ₂ : *)
  (*   WsSub γ₁ (γ₂ ∪ δ) (sub_comp_ren ζ (wks δ)) → *)
  (*   WsSub γ₁ γ₂       ζ. *)
  (* Proof. *)
  (*   pose proof (wsiSub_comp_wks' ζ). *)
  (*   specialize (H δ γ₁ γ₂). crush. *)
  (* Qed. *)
  (* Hint Resolve wsiSub_comp_wks : wsi. *)

  (* Lemma wsiSub_comp_wks1 ζ γ₁ γ₂ : *)
  (*   WsSub γ₁ (S γ₂) (sub_comp_ren ζ (wks 1)) → *)
  (*   WsSub γ₁ γ₂     ζ. *)
  (* Proof. apply (wsiSub_comp_wks ζ 1). Qed. *)
  (* Hint Resolve wsiSub_comp_wks1 : wsi. *)

  (* Lemma wsTm_natural t : *)
  (*   ∀ γ δ ξ₁ ξ₂ (wξ: WsSubNatural γ δ ξ₁ ξ₂), *)
  (*     wsTm γ t[ξ₁] → wsTm δ t[ξ₂]. *)
  (* Proof. *)
  (*   induction t; cbn; intros γ δ ξ₁ ξ₂ wξ wt; *)
  (*     inversion wt; subst; cbn; constructor; crush. *)
  (* Qed. *)

  (* Lemma wsiTm_wks δ γ t : *)
  (*   wsTm (γ ∪ δ) (t[wks δ]) → wsTm γ t. *)
  (* Proof. *)
  (*   replace (wsTm γ t) with (wsTm γ (t[ren_id])). *)
  (*   apply wsTm_natural; auto with wsi. *)
  (*   crush. *)
  (* Qed. *)
  (* Hint Resolve wsiTm_wks : wsi. *)

  (* Lemma wsiTm_wks1 γ t : *)
  (*   wsTm (S γ) (t[wks 1]) → wsTm γ t. *)
  (* Proof. apply (wsiTm_wks 1). Qed. *)
  (* Hint Resolve wsiTm_wks1 : wsi. *)

End Stuff.


(* THIS FILE CONTAINS
   Lemmas that DO NOT depend on CompCert or Verifiable C,
   and that are used in the proof of the C program but are not
   used in the proof of functional_prog.v.
*)

Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import sha.SHA256.
Require Import VST.msl.Coqlib2.
Require Import VST.floyd.coqlib3.
Require Import VST.floyd.sublist.
Require Export sha.common_lemmas.
Require Import Lia.

Global Opaque CBLOCKz LBLOCKz.

Lemma Zlength_intlist_to_bytelist:
  forall l : list int,
       Zlength (intlist_to_bytelist l) = (Zlength l * 4)%Z.
Proof.
intros.
repeat rewrite Zlength_correct. rewrite length_intlist_to_bytelist.
rewrite Nat2Z.inj_mul. rewrite Z.mul_comm. reflexivity.
Qed.

Hint Rewrite Zlength_intlist_to_bytelist : sublist.
Hint Rewrite Zlength_intlist_to_bytelist : Zlength.

Lemma skipn_intlist_to_bytelist:
  forall i m, skipn (4*i) (intlist_to_bytelist m) = intlist_to_bytelist (skipn i m).
Proof.
induction i; intros.
reflexivity.
replace (4 * S i)%nat with (4 + 4 * i)%nat by lia.
destruct m; try reflexivity.
apply IHi.
Qed.

Lemma firstn_intlist_to_bytelist:
  forall i m, firstn (4*i) (intlist_to_bytelist m) = intlist_to_bytelist (firstn i m).
Proof.
induction i; intros.
reflexivity.
replace (4 * S i)%nat with (4 + 4 * i)%nat by lia.
destruct m; try reflexivity.
simpl. f_equal. f_equal. f_equal. f_equal.
apply IHi.
Qed.

Lemma sublist_intlist_to_bytelist:
 forall i j m,
  sublist (i * WORD) (j * WORD) (intlist_to_bytelist m) =
  intlist_to_bytelist (sublist i j m).
Proof.
intros.
unfold sublist.
change WORD with 4.
destruct (zlt j 0).
rewrite (Z2Nat_neg _ l).
rewrite (Z2Nat_neg (j*4)) by lia.
rewrite !skipn_nil.
reflexivity.
rewrite ?(Z.mul_comm _ 4).
rewrite (Z2Nat.inj_mul 4 j) by lia.
change (Z.to_nat 4) with 4%nat.
rewrite -> firstn_intlist_to_bytelist.
destruct (zlt i 0).
rewrite (Z2Nat_neg _ l).
rewrite (Z2Nat_neg (4*i)) by lia.
reflexivity.
rewrite ?Z2Nat.inj_mul by lia.
change (Z.to_nat 4) with 4%nat.
apply skipn_intlist_to_bytelist.
Qed.

Lemma bytelist_to_intlist_to_bytelist':
  forall nl: list byte,
  Nat.divide (Z.to_nat WORD) (length nl) ->
  intlist_to_bytelist (bytelist_to_intlist nl) = nl.
Proof.
intros nl [k H].
revert nl H; induction k; intros.
destruct nl; inv H; reflexivity.
simpl in H.
destruct nl as [ | a [ | b [ | c [ | d ?]]]]; inv H.
unfold bytelist_to_intlist; fold bytelist_to_intlist.
rewrite intlist_to_bytelist_bytes_to_int_cons by auto.
repeat f_equal; auto.
Qed.

Lemma Ndivide_Zdivide_length:
  forall {A} n (al: list A),
   0 <= n ->
   (Nat.divide (Z.to_nat n) (length al) <->
    (n | Zlength al)).
Proof.
intros; split; intros [i ?].
exists (Z.of_nat i). rewrite Zlength_correct, H0.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id; auto.
exists (Z.to_nat i).
rewrite Zlength_correct in H0.
destruct (zeq n 0). subst.
simpl. rewrite Z.mul_0_r in H0. destruct al; inv H0.
rewrite mult_0_r. reflexivity.
assert (0 <= i).
assert (0 <= i * n) by lia.
apply Z.mul_nonneg_cancel_r in H1; auto; lia.
rewrite <- (Z2Nat.id (i*n)%Z) in H0 by lia.
apply Nat2Z.inj in H0. rewrite H0.
rewrite Z2Nat.inj_mul; auto.
Qed.

Lemma bytelist_to_intlist_to_bytelist:
  forall nl: list byte,
  Z.divide WORD (Zlength nl) ->
  intlist_to_bytelist (bytelist_to_intlist nl) = nl.
Proof.
intros.
apply bytelist_to_intlist_to_bytelist'; auto.
apply Ndivide_Zdivide_length; auto.
compute; congruence.
Qed.

Lemma length_bytelist_to_intlist: forall n l,
       length l = (Z.to_nat WORD * n)%nat ->
       length (bytelist_to_intlist l) = n.
Proof.
induction n; intros.
destruct l; inv H; reflexivity.
replace (S n) with (1 + n)%nat in H by lia.
rewrite mult_plus_distr_l in H.
destruct l as [|i0 l]; [ inv H |].
destruct l as [|i1 l]; [ inv H |].
destruct l as [|i2 l]; [ inv H |].
destruct l as [|i3 l]; [ inv H |].
simpl. f_equal. apply IHn. forget (Z.to_nat WORD * n)%nat as A. inv H; auto.
Qed.

Lemma big_endian_integer4:
 forall c0 c1 c2 c3,
  big_endian_integer (c0::c1::c2::c3::nil) =
  Int.or (Int.shl (Int.repr (Byte.unsigned c0)) (Int.repr 24))
     (Int.or (Int.shl (Int.repr (Byte.unsigned c1)) (Int.repr 16))
   (Int.or (Int.shl (Int.repr (Byte.unsigned c2)) (Int.repr 8))
          (Int.repr (Byte.unsigned c3)))).
Proof.
intros.
unfold big_endian_integer.
simpl.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32) by reflexivity.
assert (32 < Int.max_unsigned) by (compute; auto).
autorewrite with testbit.
if_tac; simpl; auto;  try lia.
if_tac; simpl; auto; try lia.
if_tac; simpl; auto; try lia.
if_tac; simpl; auto; try lia.
if_tac; simpl; auto; try lia.
autorewrite with testbit; auto.
autorewrite with testbit; auto.
replace (i - 8 - 8) with (i-16) by lia.
rewrite orb_assoc. auto.
if_tac; simpl; auto; try lia.
autorewrite with testbit; auto.
replace (i - 8 - 8) with (i-16) by lia.
replace (i - 16 - 8) with (i-24) by lia.
repeat rewrite orb_assoc. auto.
Qed.

Local Open Scope nat.

Definition LBLOCK : nat := Z.to_nat LBLOCKz.
Definition CBLOCK : nat := Z.to_nat CBLOCKz.
Opaque LBLOCK CBLOCK.

Lemma LBLOCK_zeq: Z.of_nat LBLOCK = 16%Z.
Proof. reflexivity. Qed.

Lemma CBLOCK_zeq: (Z.of_nat CBLOCK = 64%Z).
Proof. reflexivity. Qed.

Lemma LBLOCKz_nonneg: (0 <= LBLOCKz)%Z.
Proof. change LBLOCKz with 16%Z; lia. Qed.
#[export] Hint Resolve LBLOCKz_nonneg : core.

Lemma LBLOCKz_pos: (0 < LBLOCKz)%Z.
Proof. change LBLOCKz with 16%Z; lia. Qed.
#[export] Hint Resolve LBLOCKz_pos : core.

Lemma CBLOCKz_nonneg: (0 <= CBLOCKz)%Z.
Proof. change CBLOCKz with 64%Z; lia. Qed.
#[export] Hint Resolve CBLOCKz_nonneg : core.

Lemma CBLOCKz_pos: (0 < CBLOCKz)%Z.
Proof. change CBLOCKz with 64%Z; lia. Qed.
#[export] Hint Resolve CBLOCKz_pos : core.

Local Open Scope Z.

Lemma divide_hashed:
 forall (bb: list int),
    Nat.divide LBLOCK (length bb) <->
    (LBLOCKz | Zlength bb).
Proof.
intros.
change LBLOCK with (Z.to_nat LBLOCKz).
apply Ndivide_Zdivide_length.
auto.
Qed.

Lemma hash_blocks_equation' : forall (r : registers) (msg : list int),
       hash_blocks r msg =
       match msg with
       | [] => r
       | _ :: _ => hash_blocks (hash_block r (firstn LBLOCK msg)) (skipn LBLOCK msg)
       end.
Proof. exact hash_blocks_equation. Qed.

Lemma CBLOCK_eq: CBLOCK=64%nat.
Proof. reflexivity. Qed.
Lemma LBLOCK_eq: LBLOCK=16%nat.
Proof. reflexivity. Qed.

Lemma hash_blocks_last:
 forall a bl c,
              Zlength a = 8 ->
              (LBLOCKz | Zlength bl) ->
              Zlength c = LBLOCKz ->
   hash_block (hash_blocks a bl) c = hash_blocks a (bl++ c).
Proof.
intros.
assert (POS: (0 < LBLOCK)%nat) by (rewrite LBLOCK_eq; lia).
apply divide_hashed in H0.
destruct H0 as [n ?].
rewrite Zlength_correct in H,H1.
change 8 with (Z.of_nat 8) in H.
change LBLOCKz with (Z.of_nat LBLOCK) in H1.
apply Nat2Z.inj in H.
apply Nat2Z.inj in H1.
revert a bl H H0; induction n; intros.
destruct bl; inv H0.
rewrite hash_blocks_equation'.
simpl. rewrite hash_blocks_equation'.
destruct c eqn:?. inv H1.
rewrite <- Heql in *; clear i l Heql.
rewrite firstn_same by lia.
replace (skipn LBLOCK c) with (@nil int).
rewrite hash_blocks_equation'; reflexivity.
pose proof (skipn_length c LBLOCK).
rewrite H1 in H0.
destruct (skipn LBLOCK c); try reflexivity; inv H0.
replace (S n * LBLOCK)%nat with (n * LBLOCK + LBLOCK)%nat  in H0 by
  (simpl; lia).
rewrite hash_blocks_equation'.
destruct bl.
simpl in H0.
Psatz.lia.
forget (i::bl) as bl'; clear i bl. rename bl' into bl.
rewrite IHn.
symmetry.
rewrite hash_blocks_equation.
destruct bl.
simpl in H0; Psatz.lia.
unfold app at 1; fold app.
forget (i::bl) as bl'; clear i bl. rename bl' into bl.
f_equal.
f_equal.
apply firstn_app1.
Psatz.nia.
apply skipn_app1.
Psatz.nia.
apply length_hash_block; auto. (* fixme *) change 16%nat with LBLOCK.
rewrite firstn_length. apply min_l.
Psatz.nia.
rewrite skipn_length.
apply plus_reg_l with LBLOCK.
rewrite plus_comm.
rewrite Nat.sub_add by Psatz.lia.
lia.
Qed.

Lemma length_hash_blocks: forall regs blocks,
  length regs = 8%nat ->
  (LBLOCKz | Zlength blocks) ->
  length (hash_blocks regs blocks) = 8%nat.
Proof.
intros.
destruct H0 as [n ?].
rewrite Zlength_correct in H0.
assert (POS := LBLOCKz_pos).
change LBLOCKz with (Z.of_nat LBLOCK) in *.
rewrite <- (Z2Nat.id n) in H0
 by (apply -> Z.mul_nonneg_cancel_r ; [ | apply POS]; lia).
rewrite <- Nat2Z.inj_mul in H0.
apply Nat2Z.inj in H0.
revert regs blocks H H0; induction (Z.to_nat n); intros.
  destruct blocks; inv H0.
rewrite hash_blocks_equation'; auto.
destruct blocks.
destruct LBLOCK; inv POS; inv H0.
rewrite hash_blocks_equation'; auto.
forget (i::blocks) as bb.
apply IHn0; auto.
apply length_hash_block; auto. (* fixme *) change 16%nat with LBLOCK.
rewrite firstn_length. apply min_l. simpl in H0. Psatz.nia.
rewrite skipn_length. rewrite H0; clear - POS.  simpl.
rewrite plus_comm. rewrite Nat.add_sub. auto.
Qed.

Theorem Zmod_mod_mult :
  forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
  Zmod (Zmod n (a * b)) b = Zmod n b.
Proof.
intros n a [|b|b] Ha Hb.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Z.lt_gt.
easy.
now elim Hb.
Qed.

Lemma generate_and_pad_lemma1:
  forall hashed (dd: list byte) hashed' (dd': list byte) pad bitlen
   (PAD : pad = 0 \/ dd' = [])
   (H0 : Zlength dd' + 8 <= CBLOCKz)
   (H1 : 0 <= pad < 8)
   (H4: (LBLOCKz | Zlength hashed))
   (H7 : ((Zlength hashed * 4 + Zlength dd) * 8)%Z = bitlen)
   (H3: Zlength dd < CBLOCKz)
   (H2 : (LBLOCKz | Zlength hashed'))
   (H5 : intlist_to_bytelist hashed' ++ dd' =
     intlist_to_bytelist hashed ++ dd ++ [Byte.repr 128] ++ repeat Byte.zero (Z.to_nat pad)),
   let lastblock :=
               (dd' ++
                repeat Byte.zero (Z.to_nat (CBLOCKz - 8 - Zlength dd')) ++
                intlist_to_bytelist [hi_part bitlen; lo_part bitlen])
   in let lastblock' :=
             bytelist_to_intlist lastblock
   in forall (H99: Zlength lastblock = CBLOCKz),
 generate_and_pad (intlist_to_bytelist hashed ++ dd) = hashed' ++ lastblock'.
Proof.
intros.
apply intlist_to_bytelist_inj.
rewrite intlist_to_bytelist_app.
unfold lastblock'.
rewrite bytelist_to_intlist_to_bytelist; auto.
2: rewrite H99; exists LBLOCKz; reflexivity.
unfold lastblock.
rewrite <- app_ass. rewrite H5.
unfold generate_and_pad.
rewrite intlist_to_bytelist_app.
rewrite bytelist_to_intlist_to_bytelist; auto.
*
repeat rewrite app_ass.
f_equal. f_equal. f_equal.
rewrite <- app_ass.
f_equal.
rewrite <- repeat_app.
f_equal.
clear - H5 H2 H1 H0 PAD.
assert (Zlength dd' <= 56) by (change CBLOCKz with 64 in H0; lia).
clear H0.
replace (Zlength (intlist_to_bytelist hashed ++ dd))
  with (4*Zlength hashed' + Zlength dd' - (1+pad)).
2:{
rewrite Z.mul_comm.
rewrite <-  Zlength_intlist_to_bytelist.
rewrite <- Zlength_app.
rewrite H5.
rewrite <- app_ass.
rewrite Zlength_app.
forget (Zlength (intlist_to_bytelist hashed ++ dd)) as B.
rewrite Zlength_app.
rewrite Zlength_cons, Zlength_nil, Zlength_correct.
rewrite repeat_length. rewrite Z2Nat.id by lia. lia.
}
change (Z.of_nat CBLOCK - 8) with 56.
clear H5.
rewrite <- Z2Nat.inj_add by (change CBLOCKz with 64; lia).
f_equal. {
 transitivity (- (4 * Zlength hashed' + (Zlength dd' - (1 + pad) + 9)) mod 64).
 f_equal. f_equal. lia.
 rewrite <- Z.sub_0_l.
 rewrite Zminus_mod.
 rewrite Zplus_mod.
 rewrite Z.mul_comm.
 destruct H2 as [a H2]; rewrite H2.
 rewrite <- Z.mul_assoc.
 change (LBLOCKz * 4)%Z with 64%Z.
 rewrite Zmult_mod.
 assert (64<>0) by (clear; lia).
 rewrite Z.mod_same by auto. rewrite Z.mul_0_r.
 rewrite Z.mod_0_l at 2 by auto.
 rewrite Z.add_0_l. rewrite Z.mod_mod by auto.
 replace (0 mod 64) with (64 mod 64) by reflexivity.
 change CBLOCKz with 64. change LBLOCKz with 16 in H2.
 destruct PAD; subst.
 rewrite <- Zminus_mod.
 rewrite Z.mod_small; try lia.
 rewrite Zlength_correct in H|-*; lia.
 rewrite Zlength_nil in *.
 rewrite <- Zminus_mod.
 rewrite Z.mod_small; lia.
}
 rewrite Zlength_app, Zlength_intlist_to_bytelist.
 rewrite H7.
 reflexivity.
*
 autorewrite with sublist.
 rewrite Zlength_repeat by (apply Z_mod_lt; compute; auto).
 forget ( Zlength hashed * 4 + Zlength dd) as d.
 change (Z.succ 0) with 1.
 change WORD with 4.
 rewrite Z.add_assoc.
 replace (d + 9) with (d + 1 + 8) by lia.
 forget (d+1) as e.
 apply Zmod_divide; try lia.
 clear.
 rewrite Zplus_mod.
 change 64 with (16*4)%Z.
 rewrite Zmod_mod_mult by lia.
 rewrite <- Z.sub_0_l.
 rewrite Zminus_mod.
 rewrite (Zplus_mod e 8).
 change (0 mod 4) with (4 mod 4).
 change (8 mod 4) with 0.
 rewrite Z.add_0_r.
  rewrite <- Zminus_mod.
  rewrite <- Zplus_mod.
 replace (e + (4 - e mod 4)) with (4 + (e - e mod 4)) by lia.
 rewrite Zplus_mod. rewrite Z.mod_same by lia.
 rewrite Zminus_mod.   rewrite Z.mod_mod by lia.
 rewrite Z.sub_diag. reflexivity.
Qed.


Require Import FunctionalExtensionality ProofIrrelevance JMeq.
Require Import Common Notations FEqualDep.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Ltac structures_eq_simpl_step_with tac := intros; simpl in *;
  match goal with
    | _ => reflexivity
    | [ |- (fun _ : ?A => _) = _ ] => apply functional_extensionality_dep; intro
    | [ |- (fun _ : ?A => _) == _ ] => apply (@functional_extensionality_dep_JMeq A); intro
    | [ |- (forall _ : ?A, _) = _ ] => apply (@forall_extensionality_dep A); intro
    | _ => tac
  end; simpl; JMeq_eq.

Ltac structures_eq_step_with_tac structures_equal_tac tac := intros; simpl in *;
  match goal with
    | _ => reflexivity
    | [ |- _ = _ ] => expand; structures_equal_tac
    | [ |- _ == _ ] => expand; structures_equal_tac
    | _ => structures_eq_simpl_step_with tac
  end.

Ltac structures_eq_step_with structures_equal_lemma tac := structures_eq_step_with_tac ltac:(apply structures_equal_lemma) tac.


(** * RIS.alternate_eq : equivalent definitions of alpha-equivalence. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Export transducer.
Section s.
  Context {atom X: Set}{𝐀 : Atom atom} {𝐗 : Alphabet 𝐀 X}.

  (** * Alternative definition of alpha-equivalence *)
  (** ** Main results *)

  (** We introduce a new notion of alpha-equivalence. We just replaced the rule [αα] with the new [αα']. *)
  Reserved Notation " u ≡' v " (at level 80).
  Inductive αequiv' : word -> word -> Prop :=
  | αt' u v w : u ≡' v -> v ≡' w -> u ≡' w
  | αε' : [] ≡' []
  | αr' u v l : u ≡' v -> u++[l] ≡' v++[l]
  | αl' u v l : u ≡' v -> l::u ≡' l::v
  | αα' a b u : b #α u -> a #α u -> u ≡' [(a,b)]∙u
  where " u ≡' v " := (αequiv' u v).
  Hint Constructors αequiv'.

  (** Since we already know that [αα'] is admissible, and since we can prove that [αα] is an instance of [αα'], we get that the new definition of alpha-equivalence defines the same relation as [≡]. *)
  Theorem equiv_alt u v : u ≡ v <-> u ≡' v.
  Proof.
    split;intro E;induction E;reflexivity||eauto.
    - replace (⟨b :: [(a, b)] ∙ u ++ [b⟩])
        with ([(a, b)] ∙ (⟨a :: u ++ [a⟩])).
      + apply αα'.
        * unfold fresh__α in *.
          rewrite 𝗙_cons,𝗙_add;simpl;rewrite H.
          destruct_eqX b a;simpl;reflexivity.
        * unfold balanced,fresh__α in *.
          rewrite 𝗙_cons,𝗙_add;simpl;simpl_beq.
          destruct (𝗙 a u) as ((m&n)&p);simpl in H0;rewrite d_binding_simpl in H0.
          destruct H0 as (->&->).
          destruct n;reflexivity.
      + rewrite act_lists_cons,act_lists_app.
        f_equal;[|f_equal];repeat (unfold act;simpl;f_equal);simpl_beq;auto.
    - apply αr,IHE.
    - apply αl,IHE.
    - apply αequiv_αfresh_transpose.
      intros c F;unfold act;simpl.
      destruct_eqX c a;[|destruct_eqX c b];subst;tauto.
  Qed.

  (** ** Additional properties *)
  Global Instance αequiv'_equivalence : Equivalence αequiv'.
  Proof.
    split;intro;intros;rewrite <- equiv_alt in *.
    - reflexivity.
    - symmetry;auto.
    - etransitivity;eauto.
  Qed.

  Lemma αequiv'_app_left u v w : u ≡' v -> w++u≡'w++v.
  Proof. intro E;induction w;simpl;auto. Qed.

  Lemma αequiv'_app_right (u v w : word) : u ≡' v -> u++w≡'v++w.
  Proof.
    intro E;revert w;induction w using rev_induction;simpl;auto.
    + repeat rewrite app_nil_r;auto.
    + repeat rewrite <- app_ass; apply αr';auto.
  Qed.

  Global Instance αequiv'_app :
    Proper (αequiv' ==> αequiv' ==> αequiv') (@app letter).
  Proof.
    intros u1 v1 E1 u2 v2 E2.
    transitivity (u1++v2).
    - apply αequiv'_app_left;auto.
    - apply αequiv'_app_right;auto.
  Qed.

  Lemma αequiv'_binding u v : u ≡' v -> forall a, 𝗙 a u = 𝗙 a v.
  Proof. intros E a;apply αequiv_binding,equiv_alt,E. Qed.

  Lemma αequiv'_perm u v π : u ≡' v -> π ∙ u ≡' π ∙ v.
  Proof. intros E;apply equiv_alt,αequiv_perm,equiv_alt,E. Qed.

  (** * Alpha-equivalence from "Leaving the nest" *)
  (** In earlier work by Gabbay, Ghica and Petrisan an alternative definition of alpha-equivalence was used. We show here that it is equivalent with our definition. *)

  Reserved Notation " u =α= v " (at level 80).
  Inductive αequiv2 : word -> word -> Prop :=
  | αε2 : [] =α= []
  | αm u v l : u =α= v -> u++[l] =α= v++[l]
  | αα2 a b u1 u2 v1 v2 :
      a ⋄ u2 -> b ⋄ v2 ->
      (forall c, c # a -> c # b -> c # u1++u2++v1++v2 ->
            u1++open c::[(a,c)]∙u2 =α= v1++open c::[(b,c)]∙v2)
      -> u1++open a::u2++[close a] =α= v1++open b::v2++[close b]
  where " u =α= v " := (αequiv2 u v).
  Hint Constructors αequiv2.

  Remark αequiv_alternate u1 u2 v1 v2 a b c :
    c #α u2 -> c #α v2 -> a ⋄ u2 -> b ⋄ v2 ->
    u1++open c::[(a,c)]∙u2 ≡ v1++open c::[(b,c)]∙v2 ->
    u1++open a::u2++[close a] ≡ v1++open b::v2++[close b].
  Proof.
    intros f1 f2 b1 b2 E.
    transitivity  (u1 ++ open c :: [(a, c)] ∙ u2 ++ [close c]).
    - apply αequiv_app_left.
      apply αα;auto.
    - transitivity  (v1 ++ open c :: [(b, c)] ∙ v2 ++ [close c]).
      + repeat rewrite app_comm_cons,<- app_ass.
        apply αr,E.
      + apply αequiv_app_left.
        symmetry;apply αα;auto.
  Qed.

  Lemma αequiv2_to_αequiv u v : u =α= v -> u≡v.
  Proof.
    intro E;induction E;auto.
    - reflexivity.
    - apply αr,IHE.
    - destruct (exists_fresh (a :: b :: ⌊ u1 ++ u2 ++ v1 ++ v2 ⌋)) as (c & I).
      repeat rewrite support_list_app in I;simpl_In in I.
      apply αequiv_alternate with (c:=c);auto.
      + apply αfresh_support;tauto.
      + apply αfresh_support;tauto.
      + apply H2.
        * simpl;tauto.
        * simpl;tauto.
        * repeat rewrite support_list_app;simpl_In;tauto.
  Qed.

  Lemma αequiv_to_αequiv2 u v : u≡v -> u =α= v.
  Proof.
    rewrite completeness.
    revert v;induction u as [|l u IHu] using len_rev_induction;intros v' (s&P&A).
    - inversion P;auto.
    - pose proof P as P0;apply path_letter in P as (v&l'&s'&->&P&hs).
      unfold step in hs;destruct l as [a|a|x];destruct l' as [b|b|y];try tauto.
      + subst;apply Accepting_cons in A as (A&E);simpl in E;inversion E;clear E;subst.
        apply αm,IHu;[|exists s'];auto.
      + destruct hs as (hs&->);destruct_eqX a b.
        * subst;apply αm,IHu;[|exists s';split];auto.
          case_in (b,b) s'.
          -- apply decomposition in I as (m1&m2&->&I).
             rewrite rmfst_in in A;repeat rewrite map_app in *;simpl;auto.
             apply length_app in A as (->&->);[|repeat rewrite map_length];reflexivity.
          -- rewrite rmfst_notin in A;auto.
        * destruct (path_stack_decompose P N hs) as (u1&u2&v1&v2&->&->&L&B1&B2).
          repeat rewrite app_ass;apply αα2;auto.
          intros c I1 I2 I3;apply IHu.
          -- rewrite app_length,app_length;simpl;rewrite (act_lists_length _ u2);auto.
          -- pose proof I3 as Ic;repeat rewrite support_list_app in Ic;simpl in Ic;simpl_In in Ic.
             assert (E1:u1 ++ open a :: u2 ++ [close a] ≡ u1 ++ open c :: [(a,c)]∙ u2 ++ [close c] )
               by (apply αequiv_app_left,αα;auto;apply αfresh_support;tauto).
             assert (E2:v1 ++ open b :: v2 ++ [close b] ≡ v1 ++ open c :: [(b,c)]∙v2 ++ [close c] )
               by (apply αequiv_app_left,αα;auto;apply αfresh_support;tauto).
             repeat rewrite app_comm_cons,<-app_ass in *.
             symmetry in E1;apply αequiv_path in E1 as (s1&P1&A1);apply αequiv_path in E2 as (s2&P2&A2).
             assert (E0 : prj2 (@nil (atom*atom)) = prj1(@nil (atom*atom))) by reflexivity.
             assert (E1 : prj2 (@nil (atom*atom)) = prj1([]⋈@nil (atom*atom))) by reflexivity.
             pose proof (path_mix E0 P1 P0) as (E4&P4).
             pose proof (path_mix E1 P4 P2) as (E5&P3).
             unfold mix in P3 at 1;simpl in P3; clear E0 E1.
             apply path_letter in P3 as (?&?&s4&E&P3&P5);simpl_words;subst.
             eexists;split;eauto.
             clear P P0 P1 P2 P3 P4 IHu Ic B1 B2 N hs.
             set (t := prj1 s1).
             replace s1 with (t ⊗ t) in * by (unfold t;rewrite A1 at 2;symmetry;apply combine_split).
             replace (s'⊖(a,b)) with (t ⊗ t) in *
               by (etransitivity;[|symmetry;apply combine_split];rewrite <-A,<-E4,combine_snd;auto).
             unfold mix in E5,P5;rewrite combine_fst,(@combine_snd _ _ t t) in E5,P5;auto.
             rewrite combine_snd in E5;rewrite combine_fst in P5;auto.
             replace s2 with (t⊗t) in * by (rewrite (@combine_split _ _ s2),<-A2,E5;auto).
             clear A1 A E4 E5 A2;rewrite combine_snd in P5;auto.
             destruct P5 as ([(_&A')|(m1&m2&E&A')]&E').
             ++ rewrite (rmfst_absent A') in E';subst.
                rewrite combine_fst,combine_snd;auto.
             ++ subst;rewrite (rmfst_present _ A') in E'.
                rewrite Accepting_app,Accepting_cons_refl,<-Accepting_app.
                rewrite <- E';apply Accepting_combine.
      + destruct hs as (->&p&->&hs).
        replace (p∙x) with x.
        * apply αm,IHu;[|exists s'];auto.
        * symmetry;apply action_invariant,map_eq_id;intros a I.
          apply hs in I;apply paired_Accepting in I;auto.
  Qed.
End s.