(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

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

Set Implicit Arguments.

Require Import List.
Require Import more_list.
Require Import equiv_list.
Require Import Relations.
Require Import Arith.
Require Import Setoid.
Require Import decidable_set.

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

Lemma permut_nil :
  forall (A B : Set) (R : A -> B -> Prop) l, permut0 R l nil -> l = nil.
Proof.
intros A B R l P; inversion P as [ | a b l' l1 l2 a_R_b P']; trivial.
destruct l1; discriminate.
Qed.

Lemma permut_impl :
  forall (A B : Set) (R R' : A -> B -> Prop) l1 l2,
  (forall a b, R a b -> R' a b) -> permut0 R l1 l2 -> permut0 R' l1 l2.
Proof.
intros A B R R' l1; induction l1 as [ | a1 l1]; intros l2 Compat P;
inversion P as [ | a b k k1 k2 a_R_b Q]; subst.
apply Pnil.
apply Pcons.
apply Compat; trivial.
apply IHl1; trivial.
Qed.

Lemma permut_strong :
  forall (A B : Set) (R : A -> B -> Prop) a1 a2 l1 k1 l2 k2,
  R a1 a2 -> permut0 R (l1 ++ k1) (l2 ++ k2) ->
  permut0 R (l1 ++ a1 :: k1) (l2 ++ a2 :: k2).
Proof.
intros A B R a1 a2 l1; induction l1 as [ | 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]; clear P; subst.
destruct (split_list _ _ _ _ H1) as [H' | H']; clear H1.
destruct H' as [l [H1 H2]]; subst; simpl.
assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) (l2 ++ a2 :: l) k' b1_R_b2).
do 2 rewrite <- ass_app in Q'; simpl in Q'; apply Q'.
apply IHl1; trivial.
rewrite ass_app; trivial.
destruct H' as [l [H1 H2]]; subst; simpl.
destruct l as [ | u l].
simpl in H2; subst k2; rewrite <- app_nil_end.
assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) (k ++ a2 :: nil) k' b1_R_b2).
do 2 rewrite <- ass_app in Q'; simpl in Q'; apply Q'.
apply IHl1; trivial.
simpl in H2; injection H2; clear H2; intros H2 b2_eq_u; subst u k'.
assert (Q' := @Pcons _ _ R u1 b2 (l1 ++ a1 :: k1) k (l ++ a2 :: k2) b1_R_b2).
rewrite <- ass_app; simpl; apply Q'.
rewrite ass_app; apply IHl1; trivial.
rewrite <- ass_app; trivial.
Qed.

Lemma permut_inv_left_strong :
  forall (A B : Set) (R : A -> B -> Prop) a l1' l1'' l2,
  permut0 R (l1' ++ a :: l1'') l2 -> exists b, exists l2', exists l2'',
   (R a b /\ l2 = l2' ++ b :: l2'' /\ permut0 R (l1' ++ l1'') (l2' ++ l2'')).
Proof.
intros A B R a l1'; generalize a; clear a;
induction l1' as [ | a1 l1']; intros a l1'' l2 P.
inversion P as [ | a' b l' l2' l2'' a_R_b Q H]; clear P; subst.
exists b; exists l2'; exists l2''; repeat split; trivial.
inversion P as [ | a1' b l' l2' l2'' a1_R_b Q H]; clear P; subst.
destruct (IHl1' _ _ _ Q) as [b' [k2' [k2'' [a_R_b' [H Q']]]]]; clear Q.
destruct (split_list _ _ _ _ H) as [H' | H']; clear H.
destruct H' as [[ | b'' l] [H1 H2]]; simpl in *; subst.
exists b'; exists (k2' ++ b :: nil); exists k2''; repeat split; trivial.
rewrite <- app_nil_end; rewrite <- ass_app; simpl; trivial.
rewrite <- ass_app; simpl; apply Pcons; trivial.
injection H2; clear H2; intros; subst.
exists b''; exists k2'; exists (l ++ b :: l2''); repeat split; trivial.
rewrite <- ass_app; simpl; trivial.
rewrite ass_app; apply Pcons; trivial; rewrite <- ass_app; trivial.
destruct H' as [l [H1 H2]]; subst.
exists b'; exists (l2' ++ b :: l); exists k2''; repeat split; trivial.
rewrite <- ass_app; simpl; trivial.
rewrite <- ass_app.
do 2 rewrite <- app_comm_cons; apply Pcons; trivial; rewrite ass_app; trivial.
Qed.

Lemma permut_inv_right :
  forall (A : Set) (R : relation A) b l1 l2,
  permut0 R l1 (b :: l2) -> exists a, exists l1', exists l1'',
   (R a b /\ l1 = l1' ++ a :: l1'' /\ permut0 R (l1' ++ l1'') l2).
Proof.
intros A R b l1; generalize b; clear b;
induction l1 as [ | a1 l1]; intros b l2 P;
inversion P as [ | a b' l' l1' l2' a_R_b' Q H]; subst.
destruct l1' as [ | a1' l1']; injection H1; clear H1; intros; subst.
exists a1; exists (@nil A); exists l1; repeat split; trivial.
simpl in Q; destruct (IHl1 _ _ Q) as [a [k1' [k1'' [a_R_b [H Q']]]]]; subst.
exists a; exists (a1 :: k1'); exists k1''; repeat split; trivial.
simpl; apply (@Pcons _ _ R a1 b' (k1' ++ k1'') l1' l2'); trivial.
Qed.

Lemma permut_inv_right_strong :
  forall (A B : Set) (R : A -> B -> Prop) b l1 l2' l2'',
  permut0 R l1 (l2' ++ b :: l2'') -> exists a, exists l1', exists l1'',
   (R a b /\ l1 = l1' ++ a :: l1'' /\ permut0 R (l1' ++ l1'') (l2' ++ l2'')).
Proof.
intros A B R b l1; generalize b; clear b;
induction l1 as [ | a1 l1]; intros b l2' l2'' P;
inversion P as [ | a b' l' l1' k2 a_R_b' Q H]; subst.
destruct l2'; discriminate.
destruct (in_in_split_set _ _ _ _ _ _ H1) as [[H2' | H2'] | H2']; clear H1.
destruct H2' as [l [H2 H3]]; subst.
rewrite <- ass_app in Q; simpl in Q;
destruct (IHl1 b _ _ Q) as [a [l1' [l1'' [a_R_b [H Q']]]]]; subst.
exists a; exists (a1 :: l1'); exists l1''; repeat split; trivial.
simpl; rewrite ass_app; apply Pcons; trivial.
rewrite <- ass_app; trivial.
destruct H2' as [l [H2 H3]]; subst.
rewrite ass_app in Q.
destruct (IHl1 b _ _ Q) as [a [k1' [k1'' [a_R_b [H Q']]]]]; subst.
exists a; exists (a1 :: k1'); exists k1''; repeat split; trivial.
rewrite <- ass_app; simpl; apply Pcons; trivial.
rewrite ass_app; trivial.
destruct H2' as [b'_eq_b [H2 H3]]; subst.
exists a1; exists (@nil A); exists l1; repeat split; trivial.
Qed.

Lemma permut_rev :
  forall (A B : Set) (R : A -> B -> Prop) l1 l2, permut0 R l1 l2 ->
  permut0 (fun b a => R a b) l2 l1.
Proof.
intros A B R l1; induction l1 as [ | a1 l1]; intros l2 P;
inversion P as [ | a b l1' l2' l2'' a_R_b Q]; subst.
apply Pnil.
apply (@permut_strong B A (fun b a => R a b) b a1 l2' l2'' (@nil _) l1); trivial.
simpl; apply IHl1; trivial.
Qed.

(** Permutation is compatible with length. *)
Lemma permut_length :
  forall (A : Set) (R : relation A) l1 l2, permut0 R l1 l2 -> length l1 = length l2.
Proof.
intros A R l; induction l as [ | a l]; intros l' P; inversion P; trivial.
subst.
rewrite length_app; simpl; rewrite plus_comm; simpl; rewrite plus_comm.
rewrite <- length_app; rewrite (IHl (l1 ++ l2)); trivial.
Qed.

Lemma permut_refl :
   forall (A : Set) (R : relation A) l,
  (forall a, In a l -> R a a) -> permut0 R l l.
Proof.
intros A R l refl_R; induction l as [ | a l].
apply Pnil.
apply (@Pcons _ _ R a a l nil l).
apply refl_R; left; trivial.
simpl; apply IHl; intros; apply refl_R; right; trivial.
Qed.

Lemma permut_sym :
  forall (A : Set) (R : relation A) l1 l2,
   (forall a b, In a l1 -> In b l2 -> R a b -> R b a) ->
   permut0 R l1 l2 -> permut0 R l2 l1.
Proof.
intros A R l1; induction l1 as [ | a1 l1]; intros l2 sym_R P;
inversion P as [ | a b l1' l2' l2'' a_R_b Q]; subst.
apply Pnil.
apply (permut_strong (R := R) b a1 l2' l2'' (@nil A) l1).
apply sym_R; trivial; [left | apply in_or_app; right; left]; trivial.
simpl; apply IHl1; trivial.
intros; apply sym_R; trivial; [right | apply in_insert]; trivial.
Qed.

Lemma permut_trans :
  forall (A : Set) (R : relation A) 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) ->
   permut0 R l1 l2 -> permut0 R l2 l3 -> permut0 R l1 l3.
Proof.
intros A R l1 l2; generalize l1; clear l1;
induction l2 as [ | a2 l2]; intros l1 l3 trans_R P1 P2.
inversion_clear P2; trivial.
destruct (permut_inv_right P1) as [a1 [l1' [l1'' [a1_R_a2 [H Q1]]]]]; subst l1.
inversion P2 as [ | a2' a3 l2' l3' l3'' a2_R_a3 Q2]; subst.
apply permut_strong.
apply trans_R with a2; trivial.
apply in_or_app; right; left; trivial.
left; trivial.
apply in_or_app; right; left; trivial.
apply IHl2; trivial.
intros a b c; intros; apply trans_R with b; trivial.
apply in_insert; trivial.
right; trivial.
apply in_insert; trivial.
Qed.

Lemma permut_cons_inside :
  forall (A B : Set) (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 -> permut0 R (a :: l) (l1 ++ b :: l2) -> permut0 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'']; 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_insert; rewrite <- H1; apply in_or_app; right; left; trivial.
Qed.

Lemma permut_add_inside :
   forall (A B : Set) (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 -> permut0 R (l1 ++ a :: l1') (l2 ++ b :: l2') -> permut0 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 (in_in_split_set _ _ _ _ _ _ H) as [[H' | H'] | H']; clear H.
destruct H' as [l [H1 H2]]; subst.
rewrite ass_app in P'.
destruct (permut_inv_right_strong (R := R) _ _ _ P') as [a' [k1' [k1'' [a'_R_b' [H P'']]]]].
rewrite H; rewrite <- ass_app; simpl; apply permut_strong.
apply trans_R with b a; trivial.
apply in_insert; rewrite H; apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; left; apply in_or_app; right; left; trivial.
rewrite ass_app; trivial.
destruct H' as [l [H1 H2]]; subst.
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; rewrite ass_app; simpl; apply permut_strong.
apply trans_R with b a; trivial.
apply in_insert; rewrite H; apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; right; left; trivial.
apply in_or_app; right; right; apply in_or_app; right; left; trivial.
rewrite <- ass_app; trivial.
destruct H' as [H1 [H2 H3]]; subst; trivial.
Qed.

Lemma exists_dec :
  forall (A : Set) (P : A -> Prop) (l : list A),
  (forall a, In a l -> {P a}+{~P a}) ->
  {a | In a l /\ P a}+{~exists a, In a l /\ P a}.
Proof.
intros A P l P_dec; induction l as [ | a l].
right; intros [a [a_in_nil _]]; absurd (In a nil); auto.
destruct (P_dec a) as [Pa | not_Pa].
left; trivial.
left; exists a; split; trivial; left; trivial.
destruct IHl as [Ok | Ko].
intros; apply P_dec; right; trivial.
destruct Ok as [b [b_in_l P_b]].
left; exists b; split; trivial; right; trivial.
right; intros [b [[b_eq_a | b_in_l] Pb]].
subst; apply not_Pa; trivial.
apply Ko; exists b; split; trivial.
Defined.

Fixpoint split_all (A : Set) (l : list A) : list (A * (list A * list A)) :=
  match l with
  | nil => @nil _
  | a :: l =>
    (a,(@nil _, l)) ::
    (map (fun bl' => match bl' with (b,(l',l'')) => (b, (a :: l',l'')) end) (split_all l))
    end.

Lemma split_all_is_sound :
  forall (A : Set) (l  : list A) b l' l'', In (b,(l',l'')) (split_all l) <-> l = l' ++ b :: l''.
Proof.
intros A l; induction l as [ | a l]; intros b l' l''.
split; intro H.
contradiction.
destruct l'; discriminate.
simpl; split; intro H.
rewrite in_map_iff in H; destruct H as [ H | H ].
injection H; intros; subst; trivial.
destruct H as [[c [k' k'']] [H H']].
injection H; intros; subst.
simpl; apply (f_equal (fun l => a :: l)).
rewrite <- (IHl b k' l''); trivial.
rewrite in_map_iff; destruct l' as [ | a' l'];
simpl in H; injection H; intros; subst.
left; trivial.
right; exists (b,(l',l'')); split; trivial.
rewrite (IHl b l' l''); trivial.
Qed.

Lemma permut_dec :
  forall (A B : Set) (R : A -> B -> Prop),
          forall l1 l2, (forall a1 a2, In a1 l1 -> In a2 l2 -> {R a1 a2}+{~R a1 a2}) ->
         {permut0 R l1 l2}+{~permut0 R l1 l2}.
Proof.
intros A B R l1; induction l1 as [ | a1 l1]; intros l2 R_dec.
destruct l2 as [ | a2 l2].
left; apply Pnil.
right; intro P; inversion P.
assert (P_dec : forall a : B * (list B * list B),
  In a (split_all l2) ->
  {(fun bll' : B * (list B * list B) =>
    let (b, y) := bll' in let (l, l') := y in R a1 b /\ permut0 R l1 (l ++ l'))
     a} +
  {~
   (fun bll' : B * (list B * list B) =>
    let (b, y) := bll' in let (l, l') := y in R a1 b /\ permut0 R l1 (l ++ l'))
     a}).
intros [b [l l']] H; rewrite split_all_is_sound in H.
destruct (R_dec a1 b) as [a1_R_b | not_a1_R_b].
left; trivial.
subst l2; apply in_or_app; right; left; trivial.
destruct (IHl1 (l ++ l')) as [P | not_P].
intros; apply R_dec.
right; trivial.
subst l2; apply in_insert; trivial.
left; split; trivial.
right; intros [_ P]; apply not_P; trivial.
right; intros [a1_R_b _]; apply not_a1_R_b; trivial.

assert (H := list_exists_rest_is_sound
                       (fun bll' =>
                           match bll' with
                           | (b,(l,l')) => R a1 b /\ permut0 R l1 (l ++ l')
                           end) (split_all l2) P_dec).
destruct (list_exists_rest
      (fun bll' : B * (list B * list B) =>
       let (b, y) := bll' in
       let (l, l') := y in R a1 b /\ permut0 R l1 (l ++ l')) (split_all l2) P_dec).
left.
destruct ((proj1 H) (refl_equal _)) as [[b [l l']] [H' [a1_R_b P]]].
rewrite split_all_is_sound in H'; subst l2; apply Pcons; trivial.
right; intro P; inversion P; subst.
assert (false = true).
rewrite H; exists (b,(l0,l3)); split; trivial.
rewrite split_all_is_sound; trivial.
split; trivial.
discriminate.
Defined.

Lemma permut_map :
  forall (A B A' B': Set) (R : A -> B -> Prop) (R' : A' -> B' -> Prop) (f1 : A -> A') (f2 : B -> B')
  l1 l2, (forall a b, In a l1 -> In b l2 -> R a b -> R' (f1 a) (f2 b)) ->
  permut0 R l1 l2 -> permut0 R' (map f1 l1) (map f2 l2).
Proof.
intros A B A' B' R R' f1 f2 l1; induction l1 as [ | a1 l1];
intros l2 Compat P; inversion P as [ | a' b l1' l2' l2'' a_R_b P' H]; subst.
simpl; apply Pnil.
rewrite map_app; simpl; apply Pcons.
apply Compat; trivial.
left; trivial.
apply in_or_app; right; left; trivial.
rewrite <- map_app; apply IHl1; trivial.
intros a b' a_in_l1 b'_in_l2; apply Compat.
right; trivial.
apply in_insert; trivial.
Qed.

Lemma permut_length_1:
  forall (A B : Set) (R : A -> B -> Prop) a b, permut0 R (a :: nil) (b :: nil)  -> R a b.
Proof.
intros A B R a b P; inversion P as [ | a' b' l' l1' l2' a_R_b' P' H1 H']; subst.
destruct l1' as [ | a1' [ | b1' l1']].
injection H'; intros; subst; trivial.
discriminate.
discriminate.
Qed.

Lemma permut_length_2 :
 forall (A B : Set) (R : A -> B -> Prop) a1 b1 a2 b2,
    permut0 R (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
    (R a1 a2 /\ R b1 b2) \/ (R a1 b2 /\ R b1 a2).
Proof.
intros A B R a1 b1 a2 b2 P;
inversion P as [ | a b l l1 l2 a_R_b P' H1 H']; subst.
destruct l1 as [ | c1 l1].
destruct l2 as [ | c2 [ | d2 l2]].
discriminate.
injection H'; intros; subst.
left; split; trivial.
apply (permut_length_1 P').
discriminate.
destruct l1 as [ | d1 l1].
destruct l2 as [ | c2 l2].
injection H'; intros; subst.
right; split; trivial.
apply (permut_length_1 P').
discriminate.
destruct l1; discriminate.
Qed.

Lemma permut_size :
  forall (A B : Set) (R : A -> B -> Prop) size size' l1 l2,
  (forall a a', In a l1 -> In a' l2 -> R a a' -> size a = size' a') ->
  permut0 R l1 l2 -> list_size size l1 = list_size size' l2.
Proof.
intros A B R size size' l1; induction l1 as [ | a1 l1 ]; intros l2 E P;
inversion P as [ | a b l1' l2' l2'' a_R_b P']; subst; trivial.
rewrite list_size_app; simpl.
rewrite (E a1 b); trivial.
rewrite (IHl1 (l2' ++ l2'')); trivial.
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_insert; trivial.
left; trivial.
apply in_or_app; right; left; trivial.
Qed.

Lemma in_permut_in :
   forall (A : Set) l1 l2, permut0 (@eq A) l1 l2 -> (forall a, In a l1 <-> In a l2).
Proof.
assert (H : forall (A : Set) l1 l2, permut0 (@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.
apply permut_sym; trivial; intros; subst; trivial.
Qed.

(** Permutation is compatible with append. *)
Lemma permut_app :
  forall (A B : Set) (R : A -> B -> Prop) l1 l1' l2 l2',
   permut0 R l1 l2 -> permut0 R l1' l2' -> permut0 R (l1 ++ l1') (l2 ++ l2').
Proof.
intros A B R l1; induction l1 as [ | a1 l1];
intros l1' l2 l2' P P'.
inversion_clear P; trivial.
inversion P as [ | a b l1'' l2'' l2''' a_R_b Q]; subst.
simpl; rewrite <- ass_app; simpl; apply Pcons; trivial.
rewrite ass_app; apply IHl1; trivial.
Qed.

Lemma permut_swapp :
  forall (A B : Set) (R : A -> B -> Prop) l1 l1' l2 l2',
   permut0 R l1 l2 -> permut0 R l1' l2' -> permut0 R (l1 ++ l1') (l2' ++ l2).
Proof.
intros A B R l1; induction l1 as [ | a1 l1];
intros l1' l2 l2' P P'.
inversion_clear P; rewrite <- app_nil_end; trivial.
inversion P as [ | a b l1'' l2'' l2''' a_R_b Q]; subst.
simpl; rewrite ass_app; apply Pcons; trivial.
rewrite <- ass_app; apply IHl1; trivial.
Qed.

Instance equivalence_coercion (A : Set) (R : relation A) (E : equivalence _ R) : Equivalence R.
revert E;intros [E1 E2 E3].
split; assumption.
Qed.

Lemma permut_app1 :
  forall (A : Set) (R : relation A), equivalence _ R ->
  forall l l1 l2, permut0 R l1 l2 <-> permut0 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 : Set) (R : relation A), equivalence _ R ->
  forall l l1 l2, permut0 R l1 l2 <-> permut0 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.

Lemma permut_list_exists :
  forall  (A B : Set) (R : A -> B -> Prop) f f',  (forall t t', R t t' -> f t = f' t') ->
  forall l l', permut0 R l l' -> list_exists f l = list_exists f' l'.
Proof.
intros A B R f f' E l; induction l as [ | a l]; simpl; intros l' P;
inversion P as [ | a' b l1 l2' l2'' a_R_b Q]; subst; simpl; trivial.
rewrite list_exists_app; simpl.
rewrite (E _ _ a_R_b).
destruct (f' b); simpl.
destruct (list_exists f' l2'); simpl; trivial.
rewrite <- list_exists_app; apply IHl; trivial.
Qed.

Lemma permut_list_forall_exists :
  forall (A B A' B': Set) (R : A -> B -> Prop) (R' : A' -> B' -> Prop) f f',
  (forall ta ta' tb tb', R ta tb -> R' ta' tb' -> f ta ta' = f' tb tb') ->
  forall la la' lb lb',  permut0 R la lb -> permut0 R' la' lb' ->
  list_forall (fun t1 => list_exists (fun t2 => f t1 t2) la') la =
  list_forall (fun t1 => list_exists (fun t2 => f' t1 t2) lb') lb.
Proof.
intros A B A' B' R R' f f' E la; induction la as [ | a la];
intros la' lb lb' P P';
inversion P as [ | a' b k1 k2' k2'' a_R_b Q]; subst; simpl; trivial.
rewrite list_forall_app; simpl.
rewrite (IHla la' (k2' ++ k2'') lb' Q P').
rewrite list_forall_app; simpl.
assert (E' : forall (t : A') (t' : B'), R' t t' -> f a t = f' b t').
intros; apply E; trivial.
rewrite (@permut_list_exists _ _ R' (fun t2 : A' => f a t2) (fun t2 : B' => f' b t2) E' _ _ P').
destruct (list_exists (fun t2 : B' => f' b t2) lb'); simpl; trivial.
destruct (list_forall (fun t1 : B => list_exists (fun t2 : B' => f' t1 t2) lb') k2'); simpl; trivial.
Qed.

Section Srel.
  Variable A : Set.
  Variable eq_A : relation A.
  Variable eq_proof : equivalence _ eq_A.
  Lemma mem_permut0_mem :
    forall  l1 l2 (a:A), permut0 eq_A l1 l2 -> (mem eq_A a l1 <-> mem eq_A a l2).
  Proof.
    intros l1 l2 a H.
    assert (forall l1 l2 e, permut0 eq_A l1 l2 -> mem eq_A e l1 -> mem eq_A e l2).
    clear - eq_proof.
    intro l1; induction l1 as [ | a1 l1]; intros l2 e P e_mem_l1.
    contradiction.
    inversion P as [ | a' b l' l1' l2' a1_eq_b P' H1 H']; subst.
    destruct e_mem_l1 as [e_eq_a1 | e_mem_l1].
    rewrite <- mem_or_app.
    right; left; apply (equiv_trans _ _ eq_proof) with a1; trivial.
    apply mem_insert; apply IHl1; trivial.
    split; apply H0; trivial.
    apply permut_sym; trivial.
    intros a0 b _ _ a_eq_b; apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut0_refl : forall l, permut0 eq_A l l.
  Proof.
    intro l; apply permut_refl.
    intros a _; apply (equiv_refl _ _ eq_proof).
  Qed.

  Lemma permut0_sym : forall l1 l2, permut0 eq_A l1 l2 -> permut0 eq_A l2 l1.
  Proof.
    intros l1 l2 P; apply permut_sym; trivial.
    intros a b _ _ a_eq_b; apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut0_trans :
    forall l1 l2 l3 : list A, permut0 eq_A l1 l2 -> permut0 eq_A l2 l3 -> permut0 eq_A l1 l3.
  Proof.
  intros l1 l2 l3 P1 P2; apply permut_trans with l2; trivial.
  intros a b c _ _ _ a_eq_b b_eq_c; apply (equiv_trans _ _ eq_proof) with b; trivial.
  Qed.

  Lemma mem_morph0 :
   forall x y : A, eq_A x y ->
   forall x0 y0 : list A, permut0 eq_A x0 y0 -> (mem eq_A x x0 <-> mem eq_A y y0).
   Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P.
    rewrite (mem_permut0_mem e1 P).
    clear l1 P; assert (H : forall e1 e2, eq_A e1 e2 -> mem eq_A e1 l2 -> mem eq_A e2 l2).
    clear e1 e2 e1_eq_e2; intros e1 e2 e1_eq_e2;
    induction l2 as [ | a l]; simpl; trivial.
    intros [e1_eq_a | e1_mem_l]; [left | right; trivial].
    apply (equiv_trans _ _ eq_proof) with e1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
    apply IHl; trivial.
    split; apply H; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma cons_permut0_mem :
    forall l1 l2 e1 e2, eq_A e1 e2 -> permut0 eq_A (e1 :: l1) l2 -> mem eq_A e2 l2.
  Proof.
    intros l1 l2 e1 e2 e1_eq_e2 P.
    apply (proj1 (mem_morph0 e1_eq_e2 P)).
    left; apply (equiv_refl _ _ eq_proof).
  Qed.

 Lemma permut0_cons :
    forall e1 e2 l1 l2, eq_A e1 e2 ->
      (permut0 eq_A l1 l2 <-> permut0 eq_A (e1 :: l1) (e2 :: l2)).
  Proof.
    intros e1 e2 l1 l2 e1_eq_e2; split; intro P.
    apply (@Pcons _ _ eq_A 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 (equiv_trans _ _ eq_proof) with a2; trivial.
    apply (equiv_trans _ _ eq_proof) with b1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

 Lemma permut0_add_inside :
    forall e1 e2 l1 l2 l3 l4,  eq_A e1 e2 ->
      (permut0 eq_A (l1 ++ l2) (l3 ++ l4) <->
      permut0 eq_A (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 (equiv_trans _ _ eq_proof) with a2; trivial.
  apply (equiv_trans _ _ eq_proof) with b1; trivial.
  apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut0_cons_inside :
    forall e1 e2 l l1 l2, eq_A e1 e2 ->
      (permut0 eq_A l (l1 ++ l2) <-> permut0 eq_A (e1 :: l) (l1 ++ e2 :: l2)).
  Proof.
    intros e1 e2 l l1 l2 e1_eq_e2.
    apply (permut0_add_inside nil l l1 l2 e1_eq_e2).
  Qed.

(** Permutation is compatible with append. *)
Lemma permut0_app1 :
  forall l l1 l2, permut0 eq_A l1 l2 <-> permut0 eq_A (l ++ l1) (l ++ l2).
Proof.
intros l l1 l2; apply permut_app1.
apply eq_proof.
Qed.

Lemma permut0_app2 :
  forall l l1 l2, permut0 eq_A l1 l2 <-> permut0 eq_A (l1 ++ l) (l2 ++ l).
Proof.
intros l l1 l2; apply permut_app2.
apply eq_proof.
Qed.

End Srel.

  Add Parametric Relation (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (list A) (permut0 eq_A)
  reflexivity proved by (permut0_refl eq_proof)
    symmetry proved by (permut0_sym eq_proof)
      transitivity proved by (permut0_trans eq_proof) as LP.

Add Parametric Morphism  (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (mem eq_A)
	with signature eq_A ==> permut0 eq_A ==> iff
	as mem_morph2.
  exact (mem_morph0 eq_proof).
Qed.

  Add Parametric Morphism (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (List.cons (A:=A))
	with signature eq_A ==> permut0 eq_A ==> permut0 eq_A
	as add_A_morph.
  Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P; rewrite <- (@permut0_cons _ _ eq_proof e1 e2 l1 l2); trivial.
  Qed.

Add Parametric Morphism (A:Set) (eq_A:relation A) (eq_proof:  equivalence _ eq_A) : (List.app (A:=A))
	with signature permut0 eq_A ==> permut0 eq_A ==> permut0 eq_A
	as app_morph.
Proof.
intros l1 l2 P l1' l2' P'.
apply (permut0_trans eq_proof) with (l1 ++ l2').
rewrite <- permut_app1; trivial.
rewrite <- permut_app2; trivial.
Qed.

Section SRel2.
  Variable A : Set.
  Variable eq_A : relation A.
  Variable eq_proof : equivalence _ eq_A.
  Variable eq_bool : A -> A -> bool.
  Hypothesis eq_bool_ok :
    forall t1 t2, match eq_bool t1 t2 with true => eq_A t1 t2 | false => ~eq_A t1 t2 end.

Lemma ac_syntactic_aux :
 forall (l1 l2 l3 l4 : list A),
 permut0 eq_A (l1 ++ l2) (l3 ++ l4) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut0 eq_A l1 (u1 ++ u2) /\
 permut0 eq_A l2 (u3 ++ u4) /\
 permut0 eq_A l3 (u1 ++ u3) /\
 permut0 eq_A l4 (u2 ++ u4)).
Proof.
induction l1 as [ | a1 l1]; intros l2 l3 l4 P.
exists (nil : list A); exists (nil : list A); exists l3; exists l4; simpl.
repeat split.
apply (permut0_refl eq_proof).
intuition.
apply (permut0_refl eq_proof).
apply (permut0_refl eq_proof).

simpl in P.

assert (a1_in_l3l4 := @cons_permut0_mem _ _  eq_proof _ _ _ _ (equiv_refl _ _ eq_proof a1) P).
rewrite <- mem_or_app in a1_in_l3l4;
destruct a1_in_l3l4 as [a1_in_l3 | a1_in_l4].
generalize (mem_split_set _ _ eq_bool_ok _ _ a1_in_l3).
intros [a1' [l3' [l3'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l3.
rewrite app_ass in P; rewrite <- app_comm_cons in P;
rewrite <- permut0_cons_inside in P; trivial.
rewrite <- app_ass in P;
destruct (IHl1 l2 (l3' ++ l3'') l4 P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]].
exists (a1 :: u1); exists u2; exists u3; exists u4; repeat split; simpl; trivial.
rewrite <- permut0_cons; trivial; apply (equiv_refl _ _ eq_proof).
apply (permut0_sym eq_proof).  rewrite <- permut0_cons_inside; auto.
apply (permut0_sym eq_proof). assumption.

generalize (mem_split_set _ _ eq_bool_ok _ _ a1_in_l4).
intros [a1' [l4' [l4'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l4.
rewrite <- app_ass in P;
rewrite <- permut0_cons_inside in P; trivial.
rewrite app_ass in P;
destruct (IHl1 l2 l3 (l4' ++ l4'') P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]];
exists u1; exists (a1 :: u2); exists u3; exists u4; intuition; simpl; trivial.
rewrite <- permut0_cons_inside; trivial. apply equiv_refl.  assumption.
apply permut0_sym; [constructor;auto|].
apply equiv_refl. assumption.
apply equiv_trans. assumption.
apply equiv_sym. assumption. rewrite <- permut0_cons_inside; trivial.
apply permut0_sym; trivial.
Qed.

Lemma list_permut0_app_app :
 forall l1 l2, permut0 eq_A (l1 ++ l2) (l2 ++ l1).
Proof.
intros l1 l2; apply permut_swapp;apply permut0_refl;assumption.
Qed.

Lemma ac_syntactic :
 forall (l1 l2 l3 l4 : list A),
 permut0 eq_A (l2 ++ l1) (l4 ++ l3) ->
 (exists u1, exists u2, exists u3, exists u4,
 permut0 eq_A l1 (u1 ++ u2) /\
 permut0 eq_A l2 (u3 ++ u4) /\
 permut0 eq_A l3 (u1 ++ u3) /\
 permut0 eq_A l4 (u2 ++ u4)).
Proof.
intros l1 l2 l3 l4 P; apply ac_syntactic_aux.
apply permut0_trans with (l2 ++ l1). assumption.
apply list_permut0_app_app.
apply permut0_trans with (l4 ++ l3); trivial.
apply list_permut0_app_app.
Qed.

End SRel2.

Module Type S.

  Declare Module Import EDS : decidable_set.ES.
  Notation permut := (permut0 eq_A).

(* Theorem list_permut_refl *)
 Parameter permut_refl :
    forall (l : list A), permut l l.

 (* Theorem list_permut_sym *)
 Parameter permut_sym :
    forall l1 l2 : list A, permut l1 l2 -> permut l2 l1.

(* Theorem list_permut_trans *)
  Parameter permut_trans :
    forall l1 l2 l3 : list A, permut l1 l2 -> permut l2 l3 -> permut l1 l3.

  Hint Immediate permut_refl.
  Hint Resolve permut_sym.

(* Theorem mem_permut_mem *)
 Parameter mem_permut_mem :
    forall l1 l2 e, permut l1 l2 -> (mem eq_A e l1 <-> mem eq_A e l2).

(* Theorem cons_permut_mem *)
   Parameter cons_permut_mem :
    forall l1 l2 e1 e2, eq_A e1 e2 -> permut (e1 :: l1) l2 -> mem eq_A e2 l2.

(* Theorem permut_cons *)
  Parameter permut_cons :
    forall e1 e2 l1 l2, eq_A e1 e2 ->
      (permut l1 l2 <-> permut (e1 :: l1) (e2 :: l2)).

(* Theorem permut_add_inside *)
   Parameter permut_add_inside :
    forall e1 e2 l1 l2 l3 l4,  eq_A e1 e2 ->
      (permut (l1 ++ l2) (l3 ++ l4) <->
      permut (l1 ++ e1 :: l2) (l3 ++ e2 :: l4)).

(* Theorem permut_cons_inside *)
  Parameter permut_cons_inside :
    forall e1 e2 l l1 l2, eq_A e1 e2 ->
      (permut l (l1 ++ l2) <-> permut (e1 :: l) (l1 ++ e2 :: l2)).

(* Theorem permut_app1 *)
 Parameter permut_app1 :
  forall l l1 l2, permut l1 l2 <-> permut (l ++ l1) (l ++ l2).

(* Theorem permut_app2 *)
Parameter permut_app2 :
  forall l l1 l2, permut l1 l2 <-> permut (l1 ++ l) (l2 ++ l).

(* Theorem list_permut_app_app *)
 Parameter list_permut_app_app :
 forall l1 l2, permut (l1 ++ l2) (l2 ++ l1).

Definition permut_bool :=
              (fix permut_bool (kk1 kk2 : list A) {struct kk1} :  bool :=
               (match kk1 with
               | nil => match kk2 with nil => true | _ :: _=> false end
               | t1 :: k1 =>
                     match remove EDS.eq_bool t1 kk2 with
                           None => false
                         | Some k2 => permut_bool k1 k2 end
                         end)).

Parameter permut_bool_ok :
forall l1 l2, match permut_bool l1 l2 with true => permut l1 l2 | false => ~permut l1 l2 end.

(* Theorem ac_syntactic *)
 Parameter 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)).

(*  Theorem remove_is_sound *)
Parameter remove_is_sound :
  forall x l, match remove eq_bool x l with
                | None => ~mem eq_A x l
                | Some l' => permut l (x :: l')
                end.

Parameter remove_equiv_nil_2 : forall l, remove_equiv eq_bool l nil = (l,nil).

(*  Theorem remove_equiv_is_sound *)
Parameter remove_equiv_is_sound:
  forall l1 l2, match remove_equiv eq_bool l1 l2 with
  | (l1', l2') => exists l, permut l1 (l ++ l1') /\ permut l2 (l ++ l2') /\
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False)
  end.

Parameter remove_equiv_is_complete :
  forall l1 l2 l l1' l2', permut l1 (l ++ l1') -> permut l2 (l ++ l2') ->
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False) ->
    (permut (fst (remove_equiv eq_bool l1 l2)) l1' /\ permut (snd (remove_equiv eq_bool l1 l2)) l2').

Parameter remove_equiv_permut:
  forall l1 l1' l2 l2', permut l1 l1' -> permut l2 l2' ->
      permut (fst (remove_equiv eq_bool l1 l2))  (fst (remove_equiv eq_bool l1' l2')) /\
          permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1' l2')).

  Add Relation (list A) permut
  reflexivity proved by permut_refl
    symmetry proved by permut_sym
      transitivity proved by permut_trans as LP.

   Add Morphism (mem eq_A)
	with signature eq_A ==> permut ==> iff
	as mem_morph2.
 Admitted.
 Add Morphism (List.app (A:=A))
   with signature permut ==> permut ==> permut
     as app_morph.
Admitted.
Add Morphism (List.cons (A:=A))
  with signature eq_A ==> permut ==> permut
    as add_A_morph.
Admitted.
End S.

(** ** Definition of permutation over lists. *)
Module Make (EDS1 : decidable_set.ES) : S with Module EDS:= EDS1.

  Module Import EDS <: decidable_set.ES := EDS1.
  Notation permut := (permut0 eq_A).

(** ** 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 (equiv_refl _ _ eq_proof).
  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 _ _ a_eq_b; apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Hint Immediate permut_refl.
  Hint Resolve permut_sym.

  (** 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 _ _ _ a_eq_b b_eq_c; apply (equiv_trans _ _ eq_proof) with b; trivial.
  Qed.

  Add Relation (list A) permut
  reflexivity proved by permut_refl
    symmetry proved by permut_sym
      transitivity proved by permut_trans as LP.

  (** ** Compatibility Properties.
      Permutation is compatible with mem. *)
  Lemma mem_permut_mem :
    forall l1 l2 e, permut l1 l2 -> (mem eq_A e l1 <-> mem eq_A e l2).
  Proof.
    assert (forall l1 l2 e, permut l1 l2 -> mem eq_A e l1 -> mem eq_A e l2).
    intro l1; induction l1 as [ | a1 l1]; intros l2 e P e_mem_l1.
    contradiction.
    inversion P as [ | a' b l' l1' l2' a1_eq_b P' H1 H']; subst.
    destruct e_mem_l1 as [e_eq_a1 | e_mem_l1].
    rewrite <- mem_or_app.
    right; left; apply (equiv_trans _ _ eq_proof) with a1; trivial.
    apply mem_insert; apply IHl1; trivial.
    intros l1 l2 e P; split; apply H; trivial.
    apply permut_sym; trivial.
  Qed.

Lemma mem_morph :
   forall x y : EDS1.A, EDS1.eq_A x y ->
   forall x0 y0 : list EDS1.A, permut x0 y0 -> (mem EDS1.eq_A x x0 <-> mem EDS1.eq_A y y0).
   Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P.
    rewrite (mem_permut_mem e1 P).
    clear l1 P; assert (H : forall e1 e2, eq_A e1 e2 -> mem eq_A e1 l2 -> mem eq_A e2 l2).
    clear e1 e2 e1_eq_e2; intros e1 e2 e1_eq_e2;
    induction l2 as [ | a l]; simpl; trivial.
    intros [e1_eq_a | e1_mem_l]; [left | right; trivial].
    apply (equiv_trans _ _ eq_proof) with e1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
    apply IHl; trivial.
    split; apply H; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

Add Morphism (mem eq_A)
	with signature eq_A ==> permut ==> iff
	as mem_morph2.
exact mem_morph.
Qed.

  Lemma cons_permut_mem :
    forall l1 l2 e1 e2, eq_A e1 e2 -> permut (e1 :: l1) l2 -> mem eq_A e2 l2.
  Proof.
    intros l1 l2 e1 e2 e1_eq_e2 P.
    apply (proj1 (mem_morph e1_eq_e2 P)).
    left; apply (equiv_refl _ _ eq_proof).
Qed.

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

 Lemma permut_cons :
    forall e1 e2 l1 l2, eq_A e1 e2 ->
      (permut l1 l2 <-> permut (e1 :: l1) (e2 :: l2)).
  Proof.
    intros e1 e2 l1 l2 e1_eq_e2; split; intro P.
    apply (@Pcons _ _ eq_A 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 (equiv_trans _ _ eq_proof) with a2; trivial.
    apply (equiv_trans _ _ eq_proof) with b1; trivial.
    apply (equiv_sym _ _ eq_proof); trivial.
     Qed.

  Add Morphism (List.cons (A:=A))
	with signature eq_A ==> permut ==> permut
	as add_A_morph.
  Proof.
    intros e1 e2 e1_eq_e2 l1 l2 P; rewrite <- (@permut_cons e1 e2 l1 l2); trivial.
  Qed.

 Lemma permut_add_inside :
    forall e1 e2 l1 l2 l3 l4,  eq_A e1 e2 ->
      (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 (equiv_trans _ _ eq_proof) with a2; trivial.
  apply (equiv_trans _ _ eq_proof) with b1; trivial.
  apply (equiv_sym _ _ eq_proof); trivial.
  Qed.

  Lemma permut_cons_inside :
    forall e1 e2 l l1 l2, eq_A e1 e2 ->
      (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.
apply EDS.eq_proof.
Qed.

Lemma permut_app2 :
  forall l l1 l2, permut l1 l2 <-> permut (l1 ++ l) (l2 ++ l).
Proof.
intros l l1 l2; apply permut_app2.
apply EDS.eq_proof.
Qed.

Add Morphism (List.app (A:=A))
	with signature permut ==> permut ==> permut
	as app_morph.
Proof.
intros l1 l2 P l1' l2' P'.
apply permut_trans with (l1 ++ l2').
rewrite <- permut_app1; trivial.
rewrite <- permut_app2; trivial.
Qed.

Lemma list_permut_app_app :
 forall l1 l2, permut (l1 ++ l2) (l2 ++ l1).
Proof.
intros l1 l2; apply permut_swapp; apply permut_refl.
Qed.

Definition permut_bool :=
              (fix permut_bool (kk1 kk2 : list A) {struct kk1} :  bool :=
               (match kk1 with
               | nil => match kk2 with nil => true | _ :: _=> false end
               | t1 :: k1 =>
                     match remove EDS1.eq_bool t1 kk2 with
                           None => false
                         | Some k2 => permut_bool k1 k2 end
                         end)).

Lemma permut_bool_ok :
forall l1 l2, match permut_bool l1 l2 with true => permut l1 l2 | false => ~permut l1 l2 end.
Proof.
fix 1.
intro l1; case l1; clear l1.
intro l2; case l2; clear l2.
simpl; apply Pnil.
intros a2 l2 P; inversion P.
intros a1 l1 l2; simpl.
generalize (in_remove _ _ EDS1.eq_bool_ok a1 l2); case (remove eq_bool a1 l2).
intros k2 [a2 [l2' [l2'' [a1_eq_a2 [H H']]]]]; injection H'; clear H'; intro H'.
generalize (permut_bool_ok l1 k2); case (permut_bool l1 k2).
intro P; subst; apply Pcons; assumption.
intros not_P P'; apply not_P.
subst k2; rewrite (permut_cons_inside l1 l2' l2'' a1_eq_a2); subst l2; apply P'.
intros a1_diff_a2 P; apply a1_diff_a2.
rewrite <- (mem_permut_mem a1 P); left.
apply (equiv_refl _ _ eq_proof).
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.
induction l1 as [ | a1 l1]; intros l2 l3 l4 P.
exists (nil : list A); exists (nil : list A); exists l3; exists l4; simpl; intuition.

simpl in P.

assert (a1_in_l3l4 := cons_permut_mem (equiv_refl _ _ eq_proof a1) P).
rewrite <- mem_or_app in a1_in_l3l4;
destruct a1_in_l3l4 as [a1_in_l3 | a1_in_l4].
generalize (mem_split_set _ _ EDS1.eq_bool_ok _ _ a1_in_l3).
intros [a1' [l3' [l3'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l3.
rewrite app_ass in P; rewrite <- app_comm_cons in P;
rewrite <- permut_cons_inside in P; trivial.
rewrite <- app_ass in P;
destruct (IHl1 l2 (l3' ++ l3'') l4 P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]].
exists (a1 :: u1); exists u2; exists u3; exists u4; repeat split; simpl; trivial.
rewrite <- permut_cons; trivial; apply (equiv_refl _ _ eq_proof).
apply permut_sym; rewrite <- permut_cons_inside; auto.

generalize (mem_split_set _ _ EDS1.eq_bool_ok _ _ a1_in_l4).
intros [a1' [l4' [l4'' [a1_eq_a1' [H _]]]]];
simpl in a1_eq_a1'; simpl in H; subst l4.
rewrite <- app_ass in P;
rewrite <- permut_cons_inside in P; trivial.
rewrite app_ass in P;
destruct (IHl1 l2 l3 (l4' ++ l4'') P) as [u1 [u2 [u3 [u4 [P1 [P2 [P3 P4]]]]]]];
exists u1; exists (a1 :: u2); exists u3; exists u4; intuition; simpl; trivial.
rewrite <- permut_cons_inside; trivial.
apply (equiv_refl _ _ eq_proof).
apply permut_sym;
rewrite <- permut_cons_inside; trivial;
apply permut_sym; trivial.
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 list_permut_app_app.
apply permut_trans with (l4 ++ l3); trivial.
apply list_permut_app_app.
Qed.

Lemma remove_is_sound :
  forall x l, match remove eq_bool x l with
                | None => ~mem eq_A x l
                | Some l' => permut l (x :: l')
                end.
Proof.
intros x l; generalize (in_remove eq_A eq_bool eq_bool_ok x l);
case (remove eq_bool x l); [ intros k [x' [l' [l'' [x_eq_x' [H1 H2]]]]] | idtac].
injection H2; clear H2; intros; subst.
apply permut_sym; rewrite <- permut_cons_inside; auto.
intro; assumption.
Qed.

Lemma remove_permut :
  forall l1 l2, permut l1 l2 -> forall a,
  match (remove eq_bool a l1) with
  | Some l =>
        match (remove eq_bool a l2) with
        | Some l' => permut l l'
        | None => False
        end
  | None => remove eq_bool a l2 = None
  end.
Proof.
intros l1 l2 P a; generalize (remove_is_sound a l1) (remove_is_sound a l2).
case (remove eq_bool a l1); case (remove eq_bool a l2).
intros l l' P1 P2.
rewrite (@permut_cons a a l' l).
apply permut_trans with l2; trivial.
apply permut_trans with l1; trivial.
apply permut_sym; trivial.
apply (equiv_refl _ _ eq_proof).
intros l P' a_not_in_l2; apply a_not_in_l2.
rewrite <- (mem_permut_mem a P).
rewrite (mem_permut_mem a P'); left; apply (equiv_refl _ _ eq_proof).
intros l a_not_in_l1 P'; assert False; [idtac | contradiction].
apply a_not_in_l1.
rewrite (mem_permut_mem a P).
rewrite (mem_permut_mem a P'); left; apply (equiv_refl _ _ eq_proof).
intros; apply refl_equal.
Defined.

Lemma remove_eq_eq :
  forall l a a', eq_A a a' ->
  match (remove eq_bool a l) with
  | Some l1 =>
        match (remove eq_bool a' l) with
        | Some l2 => l1 = l2
        | None => False
        end
  | None => remove eq_bool a' l = None
  end.
Proof.
fix 1.
intros [ | b l] a a' a_eq_a'; simpl.
apply refl_equal.
case_eq (eq_bool a b); [intro a_eq_b | intro a_diff_b].
case_eq (eq_bool a' b); [intro a'_eq_b | intro a'_diff_b].
apply refl_equal.
apply False_rec.
assert (D := eq_bool_ok a' b); rewrite a'_diff_b in D; apply D.
apply (equiv_trans _ _ eq_proof) with a.
apply (equiv_sym _ _ eq_proof); assumption.
assert (E := eq_bool_ok a b); rewrite a_eq_b in E; assumption.
case_eq (eq_bool a' b); [intro a'_eq_b | intro a'_diff_b].
apply False_rec.
assert (D := eq_bool_ok a b); rewrite a_diff_b in D; apply D.
apply (equiv_trans _ _ eq_proof) with a'.
assumption.
assert (E := eq_bool_ok a' b); rewrite a'_eq_b in E; assumption.
generalize (remove_eq_eq l _ _ a_eq_a').
case (remove eq_bool a l); case (remove eq_bool a' l); intros; subst; trivial.
discriminate.
Defined.

Lemma remove_equiv_nil_2 :
  forall l, remove_equiv eq_bool l nil = (l,nil).
Proof.
fix 1.
intros [ | a l]; simpl.
apply refl_equal.
rewrite remove_equiv_nil_2; apply refl_equal.
Qed.

Lemma remove_equiv_is_sound:
  forall l1 l2, match remove_equiv eq_bool l1 l2 with
  | (l1', l2') => exists l, permut l1 (l ++ l1') /\ permut l2 (l ++ l2') /\
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False)
  end.
Proof.
intros l1 l2;
functional induction (remove_equiv eq_bool l1 l2)
    as [ (* Case 1 *)
         | (* Case 2 *) H1 l2 e1 l1 H2 l2' H H'
         | (* Case 3 *) H1 l2 e1 l1 H2 H H' l1'' l2'' H''].
(* Case 1 *)
exists (@nil A); simpl; intuition.
(* Case 2 *)
case_eq (remove_equiv eq_bool l1 l2'); intros l1'' l2'' H''; rewrite H'' in H'.
revert H'; intros [l [P1 [P2 H']]].
exists (e1 :: l); simpl; split.
apply (proj1 (permut_cons l1 (l ++ l1'') (equiv_refl _ _ eq_proof e1))); assumption.
split; trivial.
apply permut_trans with (e1 :: l2').
assert (H''' := remove_is_sound e1 l2); rewrite H in H'''; trivial.
apply (proj1 (permut_cons l2' (l ++ l2'') (equiv_refl _ _ eq_proof e1))); assumption.
(* Case 3 *)
case_eq (remove_equiv eq_bool l1 l2); intros l1' l2' H'''; rewrite H''' in H''; injection H''; clear H''; intros; subst l1'' l2''.
rewrite H''' in H'; revert H'; intros [l [P1 [P2 H']]]; exists l; split.
rewrite <- permut_cons_inside; trivial.
apply (equiv_refl _ _ eq_proof).
split; trivial.
intros x [x_eq_e1 | x_mem_l1'] x_mem_l2'.
assert (H'' := remove_is_sound e1 l2); rewrite H in H''.
absurd (mem eq_A e1 l2); trivial.
apply (proj1 (mem_morph x_eq_e1 (permut_refl l2))).
apply (proj2 (mem_permut_mem x P2)).
rewrite <- mem_or_app; right; trivial.
apply (H' x); trivial.
Qed.

Lemma remove_equiv_is_complete :
  forall l1 l2 l l1' l2', permut l1 (l ++ l1') -> permut l2 (l ++ l2') ->
                        (forall x, mem eq_A x l1' -> mem eq_A x l2' -> False) ->
    (permut (fst (remove_equiv eq_bool l1 l2)) l1' /\ permut (snd (remove_equiv eq_bool l1 l2)) l2').
Proof.
intros l1 l2;
functional induction (remove_equiv eq_bool l1 l2)
    as [ (* Case 1 *)
         | (* Case 2 *) H1 l2 e1 l1 H2 l2' H H'
         | (* Case 3 *) H1 l2 e1 l1 H2 H H' l1'' l2'' H'']; intros l k1' k2' P1 P2 E.
(* Case 1 *)
revert P1 P2; simpl; case l; [idtac | intros a l'].
case k1'; [idtac | intros a1' k1''].
simpl; split; assumption.
intro P1; inversion P1.
intro P1; inversion P1.
(* Case 2 *)
case_eq (remove_equiv eq_bool l1 l2'); intros l1'' l2'' H''.
assert (e1_in_l_k1' : mem eq_A e1 (l ++ k1')).
rewrite <- (mem_permut_mem e1 P1); left; apply (equiv_refl _ _ eq_proof).
rewrite <- mem_or_app in e1_in_l_k1'; simpl.
assert (Subcase : mem eq_A e1 l -> permut l1'' k1' /\ permut l2'' k2').
intro e1_in_l; generalize (remove_is_sound e1 l); case (remove eq_bool e1 l).
intros l' P.
assert (Q1 : permut l1 (l' ++ k1')).
rewrite (permut_cons l1 (l' ++ k1') (e1 := e1) (e2 := e1)) by apply (equiv_refl _ _ eq_proof).
apply permut_trans with (l ++ k1').
exact P1.
rewrite app_comm_cons; rewrite <- permut_app2; exact P.
generalize (remove_is_sound e1 l2); rewrite H; intro P2'.
assert (Q2 : permut l2' (l' ++ k2')).
rewrite (permut_cons l2' (l' ++ k2') (e1 := e1) (e2 := e1)) by apply (equiv_refl _ _ eq_proof).
apply permut_trans with l2.
apply permut_sym; assumption.
apply permut_trans with (l ++ k2').
assumption.
rewrite app_comm_cons; rewrite <- permut_app2; exact P.
generalize (H' l' k1' k2' Q1 Q2 E).
intros [PP1 PP2]; split.
rewrite H'' in PP1; assumption.
rewrite H'' in PP2; assumption.
intro Abs; apply False_rec; apply Abs; assumption.
revert e1_in_l_k1'; intros [e1_in_l | e1_in_k1'].
apply (Subcase e1_in_l).
assert (R := remove_is_sound e1 l2); rewrite H in R.
assert (e1_in_l2 : mem eq_A e1 l2).
rewrite (mem_permut_mem e1 R); left; apply (equiv_refl _ _ eq_proof).
rewrite (mem_permut_mem e1 P2) in e1_in_l2.
rewrite <- mem_or_app in e1_in_l2.
revert e1_in_l2; intros [e1_in_l | e1_in_k2'].
apply (Subcase e1_in_l).
apply False_rec; apply (E _ e1_in_k1' e1_in_k2').
(* Case 3 *)
case_eq (remove_equiv eq_bool l1 l2); intros l1' l2' H'''.
assert (R := remove_is_sound e1 l2); rewrite H in R.
assert (e1_in_l_k1' : mem eq_A e1 (l ++ k1')).
rewrite <- (mem_permut_mem e1 P1); left; apply (equiv_refl _ _ eq_proof).
rewrite <- mem_or_app in e1_in_l_k1'.
revert e1_in_l_k1'; intros [e1_in_l | e1_in_k1'].
apply False_rec.
apply R; rewrite (mem_permut_mem e1 P2).
rewrite <- mem_or_app; left; assumption.
simpl; generalize (remove_is_sound e1 k1'); case (remove eq_bool e1 k1').
intros k' P.
assert (Q1 : permut l1 (l ++ k')).
rewrite (permut_cons l1 (l ++ k') (e1 := e1) (e2 := e1)) by apply (equiv_refl _ _ eq_proof).
apply permut_trans with (l ++ k1').
exact P1.
apply permut_trans with (l ++ e1 :: k').
rewrite <- permut_app1; assumption.
apply permut_sym; rewrite <- permut_cons_inside; [apply permut_refl | apply (equiv_refl _ _ eq_proof)].
assert (E' : forall x : EDS1.A, mem eq_A x k' -> mem eq_A x k2' -> False).
intros x x_in_k x_in_k2'; apply (E x); trivial.
rewrite (mem_permut_mem x P); right; assumption.
generalize (H' l k' k2' Q1 P2 E'); rewrite H''; simpl.
intros [H1 H2]; split; trivial.
apply permut_trans with (e1 :: k').
rewrite <- permut_cons by apply (equiv_refl _ _ eq_proof); assumption.
apply permut_sym; assumption.
intro Abs; apply False_rec; apply Abs; assumption.
Qed.

Lemma remove_equiv_permut_1 :
  forall l1 l1', permut l1 l1' ->
      forall l2, (permut (fst (remove_equiv eq_bool l1 l2)) (fst (remove_equiv eq_bool l1' l2)) /\
      permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1' l2))).
Proof.
intros l1 l1' P1 l2;
generalize (remove_equiv_is_sound l1 l2) (remove_equiv_is_sound l1' l2).
case_eq (remove_equiv eq_bool l1 l2); intros k1 k2 H1; intros [l [Q1 [Q2 H]]].
case_eq (remove_equiv eq_bool l1' l2); intros k1' k2' H1'; intros [l' [Q1' [Q2' H']]].
simpl; assert (Q1'' : permut l1 (l' ++ k1')).
apply permut_trans with l1'; trivial.
assert (R := @remove_equiv_is_complete l1 l2 l' k1' k2' Q1'' Q2' H'); rewrite H1 in R.
revert R; intros [R1 R2]; split; trivial.
Qed.

Lemma remove_equiv_permut_2:
  forall l1 l2 l2', permut l2 l2' ->
      (fst (remove_equiv eq_bool l1 l2) =  fst (remove_equiv eq_bool l1 l2') /\
          permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1 l2'))).
Proof.
fix 1.
intros [ | a1 l1] l2 l2' P.
simpl; split; [apply refl_equal | trivial].
simpl; generalize (remove_permut P a1).
case_eq (remove eq_bool a1 l2); [intro k2 | idtac]; intro H2.
case_eq (remove eq_bool a1 l2'); [intro k2' | idtac]; intro H2'.
intro P'; assert (H := remove_equiv_permut_2 l1 _ _ P'); case H; intros H' H''; split; trivial.
intro; apply False_rec; trivial.
intro H2'; rewrite H2'.
assert (H := remove_equiv_permut_2 l1 _ _ P); case H; intros H' H''; split.
revert H'; case (remove_equiv eq_bool l1 l2); intros k1 k2;
case (remove_equiv eq_bool l1 l2'); intros k1' k2'; simpl; intros; subst; trivial.
revert H''; case (remove_equiv eq_bool l1 l2); intros k1 k2;
case (remove_equiv eq_bool l1 l2'); intros k1' k2'; simpl; intros; subst; trivial.
Defined.

Lemma remove_equiv_permut:
  forall l1 l1' l2 l2', permut l1 l1' -> permut l2 l2' ->
      permut (fst (remove_equiv eq_bool l1 l2))  (fst (remove_equiv eq_bool l1' l2')) /\
          permut (snd (remove_equiv eq_bool l1 l2)) (snd (remove_equiv eq_bool l1' l2')).
Proof.
intros l1 l1' l2 l2' P1 P2.
generalize (remove_equiv_permut_1 P1 l2) (remove_equiv_permut_2 l1' P2).
case (remove_equiv eq_bool l1 l2); case (remove_equiv eq_bool l1' l2); case (remove_equiv eq_bool l1' l2');
simpl; intros u1 u2 u3 u4 u5 u6 [Q1 Q2] [Q3 Q4]; split.
subst; assumption.
apply permut_trans with u4; assumption.
Qed.

End Make.

(* With section instead of module, and then polymorph use
Section LP.
Variable A : Set.
Parameter eq_A_dec : forall t1 t2 : A, {t1 = t2} + {t1 <> t2}.
...
End LP.

Add Relation list list_permut
reflexivity proved by list_permut_refl
symmetry proved by list_permut_sym
transitivity proved by list_permut_trans as LP_poly.

Add Morphism In with signature  eq ==> list_permut ==> iff as in_morph_poly.
Proof.
intros; split; intros.
apply in_permut_in with x1; trivial.
apply in_permut_in with x2; trivial; apply list_permut_sym; trivial.
Qed.

Goal forall (a b:nat), list_permut (a::b::nil) (b::a::nil) ->
In a (b :: a :: nil).
intros a b P.
rewrite <- P.
left; trivial.
Qed.
*)

(*
Extract Constant eq_element_dec => eq.
Extract Constant o_element_dec => le.
Extract Constant element => int.
Extraction split_list.
Extraction partition.
Extraction NoInline partition.
Extraction quicksort.
*)

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../basis/") ***
*** End: ***
 *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import NZAxioms NZBase Decidable OrdersTac.

Module Type NZOrderProp
 (Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ).

Instance le_wd : Proper (eq==>eq==>iff) le.
Proof.
intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm.
Qed.

Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H].

Theorem lt_le_incl : forall n m, n < m -> n <= m.
Proof.
intros. apply lt_eq_cases. now left.
Qed.

Theorem le_refl : forall n, n <= n.
Proof.
intro. apply lt_eq_cases. now right.
Qed.

Theorem lt_succ_diag_r : forall n, n < S n.
Proof.
intro n. rewrite lt_succ_r. apply le_refl.
Qed.

Theorem le_succ_diag_r : forall n, n <= S n.
Proof.
intro; apply lt_le_incl; apply lt_succ_diag_r.
Qed.

Theorem neq_succ_diag_l : forall n, S n ~= n.
Proof.
intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r.
Qed.

Theorem neq_succ_diag_r : forall n, n ~= S n.
Proof.
intro n; apply neq_sym, neq_succ_diag_l.
Qed.

Theorem nlt_succ_diag_l : forall n, ~ S n < n.
Proof.
intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl.
Qed.

Theorem nle_succ_diag_l : forall n, ~ S n <= n.
Proof.
intros n H; le_elim H.
false_hyp H nlt_succ_diag_l. false_hyp H neq_succ_diag_l.
Qed.

Theorem le_succ_l : forall n m, S n <= m <-> n < m.
Proof.
intro n; nzinduct m n.
split; intro H. false_hyp H nle_succ_diag_l. false_hyp H lt_irrefl.
intro m.
rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd.
rewrite or_cancel_r.
reflexivity.
intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l.
intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl.
Qed.

(** Trichotomy *)

Theorem le_gt_cases : forall n m, n <= m \/ n > m.
Proof.
intros n m; nzinduct n m.
left; apply le_refl.
intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition.
Qed.

Theorem lt_trichotomy : forall n m,  n < m \/ n == m \/ m < n.
Proof.
intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto.
Qed.

Notation lt_eq_gt_cases := lt_trichotomy (only parsing).

(** Asymmetry and transitivity. *)

Theorem lt_asymm : forall n m, n < m -> ~ m < n.
Proof.
intros n m; nzinduct n m.
intros H; false_hyp H lt_irrefl.
intro n; split; intros H H1 H2.
apply lt_succ_r in H2. le_elim H2.
apply H; auto. apply le_succ_l. now apply lt_le_incl.
rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l.
apply le_succ_l in H1. le_elim H1.
apply H; auto. rewrite lt_succ_r. now apply lt_le_incl.
rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l.
Qed.

Notation lt_ngt := lt_asymm (only parsing).

Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
Proof.
intros n m p; nzinduct p m.
intros _ H; false_hyp H lt_irrefl.
intro p. rewrite 2 lt_succ_r.
split; intros H H1 H2.
apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1].
assert (n <= p) as H3 by (auto using lt_le_incl).
le_elim H3. assumption. rewrite <- H3 in H2.
elim (lt_asymm n m); auto.
Qed.

Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
Proof.
intros n m p. rewrite 3 lt_eq_cases.
intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ';
 generalize (lt_trans n m p); auto with relations.
Qed.

(** Some type classes about order *)

Instance lt_strorder : StrictOrder lt.
Proof. split. exact lt_irrefl. exact lt_trans. Qed.

Instance le_preorder : PreOrder le.
Proof. split. exact le_refl. exact le_trans. Qed.

Instance le_partialorder : PartialOrder _ le.
Proof.
intros x y. compute. split.
intro EQ; now rewrite EQ.
rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y.
Qed.

(** We know enough now to benefit from the generic [order] tactic. *)

Definition lt_compat := lt_wd.
Definition lt_total := lt_trichotomy.
Definition le_lteq := lt_eq_cases.

Module Private_OrderTac.
Module IsTotal.
 Definition eq_equiv := eq_equiv.
 Definition lt_strorder := lt_strorder.
 Definition lt_compat := lt_compat.
 Definition lt_total := lt_total.
 Definition le_lteq := le_lteq.
End IsTotal.
Module Tac := !MakeOrderTac NZ IsTotal.
End Private_OrderTac.
Ltac order := Private_OrderTac.Tac.order.

(** Some direct consequences of [order]. *)

Theorem lt_neq : forall n m, n < m -> n ~= m.
Proof. order. Qed.

Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m.
Proof. intuition order. Qed.

Theorem eq_le_incl : forall n m, n == m -> n <= m.
Proof. order. Qed.

Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y.
Proof. order. Qed.

Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z.
Proof. order. Qed.

Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y.
Proof. order. Qed.

Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z.
Proof. order. Qed.

Declare Left  Step lt_stepl.
Declare Right Step lt_stepr.
Declare Left  Step le_stepl.
Declare Right Step le_stepr.

Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
Proof. order. Qed.

Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p.
Proof. order. Qed.

Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m.
Proof. order. Qed.

(** More properties of [<] and [<=] with respect to [S] and [0]. *)

Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m.
Proof.
intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r.
Qed.

Theorem lt_succ_l : forall n m, S n < m -> n < m.
Proof.
intros n m H; apply le_succ_l; order.
Qed.

Theorem le_le_succ_r : forall n m, n <= m -> n <= S m.
Proof.
intros n m LE. apply lt_succ_r in LE. order.
Qed.

Theorem lt_lt_succ_r : forall n m, n < m -> n < S m.
Proof.
intros. rewrite lt_succ_r. order.
Qed.

Theorem succ_lt_mono : forall n m, n < m <-> S n < S m.
Proof.
intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r.
Qed.

Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m.
Proof.
intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd.
Qed.

Theorem lt_0_1 : 0 < 1.
Proof.
rewrite one_succ. apply lt_succ_diag_r.
Qed.

Theorem le_0_1 : 0 <= 1.
Proof.
apply lt_le_incl, lt_0_1.
Qed.

Theorem lt_1_2 : 1 < 2.
Proof.
rewrite two_succ. apply lt_succ_diag_r.
Qed.

Theorem lt_0_2 : 0 < 2.
Proof.
transitivity 1. apply lt_0_1. apply lt_1_2.
Qed.

Theorem le_0_2 : 0 <= 2.
Proof.
apply lt_le_incl, lt_0_2.
Qed.

(** The order tactic enriched with some knowledge of 0,1,2 *)

Ltac order' := generalize lt_0_1 lt_1_2; order.

Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m.
Proof.
intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order.
Qed.

(** More Trichotomy, decidability and double negation elimination. *)

(** The following theorem is cleary redundant, but helps not to
remember whether one has to say le_gt_cases or lt_ge_cases *)

Theorem lt_ge_cases : forall n m, n < m \/ n >= m.
Proof.
intros n m; destruct (le_gt_cases m n); intuition order.
Qed.

Theorem le_ge_cases : forall n m, n <= m \/ n >= m.
Proof.
intros n m; destruct (le_gt_cases n m); intuition order.
Qed.

Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m.
Proof.
intros n m; destruct (lt_trichotomy n m); intuition order.
Qed.

(** Decidability of equality, even though true in each finite ring, does not
have a uniform proof. Otherwise, the proof for two fixed numbers would
reduce to a normal form that will say if the numbers are equal or not,
which cannot be true in all finite rings. Therefore, we prove decidability
in the presence of order. *)

Theorem eq_decidable : forall n m, decidable (n == m).
Proof.
intros n m; destruct (lt_trichotomy n m) as [ | [ | ]];
 (right; order) || (left; order).
Qed.

(** DNE stands for double-negation elimination *)

Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m.
Proof.
intros n m; split; intro H.
destruct (eq_decidable n m) as [H1 | H1].
assumption. false_hyp H1 H.
intro H1; now apply H1.
Qed.

Theorem le_ngt : forall n m, n <= m <-> ~ n > m.
Proof. intuition order. Qed.

(** Redundant but useful *)

Theorem nlt_ge : forall n m, ~ n < m <-> n >= m.
Proof. intuition order. Qed.

Theorem lt_decidable : forall n m, decidable (n < m).
Proof.
intros n m; destruct (le_gt_cases m n); [right|left]; order.
Qed.

Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m.
Proof.
intros n m; split; intro H.
destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
intro H1; false_hyp H H1.
Qed.

Theorem nle_gt : forall n m, ~ n <= m <-> n > m.
Proof. intuition order. Qed.

(** Redundant but useful *)

Theorem lt_nge : forall n m, n < m <-> ~ n >= m.
Proof. intuition order. Qed.

Theorem le_decidable : forall n m, decidable (n <= m).
Proof.
intros n m; destruct (le_gt_cases n m); [left|right]; order.
Qed.

Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m.
Proof.
intros n m; split; intro H.
destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
intro H1; false_hyp H H1.
Qed.

Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m.
Proof.
intros n m; rewrite lt_succ_r. intuition order.
Qed.

(** The difference between integers and natural numbers is that for
every integer there is a predecessor, which is not true for natural
numbers. However, for both classes, every number that is bigger than
some other number has a predecessor. The proof of this fact by regular
induction does not go through, so we need to use strong
(course-of-value) induction. *)

Lemma lt_exists_pred_strong :
  forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k.
Proof.
intro z; nzinduct n z.
order.
intro n; split; intros IH m H1 H2.
apply le_succ_r in H2. destruct H2 as [H2 | H2].
now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2].
apply IH. assumption. now apply le_le_succ_r.
Qed.

Theorem lt_exists_pred :
  forall z n, z < n -> exists k, n == S k /\ z <= k.
Proof.
intros z n H; apply lt_exists_pred_strong with (z := z) (n := n).
assumption. apply le_refl.
Qed.

Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n.
Proof.
 intros z n H.
 destruct (lt_exists_pred _ _ H) as (n' & EQ & LE).
 rewrite EQ. now rewrite pred_succ.
Qed.

(** Stronger variant of induction with assumptions n >= 0 (n < 0)
in the induction step *)

Section Induction.

Variable A : t -> Prop.
Hypothesis A_wd : Proper (eq==>iff) A.

Section Center.

Variable z : t. (* A z is the basis of induction *)

Section RightInduction.

Let A' (n : t) := forall m, z <= m -> m < n -> A m.
Let right_step :=   forall n, z <= n -> A n -> A (S n).
Let right_step' :=  forall n, z <= n -> A' n -> A n.
Let right_step'' := forall n, A' n <-> A' (S n).

Lemma rs_rs' :  A z -> right_step -> right_step'.
Proof.
intros Az RS n H1 H2.
le_elim H1. apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]].
rewrite H3. apply RS; trivial. apply H2; trivial.
rewrite H3; apply lt_succ_diag_r.
rewrite <- H1; apply Az.
Qed.

Lemma rs'_rs'' : right_step' -> right_step''.
Proof.
intros RS' n; split; intros H1 m H2 H3.
apply lt_succ_r in H3; le_elim H3;
[now apply H1 | rewrite H3 in *; now apply RS'].
apply H1; [assumption | now apply lt_lt_succ_r].
Qed.

Lemma rbase : A' z.
Proof.
intros m H1 H2. apply le_ngt in H1. false_hyp H2 H1.
Qed.

Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n.
Proof.
intros H1 n H2. apply H1 with (n := S n); [assumption | apply lt_succ_diag_r].
Qed.

Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n.
Proof.
intro RS'; apply A'A_right; unfold A'; nzinduct n z;
[apply rbase | apply rs'_rs''; apply RS'].
Qed.

Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n.
Proof.
intros Az RS; apply strong_right_induction; now apply rs_rs'.
Qed.

Theorem right_induction' :
  (forall n, n <= z -> A n) -> right_step -> forall n, A n.
Proof.
intros L R n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply L; now apply lt_le_incl.
apply L; now apply eq_le_incl.
apply right_induction. apply L; now apply eq_le_incl. assumption.
now apply lt_le_incl.
Qed.

Theorem strong_right_induction' :
  (forall n, n <= z -> A n) -> right_step' -> forall n, A n.
Proof.
intros L R n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply L; now apply lt_le_incl.
apply L; now apply eq_le_incl.
apply strong_right_induction. assumption. now apply lt_le_incl.
Qed.

End RightInduction.

Section LeftInduction.

Let A' (n : t) := forall m, m <= z -> n <= m -> A m.
Let left_step :=   forall n, n < z -> A (S n) -> A n.
Let left_step' :=  forall n, n <= z -> A' (S n) -> A n.
Let left_step'' := forall n, A' n <-> A' (S n).

Lemma ls_ls' :  A z -> left_step -> left_step'.
Proof.
intros Az LS n H1 H2. le_elim H1.
apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl].
rewrite H1; apply Az.
Qed.

Lemma ls'_ls'' : left_step' -> left_step''.
Proof.
intros LS' n; split; intros H1 m H2 H3.
apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1.
le_elim H3.
apply le_succ_l in H3. now apply H1.
rewrite <- H3 in *; now apply LS'.
Qed.

Lemma lbase : A' (S z).
Proof.
intros m H1 H2. apply le_succ_l in H2.
apply le_ngt in H1. false_hyp H2 H1.
Qed.

Lemma A'A_left : (forall n, A' n) -> forall n, n <= z -> A n.
Proof.
intros H1 n H2. apply (H1 n); [assumption | now apply eq_le_incl].
Qed.

Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n.
Proof.
intro LS'; apply A'A_left; unfold A'; nzinduct n (S z);
[apply lbase | apply ls'_ls''; apply LS'].
Qed.

Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n.
Proof.
intros Az LS; apply strong_left_induction; now apply ls_ls'.
Qed.

Theorem left_induction' :
  (forall n, z <= n -> A n) -> left_step -> forall n, A n.
Proof.
intros R L n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply left_induction. apply R. now apply eq_le_incl. assumption.
now apply lt_le_incl.
rewrite H; apply R; now apply eq_le_incl.
apply R; now apply lt_le_incl.
Qed.

Theorem strong_left_induction' :
  (forall n, z <= n -> A n) -> left_step' -> forall n, A n.
Proof.
intros R L n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply strong_left_induction; auto. now apply lt_le_incl.
rewrite H; apply R; now apply eq_le_incl.
apply R; now apply lt_le_incl.
Qed.

End LeftInduction.

Theorem order_induction :
  A z ->
  (forall n, z <= n -> A n -> A (S n)) ->
  (forall n, n < z  -> A (S n) -> A n) ->
    forall n, A n.
Proof.
intros Az RS LS n.
destruct (lt_trichotomy n z) as [H | [H | H]].
now apply left_induction; [| | apply lt_le_incl].
now rewrite H.
now apply right_induction; [| | apply lt_le_incl].
Qed.

Theorem order_induction' :
  A z ->
  (forall n, z <= n -> A n -> A (S n)) ->
  (forall n, n <= z -> A n -> A (P n)) ->
    forall n, A n.
Proof.
intros Az AS AP n; apply order_induction; try assumption.
intros m H1 H2. apply AP in H2; [|now apply le_succ_l].
now rewrite pred_succ in H2.
Qed.

End Center.

Theorem order_induction_0 :
  A 0 ->
  (forall n, 0 <= n -> A n -> A (S n)) ->
  (forall n, n < 0  -> A (S n) -> A n) ->
    forall n, A n.
Proof (order_induction 0).

Theorem order_induction'_0 :
  A 0 ->
  (forall n, 0 <= n -> A n -> A (S n)) ->
  (forall n, n <= 0 -> A n -> A (P n)) ->
    forall n, A n.
Proof (order_induction' 0).

(** Elimintation principle for < *)

Theorem lt_ind : forall (n : t),
  A (S n) ->
  (forall m, n < m -> A m -> A (S m)) ->
   forall m, n < m -> A m.
Proof.
intros n H1 H2 m H3.
apply right_induction with (S n); [assumption | | now apply le_succ_l].
intros; apply H2; try assumption. now apply le_succ_l.
Qed.

(** Elimination principle for <= *)

Theorem le_ind : forall (n : t),
  A n ->
  (forall m, n <= m -> A m -> A (S m)) ->
   forall m, n <= m -> A m.
Proof.
intros n H1 H2 m H3.
now apply right_induction with n.
Qed.

End Induction.

Tactic Notation "nzord_induct" ident(n) :=
  induction_maker n ltac:(apply order_induction_0).

Tactic Notation "nzord_induct" ident(n) constr(z) :=
  induction_maker n ltac:(apply order_induction with z).

Section WF.

Variable z : t.

Let Rlt (n m : t) := z <= n < m.
Let Rgt (n m : t) := m < n <= z.

Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt.
Proof.
intros x1 x2 H1 x3 x4 H2; unfold Rlt. rewrite H1; now rewrite H2.
Qed.

Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt.
Proof.
intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2.
Qed.

Theorem lt_wf : well_founded Rlt.
Proof.
unfold well_founded.
apply strong_right_induction' with (z := z).
auto with typeclass_instances.
intros n H; constructor; intros y [H1 H2].
apply nle_gt in H2. elim H2. now apply le_trans with z.
intros n H1 H2; constructor; intros m [H3 H4]. now apply H2.
Qed.

Theorem gt_wf : well_founded Rgt.
Proof.
unfold well_founded.
apply strong_left_induction' with (z := z).
auto with typeclass_instances.
intros n H; constructor; intros y [H1 H2].
apply nle_gt in H2. elim H2. now apply le_lt_trans with n.
intros n H1 H2; constructor; intros m [H3 H4].
apply H2. assumption. now apply le_succ_l.
Qed.

End WF.

End NZOrderProp.

(** If we have moreover a [compare] function, we can build
    an [OrderedType] structure. *)

(* Temporary workaround for bug #2949: remove this problematic + unused functor
Module NZOrderedType (NZ : NZDecOrdSig')
 <: DecidableTypeFull <: OrderedTypeFull
 := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec.
*)


Require Import Utils.

Set Implicit Arguments.

Module Type CTXTYP.

Parameter Typ : Type.

Parameter TypTp : Typ->Type.
Coercion TypTp : Typ >-> Sortclass.

End CTXTYP.

Module Contex (Import CtxTyp : CTXTYP).

(* Semantic contexts *)

Inductive CtxS : Type->Type :=
	empCtxS : CtxS unit |
	extCtxS G (s:CtxS G) (T:G->Typ) : CtxS (sigT T).

Inductive Ctx : Type := ctx G (s:CtxS G).

Definition CtxTp G := match G with ctx G _ => G end.
Coercion CtxTp : Ctx >-> Sortclass.

Definition ctxSc (G:Ctx) : CtxS G := match G with ctx _ s => s end.

Definition EmpCtx := ctx empCtxS.
Definition ExtCtx G T := ctx (extCtxS (ctxSc G) T).

Definition IsExtCtx G := match G with
	ctx _ empCtxS => False |
	ctx _ (extCtxS _ _ _) => True
end.

Definition CtxInit G := match G with
	ctx _ empCtxS => EmpCtx |
	ctx _ (extCtxS _ s _) => ctx s
end.

Definition CtxTop G : forall ne:IsExtCtx G,CtxInit G->Typ.
	destruct G.
	destruct s;simpl;intro.

	destruct ne.

	exact T.
Defined.
Arguments CtxTop [G] ne g.

Fixpoint ctxLenS G (s:CtxS G) := match s with
	empCtxS => O |
	extCtxS _ s _ => S (ctxLenS s)
end.

Definition ctxLen G := ctxLenS (ctxSc G).

Definition extCtxUnfold G : forall ne:IsExtCtx G,G = ExtCtx (CtxInit G) (CtxTop ne).
	destruct G.
	destruct s;simpl;intro.

	destruct ne.

	reflexivity.
Defined.
Arguments extCtxUnfold [G] ne.

Definition extCtxInj G1 G2 : forall T1 T2 (e:ExtCtx G1 T1 = ExtCtx G2 T2),
existT (fun G:Ctx=>G->Typ) G1 T1 = existT _ G2 T2.
	destruct G1 as (G1,s1).
	destruct G2 as (G2,s2).
	simpl.
	intros.
	generalize I.
	apply (tr (fun Gx=>forall ne:IsExtCtx Gx,_ = existT (fun G:Ctx=>G->Typ) _ (CtxTop ne)) e).
	simpl.
	intro.
	reflexivity.
Defined.

(* Strongly typed de Bruijn indexes *)

(*
Inductive AtCtx : forall G:Ctx,nat->(G->Typ)->Type :=
	topCtx G T : AtCtx (ExtCtx G T) O (fun g=>T (projT1 g)) |
	popCtx G i T : AtCtx G i T->forall T',AtCtx (ExtCtx G T') (S i) (fun g=>T (projT1 g)).
*)

Inductive PopCtx G (T':G->Typ) P : (sigT T'->Typ)->Type :=
	mkPopCtx T : P T->PopCtx T' P (fun g=>T (projT1 g)).

Fixpoint AtCtxS G (s:CtxS G) i : (G->Typ)->Type := match s with
	empCtxS => fun T=>Empty_set |
	extCtxS _ s T' => match i with
		O => eq (fun g=>T' (projT1 g)) |
		S i => PopCtx T' (AtCtxS s i)
	end
end.

Definition AtCtx G := AtCtxS (ctxSc G).

Definition topCtx G T : AtCtx (ExtCtx G T) O (fun g=>T (projT1 g)) := eq_refl.

Definition popCtx G i T (a:AtCtx G i T) T' : AtCtx (ExtCtx G T') (S i) (fun g=>T (projT1 g)) := mkPopCtx _ _ _ a.
Arguments popCtx [G i T] a T'.

Definition atCtxIndS (P:forall G i T,AtCtx G i T->Type)
	(top:forall G T,P _ _ _ (topCtx G T))
	(pop:forall G i T (a:AtCtx G i T) (IHa:P _ _ _ a) T',P _ _ _ (popCtx a T'))
: forall G (s:CtxS G) i T (a:AtCtx (ctx s) i T),P _ _ _ a.
	refine (fix atCtxIndS G s i := match s in CtxS G return forall T (a:AtCtx (ctx s) i T),P _ _ _ a with
		empCtxS => _ |
		extCtxS _ s0 _ => _
	end);clear G s;simpl;intro.

	intro.
	destruct a.

	destruct i;unfold AtCtx;simpl;intro;destruct a.
		exact (top (ctx s0) _).

		exact (pop _ _ _ _ (atCtxIndS _ _ _ _ _) _).
Defined.

Definition AtCtx_rect (P:forall G i T,AtCtx G i T->Type)
	(top:forall G T,P _ _ _ (topCtx G T))
	(pop:forall G i T (a:AtCtx G i T) (IHa:P _ _ _ a) T',P _ _ _ (popCtx a T'))
G : forall i T (a:AtCtx G i T),P _ _ _ a := match G with ctx _ s => atCtxIndS P top pop s end.

Inductive ExAtCtx G i : Type := exAtCtx T (a:AtCtx G i T).
Arguments exAtCtx [G i T] a.

Definition xa_T G i (xa:ExAtCtx G i) := match xa with exAtCtx T _ => T end.
Definition xa_a G i (xa:ExAtCtx G i) : AtCtx G i (xa_T xa) := match xa with exAtCtx _ a => a end.

Definition atCtxUniq G i T1 (a1:AtCtx G i T1) : forall T2 (a2:AtCtx G i T2),
exAtCtx a1 = exAtCtx a2.
	induction a1 as [| ? ? T1] using AtCtx_rect;intros.

	destruct a2.
	reflexivity.

	change (PopCtx T' (AtCtx G i) T2) in a2.
	destruct a2 as (T2,a2).
	exact (tr (fun xa=>exAtCtx (popCtx a1 T') = exAtCtx (popCtx (xa_a xa) T')) (IHa1 _ a2) eq_refl).
Defined.
Arguments atCtxUniq [G i T1] a1 [T2] a2.

Definition envProj G i T (a:AtCtx G i T) : forall g,T g.
	induction a using AtCtx_rect.

	exact (@projT2 _ _).

	exact (fun g=>IHa (projT1 g)).
Defined.
Arguments envProj [G i T] a g.

Remark envProj_top G T : envProj (topCtx G T) = @projT2 _ _.
	reflexivity.
Qed.

Lemma envProj_pop G i : forall T (a:AtCtx G i T) T',(fun g=>envProj a (projT1 g)) = envProj (popCtx a T').
	destruct G.
	simpl CtxTp.
	intros.
	reflexivity.
Qed.
Arguments envProj_pop [G i T] a T'.

(* Telescopes (Iterated context extension) *)

Inductive TeleS GL : nat->Ctx->Type :=
	empTeleS : TeleS GL O GL |
	extTeleS n G (xg:TeleS GL n G) T : TeleS GL (S n) (ExtCtx G T).

Definition extTeleSInv GL n G T (xg:TeleS GL (S n) (ExtCtx G T)) (P:forall n G T,TeleS GL n (ExtCtx G T)->Type)
	(ext:forall xg:TeleS GL n G,P _ _ _ (extTeleS xg T))
: P _ _ _ xg.
	pose (P' n Gx (xg:TeleS GL n Gx) := forall ne:IsExtCtx Gx,
		P _ _ _ (tr (TeleS GL n) (extCtxUnfold ne) xg)).
	assert (Peq := match G return forall T xg,P (S n) G T xg = P _ (ctx (ctxSc G)) _ xg
		with ctx _ _ => fun _ _=>eq_refl end T).
	apply (tr (fun C=>C) (eq_sym (Peq _))).
	generalize I.
	refine (match xg in TeleS _ Sn Gx return (Sn = S n)->(ExtCtx G T = Gx)->P' _ _ xg with
		empTeleS => fun e=>match O_S _ e with end |
		extTeleS _ _ xg0 _ => fun Hn HG=>_
	end eq_refl eq_refl).
	revert xg0.
	apply (tr (fun _=>_) (eq_sym (Sinj Hn))).
	apply (tr (fun GT=>forall xg,P' _ _ (extTeleS xg (projT2 GT))) (extCtxInj HG)).
	simpl.
	intros ? ?.
	simpl.
	exact (tr (fun C=>C) (Peq _) (ext _)).
Defined.

Lemma extTeleSInvEq GL n G P : forall T (xg:TeleS GL n G) ext,ext xg = extTeleSInv (extTeleS xg T) P ext.
	destruct G.
	simpl CtxTp.
	intros.
	exact (eq_refl (ext xg)).
Qed.

Fixpoint unExt GL n G (xg:TeleS GL n G) : G->GL := match xg with
	empTeleS => fun g=>g |
	extTeleS _ _ xg _ => fun g=>unExt xg (projT1 g)
end.

Fixpoint atUnExt GL n G i T (xg:TeleS GL n G) (a:AtCtx GL i T) : AtCtx G (n + i) (fun g=>T (unExt xg g)) := match xg with
	empTeleS => a |
	extTeleS _ _ xg T' => popCtx (atUnExt i T xg a) T'
end.
Arguments atUnExt [GL n G i T] xg a.

Lemma envProj_UnExt GL n G i T (xg:TeleS GL n G) (a:AtCtx GL i T) : (fun g=>envProj a (unExt xg g)) = envProj (atUnExt xg a).
	induction xg as [| ? ? ? ? T'].

	exact (eq_refl (envProj a)).

	simpl atUnExt.
	apply (tr (fun x=>_ = x) (envProj_pop (atUnExt xg a) T')).
	apply (tr (fun x=>_ = fun g=>x (projT1 g)) IHxg).
	reflexivity.
Qed.
Arguments envProj_UnExt [GL n G i T] xg a.

(* Telescope Computation *)

Inductive TeleComp GL' n G : Type := mkTeleComp G' (xg':TeleS GL' n G') (f':G'->G).

Definition xc_G' GL' n G (xc:TeleComp GL' n G) := match xc with mkTeleComp G' _ _ => G' end.
Definition xc_xg' GL' n G (xc:TeleComp GL' n G) : TeleS GL' n (xc_G' xc) := match xc with mkTeleComp _ xg' _ => xg' end.
Definition xc_f' GL' n G (xc:TeleComp GL' n G) : xc_G' xc->G := match xc with mkTeleComp _ _ f' => f' end.

Definition teleComp GL n G (xg:TeleS GL n G) (GL':Ctx) (f:GL'->GL) : TeleComp GL' n G.
	induction xg.

	exact (mkTeleComp (empTeleS _) f).

	refine (mkTeleComp (extTeleS (xc_xg' IHxg) _)
		(fun (g:sigT (fun g=>T (xc_f' IHxg g)))=>existT _ (xc_f' IHxg (projT1 g)) _)).
	exact (projT2 g).
Defined.

(* Bump *)

Definition xcBump GL n GL' (X:TeleS GL n GL') l G (xg:TeleS GL l G) := teleComp xg GL' (unExt X).

Definition CtxBump GL n GL' (X:TeleS GL n GL') l G (xg:TeleS GL l G) := xc_G' (xcBump X xg).

Definition elBump GL n GL' (X:TeleS GL n GL') l G (xg:TeleS GL l G) T (t:forall g,T g) (g:CtxBump X xg) :=
	t (xc_f' (xcBump X xg) g).
Arguments elBump [GL n GL'] X [l G] xg [T] t g.

Definition atBumpLo GL n GL' l G i T (X:TeleS GL n GL') (xg:TeleS GL l G) (a:AtCtx G i T) (Ho:ltd i l) : AtCtx (CtxBump X xg) i (elBump X xg T).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);simpl;intro.

	apply (extTeleSInv xg).
	clear xg.
	intro.
	change (AtCtx (ExtCtx (CtxBump X xg) (elBump X xg T)) O (fun g=>elBump X xg T (projT1 g))).
	apply topCtx.

	revert T a IHa.
	apply (extTeleSInv xg).
	clear xg.
	intros.
	change (AtCtx (ExtCtx (CtxBump X xg) (elBump X xg T')) (S i) (fun g=>elBump X xg T (projT1 g))).
	apply popCtx.
	exact (IHa _ Ho xg).
Defined.
Arguments atBumpLo [GL n GL' l G i T] X xg a Ho.

Lemma envProj_BumpLo GL n GL' l G i T (X:TeleS GL n GL') (xg:TeleS GL l G) (a:AtCtx G i T) (Ho:ltd i l) :
elBump X xg (envProj a) = envProj (atBumpLo X xg a Ho).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	revert Ho.
	apply (extTeleSInv xg).
	clear xg.
	revert T.
	destruct G.
	simpl.
	intros.
	reflexivity.

	revert T a IHa Ho.
	apply (extTeleSInv xg).
	clear xg.
	revert T'.
	destruct G.
	simpl CtxTp.
	intros.
	change (elBump X (extTeleS xg T') (envProj (popCtx a T')) =
		envProj (popCtx (atBumpLo X xg a Ho) (elBump X xg T'))).
	apply (tr (fun x=>_ = x) (envProj_pop (atBumpLo X xg a Ho) (elBump X xg T'))).
	apply (tr (fun x=>_ = fun g=>x (projT1 g)) (IHa _ Ho xg)).
	reflexivity.
Qed.
Arguments envProj_BumpLo [GL n GL' l G i T] X xg a Ho.

Definition atBumpHi GL n GL' l G i T (X:TeleS GL n GL') (xg:TeleS GL l G) (a:AtCtx G i T) (Ho:ltd l (S i)) : AtCtx (CtxBump X xg) (n + i) (elBump X xg T).
	revert i Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	exact (atUnExt X a).

	intro.
	destruct i.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	apply (tr (fun v=>AtCtx _ v _) (plus_n_Sm n i)).
	change (PopCtx T' (AtCtx G i) T) in a.
	destruct a.
	change (AtCtx (ExtCtx (CtxBump X xg) (elBump X xg T')) (S (n + i)) (fun g=>elBump X xg T (projT1 g))).
	apply popCtx.
	exact (IHxg _ Ho _ a).
Defined.
Arguments atBumpHi [GL n GL' l G i T] X xg a Ho.

Lemma envProj_BumpHi GL n GL' l G i T (X:TeleS GL n GL') (xg:TeleS GL l G) (a:AtCtx G i T) (Ho:ltd l (S i)) :
elBump X xg (envProj a) = envProj (atBumpHi X xg a Ho).
	revert i Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	simpl.
	apply (tr (fun x=>_ = x) (envProj_UnExt X a)).
	reflexivity.

	intro.
	destruct i.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G i) T) in a.
	destruct a.
	simpl atBumpHi.
	destruct (plus_n_Sm n i).
	simpl tr.
	apply (tr (fun x=>elBump X (extTeleS xg T') x = _) (envProj_pop a T')).
	apply (tr (fun x=>_ = x) (envProj_pop (atBumpHi X xg a Ho) (elBump X xg T'))).
	apply (tr (fun x=>_ = fun g=>x (projT1 g)) (IHxg _ Ho _ a)).
	reflexivity.
Qed.
Arguments envProj_BumpHi [GL n GL' l G i T] X xg a Ho.

(* Subst *)

Definition xcSubst GL B l G (xg:TeleS (ExtCtx GL B) l G) (b:forall g,B g) := teleComp xg GL (fun g=>existT B g (b g)).

Definition CtxSubst GL B l G (xg:TeleS (ExtCtx GL B) l G) b := xc_G' (xcSubst xg b).

Definition elSubst GL B l G (xg:TeleS (ExtCtx GL B) l G) b T (t:forall g,T g) (g:CtxSubst xg b) :=
	t (xc_f' (xcSubst xg b) g).
Arguments elSubst [GL B l G] xg b [T] t g.

Definition atSubstLt GL B l G i T (xg:TeleS (ExtCtx GL B) l G) b (a:AtCtx G i T) (Ho:ltd i l) :
AtCtx (CtxSubst xg b) i (elSubst xg b T).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	apply (extTeleSInv xg).
	clear xg.
	intro.
	apply (topCtx (CtxSubst xg b) (elSubst xg b T)).

	revert T a IHa.
	apply (extTeleSInv xg).
	clear xg.
	intros.
	exact (popCtx (IHa _ Ho xg) (elSubst xg b T')).
Defined.
Arguments atSubstLt [GL B l G i T] xg b a Ho.

Lemma envProj_SubstLt GL B l G i T (xg:TeleS (ExtCtx GL B) l G) b (a:AtCtx G i T) (Ho:ltd i l) :
elSubst xg b (envProj a) = envProj (atSubstLt xg b a Ho).
	revert l Ho xg.
	induction a using AtCtx_rect;intro;(destruct l;intro;[exact (match Ho with end) |]);intro.

	revert Ho.
	apply (extTeleSInv xg).
	clear xg.
	revert T.
	destruct G.
	simpl CtxTp.
	intros.
	reflexivity.

	revert T a IHa Ho.
	apply (extTeleSInv xg).
	clear xg.
	revert T'.
	destruct G.
	simpl CtxTp.
	intros.
	change (elSubst (extTeleS xg T') b (envProj (popCtx a T')) =
		envProj (popCtx (atSubstLt xg b a Ho) (elSubst xg b T'))).
	apply (tr (fun x=>_ = x) (envProj_pop (atSubstLt xg b a Ho) (elSubst xg b T'))).
	apply (tr (fun x=>_ = fun g=>x (projT1 g)) (IHa _ Ho xg)).
	reflexivity.
Qed.
Arguments envProj_SubstLt [GL B l G i T] xg b a Ho.

Definition atSubstGt GL B l G i T (xg:TeleS (ExtCtx GL B) l G) b (a:AtCtx G (S i) T) (Ho:ltd l (S i)) :
AtCtx (CtxSubst xg b) i (elSubst xg b T).
	revert i Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	change (PopCtx B (AtCtx GL i) T) in a.
	destruct a.
	exact a.

	intro.
	destruct i.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G (S i)) T) in a.
	destruct a.
	exact (popCtx (IHxg _ Ho _ a) (elSubst xg b T')).
Defined.
Arguments atSubstGt [GL B l G i T] xg b a Ho.

Lemma envProj_SubstGt GL B l G i T (xg:TeleS (ExtCtx GL B) l G) b (a:AtCtx G (S i) T) (Ho:ltd l (S i)) :
elSubst xg b (envProj a) = envProj (atSubstGt xg b a Ho).
	revert i Ho T a.
	induction xg as [| l ? ? ? T'].

	intros.
	change (PopCtx B (AtCtx GL i) T) in a.
	destruct a.
	change (elSubst (empTeleS (ExtCtx GL B)) b (envProj (popCtx a B)) = envProj a).
	apply (tr (fun x=>elSubst (empTeleS _) b x = _) (envProj_pop a B)).
	reflexivity.

	intro.
	destruct i.
		intro.
		exact (match ltd_n_O Ho with end).
	intros.
	change (PopCtx T' (AtCtx G (S i)) T) in a.
	destruct a.
	change (elSubst (extTeleS xg T') b (envProj (popCtx a T')) =
		envProj (popCtx (atSubstGt xg b a Ho) (elSubst xg b T'))).
	apply (tr (fun x=>elSubst (extTeleS xg T') b x = _) (envProj_pop a T')).
	apply (tr (fun x=>_ = x) (envProj_pop (atSubstGt xg b a Ho) (elSubst xg b T'))).
	apply (tr (fun x=>_ = fun g=>x (projT1 g)) (IHxg _ Ho _ a)).
	reflexivity.
Qed.
Arguments envProj_SubstGt [GL B l G i T] xg b a Ho.

Lemma xcSubstEqUnExt GL B l G (xg:TeleS (ExtCtx GL B) l G) b : forall B' (a:AtCtx G l B'),
	let X : TeleS GL l (CtxSubst xg b) := xc_xg' (xcSubst xg b) in
existT (fun T:_->Typ=>forall g,T g) (fun g=>B (unExt X g)) (fun g=>b (unExt X g)) =
existT _ (elSubst xg b B') (elSubst xg b (envProj a)).
	induction xg as [| l];intros;unfold AtCtx in a;simpl in a.

	destruct a.
	unfold elSubst.
	unfold CtxSubst.
	simpl.
	reflexivity.

	set (Tt (T:_->Typ) := forall g,T g).
	change (CtxSubst (extTeleS xg T) b) with (ExtCtx (CtxSubst xg b) (elSubst xg b T)) in Tt.
	destruct a as (B').
	change (AtCtx G l B') in a.
	simpl unExt.
	clear X.
	set (X := xc_xg' (xcSubst xg b)).
	apply (tr (fun x:forall g,B' (projT1 g)=>_ = existT Tt _ (elSubst (extTeleS xg T) b x)) (envProj_pop a T)).
	apply (tr (fun s:{T:_->Typ & forall g,T g}=>_ = existT Tt (fun g=>projT1 s (projT1 g)) (fun g=>projT2 s (projT1 g))) (IHxg _ a)).
	simpl.
	fold X.
	reflexivity.
Qed.
Arguments xcSubstEqUnExt [GL B l G] xg b [B'] a.

End Contex.


(* Check let-ins in fix and Fixpoint *)

Definition foo := fix f (m : nat) (o := true) (n : nat) {struct n} :=
  match n with 0 => 0 | S n' => f 0 n' end.

Fixpoint f (m : nat) (o := true) (n : nat) {struct n} :=
  match n with 0 => 0 | S n' => f 0 n' end.