(************************************************************************)
(*         *   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)         *)
(************************************************************************)

Require Export List.
Require Export Sorted.
Require Export Setoid Basics Morphisms.
Set Implicit Arguments.
Unset Strict Implicit.
(* Set Universe Polymorphism. *)
(** * Logical relations over lists with respect to a setoid equality
      or ordering. *)

(** This can be seen as a complement of predicate [lelistA] and [sort]
    found in [Sorting]. *)

Section Type_with_equality.
Variable A : Type.
Variable eqA : A -> A -> Prop.

(** Being in a list modulo an equality relation over type [A]. *)

Inductive InA (x : A) : list A -> Prop :=
  | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l)
  | InA_cons_tl : forall y l, InA x l -> InA x (y :: l).

Hint Constructors InA.

(** TODO: it would be nice to have a generic definition instead
    of the previous one. Having [InA = Exists eqA] raises too
    many compatibility issues. For now, we only state the equivalence: *)

Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l.
Proof. split; induction 1; auto. Qed.

Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l.
Proof.
 intuition. invlist InA; auto.
Qed.

Lemma InA_nil : forall x, InA x nil <-> False.
Proof.
 intuition. invlist InA.
Qed.

(** An alternative definition of [InA]. *)

Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l.
Proof.
 intros; rewrite InA_altdef, Exists_exists; firstorder.
Qed.

(** A list without redundancy modulo the equality over [A]. *)

Inductive NoDupA : list A -> Prop :=
  | NoDupA_nil : NoDupA nil
  | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l).

Hint Constructors NoDupA.

(** An alternative definition of [NoDupA] based on [ForallOrdPairs] *)

Lemma NoDupA_altdef : forall l,
 NoDupA l <-> ForallOrdPairs (complement eqA) l.
Proof.
 split; induction 1; constructor; auto.
 rewrite Forall_forall. intros b Hb.
 intro Eq; elim H. rewrite InA_alt. exists b; auto.
 rewrite InA_alt; intros (a' & Haa' & Ha').
 rewrite Forall_forall in H. exact (H a' Ha' Haa').
Qed.

(** lists with same elements modulo [eqA] *)

Definition inclA l l' := forall x, InA x l -> InA x l'.
Definition equivlistA l l' := forall x, InA x l <-> InA x l'.

Lemma incl_nil l : inclA nil l.
Proof. intro. intros. inversion H. Qed.
Hint Resolve incl_nil : list.

(** lists with same elements modulo [eqA] at the same place *)

Inductive eqlistA : list A -> list A -> Prop :=
  | eqlistA_nil : eqlistA nil nil
  | eqlistA_cons : forall x x' l l',
      eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l').

Hint Constructors eqlistA.

(** We could also have written [eqlistA = Forall2 eqA]. *)

Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'.
Proof. split; induction 1; auto. Qed.

(** Results concerning lists modulo [eqA] *)

Hypothesis eqA_equiv : Equivalence eqA.
Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv).
Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv).
Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv).

Hint Resolve eqarefl eqatrans.
Hint Immediate eqasym.

Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA.

(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *)

Global Instance equivlist_equiv : Equivalence equivlistA.
Proof.
 firstorder.
Qed.

Global Instance eqlistA_equiv : Equivalence eqlistA.
Proof.
 constructor; red.
 induction x; auto.
 induction 1; auto.
 intros x y z H; revert z; induction H; auto.
 inversion 1; subst; auto. invlist eqlistA; eauto with *.
Qed.
(** Moreover, [eqlistA] implies [equivlistA]. A reverse result
    will be proved later for sorted list without duplicates. *)

Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA.
Proof.
  intros x x' H. induction H.
  intuition.
  red; intros.
  rewrite 2 InA_cons.
  rewrite (IHeqlistA x0), H; intuition.
Qed.

(** InA is compatible with eqA (for its first arg) and with
    equivlistA (and hence eqlistA) for its second arg *)

Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA.
Proof.
 intros x x' Hxx' l l' Hll'. rewrite (Hll' x).
 rewrite 2 InA_alt; firstorder.
Qed.

(** For compatibility, an immediate consequence of [InA_compat] *)

Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l.
Proof.
 intros l x y H H'. rewrite <- H. auto.
Qed.
Hint Immediate InA_eqA.

Lemma In_InA : forall l x, In x l -> InA x l.
Proof.
 simple induction l; simpl; intuition.
 subst; auto.
Qed.
Hint Resolve In_InA.

Lemma InA_split : forall l x, InA x l ->
 exists l1 y l2, eqA x y /\ l = l1++y::l2.
Proof.
induction l; intros; inv.
exists (@nil A); exists a; exists l; auto.
destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))).
exists (a::l1); exists y; exists l2; auto.
split; simpl; f_equal; auto.
Qed.

Lemma InA_app : forall l1 l2 x,
 InA x (l1 ++ l2) -> InA x l1 \/ InA x l2.
Proof.
 induction l1; simpl in *; intuition.
 inv; auto.
 elim (IHl1 l2 x H0); auto.
Qed.

Lemma InA_app_iff : forall l1 l2 x,
 InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2.
Proof.
 split.
 apply InA_app.
 destruct 1; generalize H; do 2 rewrite InA_alt.
 destruct 1 as (y,(H1,H2)); exists y; split; auto.
 apply in_or_app; auto.
 destruct 1 as (y,(H1,H2)); exists y; split; auto.
 apply in_or_app; auto.
Qed.

Lemma InA_rev : forall p m,
 InA p (rev m) <-> InA p m.
Proof.
 intros; do 2 rewrite InA_alt.
 split; intros (y,H); exists y; intuition.
 rewrite In_rev; auto.
 rewrite <- In_rev; auto.
Qed.

(** Some more facts about InA *)

Lemma InA_singleton x y : InA x (y::nil) <-> eqA x y.
Proof.
 rewrite InA_cons, InA_nil; tauto.
Qed.

Lemma InA_double_head x y l :
 InA x (y :: y :: l) <-> InA x (y :: l).
Proof.
 rewrite !InA_cons; tauto.
Qed.

Lemma InA_permute_heads x y z l :
 InA x (y :: z :: l) <-> InA x (z :: y :: l).
Proof.
 rewrite !InA_cons; tauto.
Qed.

Lemma InA_app_idem x l : InA x (l ++ l) <-> InA x l.
Proof.
 rewrite InA_app_iff; tauto.
Qed.

Section NoDupA.

Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' ->
  (forall x, InA x l -> InA x l' -> False) ->
  NoDupA (l++l').
Proof.
induction l; simpl; auto; intros.
inv.
constructor.
rewrite InA_alt; intros (y,(H4,H5)).
destruct (in_app_or _ _ _ H5).
elim H2.
rewrite InA_alt.
exists y; auto.
apply (H1 a).
auto.
rewrite InA_alt.
exists y; auto.
apply IHl; auto.
intros.
apply (H1 x); auto.
Qed.

Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l).
Proof.
induction l.
simpl; auto.
simpl; intros.
inv.
apply NoDupA_app; auto.
constructor; auto.
intro; inv.
intros x.
rewrite InA_alt.
intros (x1,(H2,H3)).
intro; inv.
destruct H0.
rewrite <- H4, H2.
apply In_InA.
rewrite In_rev; auto.
Qed.

Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l').
Proof.
 induction l; simpl in *; intros; inv; auto.
 constructor; eauto.
 contradict H0.
 rewrite InA_app_iff in *.
 rewrite InA_cons.
 intuition.
Qed.

Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l').
Proof.
 induction l; simpl in *; intros; inv; auto.
 constructor; eauto.
 assert (H2:=IHl _ _ H1).
 inv.
 rewrite InA_cons.
 red; destruct 1.
 apply H0.
 rewrite InA_app_iff in *; rewrite InA_cons; auto.
 apply H; auto.
 constructor.
 contradict H0.
 rewrite InA_app_iff in *; rewrite InA_cons; intuition.
 eapply NoDupA_split; eauto.
Qed.

Lemma NoDupA_singleton x : NoDupA (x::nil).
Proof.
 repeat constructor. inversion 1.
Qed.

End NoDupA.

Section EquivlistA.

Global Instance equivlistA_cons_proper:
 Proper (eqA ==> equivlistA ==> equivlistA) (@cons A).
Proof.
 intros ? ? E1 ? ? E2 ?; now rewrite !InA_cons, E1, E2.
Qed.

Global Instance equivlistA_app_proper:
 Proper (equivlistA ==> equivlistA ==> equivlistA) (@app A).
Proof.
 intros ? ? E1 ? ? E2 ?. now rewrite !InA_app_iff, E1, E2.
Qed.

Lemma equivlistA_cons_nil x l : ~ equivlistA (x :: l) nil.
Proof.
 intros E. now eapply InA_nil, E, InA_cons_hd.
Qed.

Lemma equivlistA_nil_eq l : equivlistA l nil -> l = nil.
Proof.
 destruct l.
 - trivial.
 - intros H. now apply equivlistA_cons_nil in H.
Qed.

Lemma equivlistA_double_head x l : equivlistA (x :: x :: l) (x :: l).
Proof.
 intro. apply InA_double_head.
Qed.

Lemma equivlistA_permute_heads x y l :
 equivlistA (x :: y :: l) (y :: x :: l).
Proof.
 intro. apply InA_permute_heads.
Qed.

Lemma equivlistA_app_idem l : equivlistA (l ++ l) l.
Proof.
 intro. apply InA_app_idem.
Qed.

Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y ->
 NoDupA (x::l) -> NoDupA (l1++y::l2) ->
 equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2).
Proof.
 intros; intro a.
 generalize (H2 a).
 rewrite !InA_app_iff, !InA_cons.
 inv.
 assert (SW:=NoDupA_swap H1). inv.
 rewrite InA_app_iff in H0.
 split; intros.
 assert (~eqA a x) by (contradict H3; rewrite <- H3; auto).
 assert (~eqA a y) by (rewrite <- H; auto).
 tauto.
 assert (OR : eqA a x \/ InA a l) by intuition. clear H6.
 destruct OR as [EQN|INA]; auto.
 elim H0.
 rewrite <-H,<-EQN; auto.
Qed.

End EquivlistA.

Section Fold.

Variable B:Type.
Variable eqB:B->B->Prop.
Variable st:Equivalence eqB.
Variable f:A->B->B.
Variable i:B.
Variable Comp:Proper (eqA==>eqB==>eqB) f.

Lemma fold_right_eqlistA :
   forall s s', eqlistA s s' ->
   eqB (fold_right f i s) (fold_right f i s').
Proof.
induction 1; simpl; auto with relations.
apply Comp; auto.
Qed.

(** Fold with restricted [transpose] hypothesis. *)

Section Fold_With_Restriction.
Variable R : A -> A -> Prop.
Hypothesis R_sym : Symmetric R.
Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.

(*

(** [ForallOrdPairs R] is compatible with [equivlistA] over the
    lists without duplicates, as long as the relation [R]
    is symmetric and compatible with [eqA]. To prove this fact,
    we use an auxiliary notion: "forall distinct pairs, ...".
*)

Definition ForallNeqPairs :=
 ForallPairs (fun a b => ~eqA a b -> R a b).

(** [ForallOrdPairs] and [ForallNeqPairs] are related, but not completely
    equivalent. For proving one implication, we need to know that the
    list has no duplicated elements... *)

Lemma ForallNeqPairs_ForallOrdPairs : forall l, NoDupA l ->
 ForallNeqPairs l -> ForallOrdPairs R l.
Proof.
 induction l; auto.
 constructor. inv.
 rewrite Forall_forall; intros b Hb.
 apply H0; simpl; auto.
 contradict H1; rewrite H1; auto.
 apply IHl.
 inv; auto.
 intros b c Hb Hc Hneq.
 apply H0; simpl; auto.
Qed.

(** ... and for proving the other implication, we need to be able
   to reverse relation [R]. *)

Lemma ForallOrdPairs_ForallNeqPairs : forall l,
 ForallOrdPairs R l -> ForallNeqPairs l.
Proof.
 intros l Hl x y Hx Hy N.
 destruct (ForallOrdPairs_In Hl x y Hx Hy) as [H|[H|H]].
 subst; elim N; auto.
 assumption.
 apply R_sym; assumption.
Qed.

*)

(** Compatibility of [ForallOrdPairs] with respect to [inclA]. *)

Lemma ForallOrdPairs_inclA : forall l l',
 NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'.
Proof.
induction l' as [|x l' IH].
constructor.
intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto.
rewrite Forall_forall; intros y Hy.
assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto).
 apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx').
assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto).
 apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy').
rewrite Hxx', Hyy'.
destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto.
absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto.
Qed.

(** Two-argument functions that allow to reorder their arguments. *)
Definition transpose (f : A -> B -> B) :=
  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)).

(** A version of transpose with restriction on where it should hold *)
Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) :=
  forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)).

Variable TraR :transpose_restr R f.

Lemma fold_right_commutes_restr :
  forall s1 s2 x, ForallOrdPairs R (s1++x::s2) ->
  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
Proof.
induction s1; simpl; auto; intros.
reflexivity.
transitivity (f a (f x (fold_right f i (s1++s2)))).
apply Comp; auto.
apply IHs1.
invlist ForallOrdPairs; auto.
apply TraR.
invlist ForallOrdPairs; auto.
rewrite Forall_forall in H0; apply H0.
apply in_or_app; simpl; auto.
Qed.

Lemma fold_right_equivlistA_restr :
  forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
  equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
Proof.
 simple induction s.
 destruct s'; simpl.
 intros; reflexivity.
 unfold equivlistA; intros.
 destruct (H2 a).
 assert (InA a nil) by auto; inv.
 intros x l Hrec s' N N' F E; simpl in *.
 assert (InA x s') by (rewrite <- (E x); auto).
 destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
 subst s'.
 transitivity (f x (fold_right f i (s1++s2))).
 apply Comp; auto.
 apply Hrec; auto.
 inv; auto.
 eapply NoDupA_split; eauto.
 invlist ForallOrdPairs; auto.
 eapply equivlistA_NoDupA_split; eauto.
 transitivity (f y (fold_right f i (s1++s2))).
 apply Comp; auto. reflexivity.
 symmetry; apply fold_right_commutes_restr.
 apply ForallOrdPairs_inclA with (x::l); auto.
  red; intros; rewrite E; auto.
Qed.

Lemma fold_right_add_restr :
  forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s ->
  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
Proof.
 intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto.
Qed.

End Fold_With_Restriction.

(** we now state similar results, but without restriction on transpose. *)

Variable Tra :transpose f.

Lemma fold_right_commutes : forall s1 s2 x,
  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
Proof.
induction s1; simpl; auto; intros.
reflexivity.
transitivity (f a (f x (fold_right f i (s1++s2)))); auto.
apply Comp; auto.
Qed.

Lemma fold_right_equivlistA :
  forall s s', NoDupA s -> NoDupA s' ->
  equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
Proof.
intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True);
 repeat red; auto.
apply ForallPairs_ForallOrdPairs; try red; auto.
Qed.

Lemma fold_right_add :
  forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s ->
  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
Proof.
 intros; apply (@fold_right_equivlistA s' (x::s)); auto.
Qed.

End Fold.

Section Fold2.

Variable B:Type.
Variable eqB:B->B->Prop.
Variable st:Equivalence eqB.
Variable f:A->B->B.
Variable Comp:Proper (eqA==>eqB==>eqB) f.

Lemma fold_right_eqlistA2 :
  forall s s' (i j:B) (heqij: eqB i j) (heqss': eqlistA s s'),
  eqB (fold_right f i s) (fold_right f j s').
Proof.
  intros s.
  induction s;intros.
  - inversion heqss'.
    subst.
    simpl.
    assumption.
  - inversion heqss'.
    subst.
    simpl.
    apply Comp.
    + assumption.
    + apply IHs;assumption.
Qed.

Section Fold2_With_Restriction.

Variable R : A -> A -> Prop.
Hypothesis R_sym : Symmetric R.
Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.

(** Two-argument functions that allow to reorder their arguments. *)
Definition transpose2 (f : A -> B -> B) :=
  forall (x y : A) (z z': B), eqB z z' -> eqB (f x (f y z)) (f y (f x z')).

(** A version of transpose with restriction on where it should hold *)
Definition transpose_restr2 (R : A -> A -> Prop)(f : A -> B -> B) :=
  forall (x y : A) (z z': B), R x y -> eqB z z' -> eqB (f x (f y z)) (f y (f x z')).

Variable TraR :transpose_restr2 R f.

Lemma fold_right_commutes_restr2 :
  forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) ->
  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))).
Proof.
induction s1; simpl; auto; intros.
- apply Comp.
  + destruct eqA_equiv. apply Equivalence_Reflexive.
  + eapply fold_right_eqlistA2.
    * assumption.
    * reflexivity.
- transitivity (f a (f x (fold_right f j (s1++s2)))).
  apply Comp; auto.
  eapply IHs1.
  assumption.
  invlist ForallOrdPairs; auto.
  apply TraR.
  invlist ForallOrdPairs; auto.
  rewrite Forall_forall in H0; apply H0.
  apply in_or_app; simpl; auto.
  reflexivity.
Qed.

Lemma fold_right_equivlistA_restr2 :
  forall s s' i j,
    NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
    equivlistA s s' -> eqB i j ->
    eqB (fold_right f i s) (fold_right f j s').
Proof.
 simple induction s.
 destruct s'; simpl.
 intros. assumption.
 unfold equivlistA; intros.
 destruct (H2 a).
 assert (InA a nil) by auto; inv.
 intros x l Hrec s' i j N N' F E eqij; simpl in *.
 assert (InA x s') by (rewrite <- (E x); auto).
 destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
 subst s'.
 transitivity (f x (fold_right f j (s1++s2))).
 - apply Comp; auto.
   apply Hrec; auto.
   inv; auto.
   eapply NoDupA_split; eauto.
   invlist ForallOrdPairs; auto.
   eapply equivlistA_NoDupA_split; eauto.
 - transitivity (f y (fold_right f i (s1++s2))).
   + apply Comp; auto.
     symmetry.
     apply fold_right_eqlistA2.
     * assumption.
     * reflexivity.
   + symmetry.
     apply fold_right_commutes_restr2.
     symmetry.
     assumption.
     apply ForallOrdPairs_inclA with (x::l); auto.
     red; intros; rewrite E; auto.
Qed.

Lemma fold_right_add_restr2 :
  forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s ->
  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
Proof.
 intros; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto.
Qed.

End Fold2_With_Restriction.

Variable Tra :transpose2 f.

Lemma fold_right_commutes2 : forall s1 s2 i x x',
  eqA x x' ->
  eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))).
Proof.
  induction s1;simpl;intros.
- apply Comp;auto.
  reflexivity.
- transitivity (f a (f x' (fold_right f i (s1++s2)))); auto.
  + apply Comp;auto.
  + apply Tra.
    reflexivity.
Qed.

Lemma fold_right_equivlistA2 :
  forall s s' i j, NoDupA s -> NoDupA s' -> eqB i j ->
  equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s').
Proof.
red in Tra.
intros; apply fold_right_equivlistA_restr2 with (R:=fun _ _ => True);
repeat red; auto.
apply ForallPairs_ForallOrdPairs; try red; auto.
Qed.

Lemma fold_right_add2 :
  forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s ->
  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
Proof.
 intros.
 replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto.
 eapply fold_right_equivlistA2;auto.
Qed.

End Fold2.

Section Remove.

Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.

Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }.
Proof.
induction l.
right; auto.
intro; inv.
destruct (eqA_dec x a).
left; auto.
destruct IHl.
left; auto.
right; intro; inv; contradiction.
Defined.

Fixpoint removeA (x : A) (l : list A) : list A :=
  match l with
    | nil => nil
    | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl)
  end.

Lemma removeA_filter : forall x l,
  removeA x l = filter (fun y => if eqA_dec x y then false else true) l.
Proof.
induction l; simpl; auto.
destruct (eqA_dec x a); auto.
rewrite IHl; auto.
Qed.

Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y.
Proof.
induction l; simpl; auto.
split.
intro; inv.
destruct 1; inv.
intros.
destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto.
rewrite IHl; split; destruct 1; split; auto.
inv; auto.
destruct H0; transitivity a; auto.
split.
intro; inv.
split; auto.
contradict Hnot.
transitivity y; auto.
rewrite (IHl x y) in H0; destruct H0; auto.
destruct 1; inv; auto.
right; rewrite IHl; auto.
Qed.

Lemma removeA_NoDupA :
  forall s x, NoDupA s ->  NoDupA (removeA x s).
Proof.
simple induction s; simpl; intros.
auto.
inv.
destruct (eqA_dec x a); simpl; auto.
constructor; auto.
rewrite removeA_InA.
intuition.
Qed.

Lemma removeA_equivlistA : forall l l' x,
  ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l').
Proof.
unfold equivlistA; intros.
rewrite removeA_InA.
split; intros.
rewrite <- H0; split; auto.
contradict H.
apply InA_eqA with x0; auto.
rewrite <- (H0 x0) in H1.
destruct H1.
inv; auto.
elim H2; auto.
Qed.

End Remove.

(** Results concerning lists modulo [eqA] and [ltA] *)

Variable ltA : A -> A -> Prop.
Hypothesis ltA_strorder : StrictOrder ltA.
Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA.

Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder).

Hint Resolve sotrans.

Notation InfA:=(lelistA ltA).
Notation SortA:=(sort ltA).

Hint Constructors lelistA sort.

Lemma InfA_ltA :
 forall l x y, ltA x y -> InfA y l -> InfA x l.
Proof.
 destruct l; constructor. inv; eauto.
Qed.

Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA.
Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *)
 intros x x' Hxx' l l' Hll'.
 inversion_clear Hll'.
 intuition.
 split; intro; inv; constructor.
 rewrite <- Hxx', <- H; auto.
 rewrite Hxx', H; auto.
Qed.

(** For compatibility, can be deduced from [InfA_compat] *)
Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l.
Proof using eqA_equiv ltA_compat.
 intros H; now rewrite H.
Qed.
Hint Immediate InfA_ltA InfA_eqA.

Lemma SortA_InfA_InA :
 forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x.
Proof.
 simple induction l.
 intros. inv.
 intros. inv.
 setoid_replace x with a; auto.
 eauto.
Qed.

Lemma In_InfA :
 forall l x, (forall y, In y l -> ltA x y) -> InfA x l.
Proof.
 simple induction l; simpl; intros; constructor; auto.
Qed.

Lemma InA_InfA :
 forall l x, (forall y, InA y l -> ltA x y) -> InfA x l.
Proof.
 simple induction l; simpl; intros; constructor; auto.
Qed.

(* In fact, this may be used as an alternative definition for InfA: *)

Lemma InfA_alt :
 forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)).
Proof.
split.
intros; eapply SortA_InfA_InA; eauto.
apply InA_InfA.
Qed.

Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2).
Proof.
 induction l1; simpl; auto.
 intros; inv; auto.
Qed.

Lemma SortA_app :
 forall l1 l2, SortA l1 -> SortA l2 ->
 (forall x y, InA x l1 -> InA y l2 -> ltA x y) ->
 SortA (l1 ++ l2).
Proof.
 induction l1; simpl in *; intuition.
 inv.
 constructor; auto.
 apply InfA_app; auto.
 destruct l2; auto.
Qed.

Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l.
Proof.
 simple induction l; auto.
 intros x l' H H0.
 inv.
 constructor; auto.
 intro.
 apply (StrictOrder_Irreflexive x).
 eapply SortA_InfA_InA; eauto.
Qed.

(** Some results about [eqlistA] *)

Section EqlistA.

Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'.
Proof.
induction 1; auto; simpl; congruence.
Qed.

Global Instance app_eqlistA_compat :
 Proper (eqlistA==>eqlistA==>eqlistA) (@app A).
Proof.
 repeat red; induction 1; simpl; auto.
Qed.

(** For compatibility, can be deduced from app_eqlistA_compat **)
Lemma eqlistA_app : forall l1 l1' l2 l2',
   eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2').
Proof.
intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity.
Qed.

Lemma eqlistA_rev_app : forall l1 l1',
   eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' ->
   eqlistA ((rev l1)++l2) ((rev l1')++l2').
Proof.
induction 1; auto.
simpl; intros.
do 2 rewrite app_ass; simpl; auto.
Qed.

Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A).
Proof.
repeat red. intros.
rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)).
apply eqlistA_rev_app; auto.
Qed.

Lemma eqlistA_rev : forall l1 l1',
   eqlistA l1 l1' -> eqlistA (rev l1) (rev l1').
Proof.
apply rev_eqlistA_compat.
Qed.

Lemma SortA_equivlistA_eqlistA : forall l l',
   SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'.
Proof.
induction l; destruct l'; simpl; intros; auto.
destruct (H1 a); assert (InA a nil) by auto; inv.
destruct (H1 a); assert (InA a nil) by auto; inv.
inv.
assert (forall y, InA y l -> ltA a y).
intros; eapply SortA_InfA_InA with (l:=l); eauto.
assert (forall y, InA y l' -> ltA a0 y).
intros; eapply SortA_InfA_InA with (l:=l'); eauto.
clear H3 H4.
assert (eqA a a0).
 destruct (H1 a).
 destruct (H1 a0).
 assert (InA a (a0::l')) by auto. inv; auto.
 assert (InA a0 (a::l)) by auto. inv; auto.
 elim (StrictOrder_Irreflexive a); eauto.
constructor; auto.
apply IHl; auto.
split; intros.
destruct (H1 x).
assert (InA x (a0::l')) by auto. inv; auto.
rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto.
destruct (H1 x).
assert (InA x (a::l)) by auto. inv; auto.
rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto.
Qed.

End EqlistA.

(** A few things about [filter] *)

Section Filter.

Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l).
Proof.
induction l; simpl; auto.
intros; inv; auto.
destruct (f a); auto.
constructor; auto.
apply In_InfA; auto.
intros.
rewrite filter_In in H; destruct H.
eapply SortA_InfA_InA; eauto.
Qed.
Arguments eq {A} x _.

Lemma filter_InA : forall f, Proper (eqA==>eq) f ->
 forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
Proof.
clear sotrans ltA ltA_strorder ltA_compat.
intros; do 2 rewrite InA_alt; intuition.
destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition.
destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition.
  rewrite (H _ _ H0); auto.
destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition.
  rewrite <- (H _ _ H0); auto.
Qed.

Lemma filter_split :
 forall f, (forall x y, f x = true -> f y = false -> ltA x y) ->
 forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l.
Proof.
induction l; simpl; intros; auto.
inv.
rewrite IHl at 1; auto.
case_eq (f a); simpl; intros; auto.
assert (forall e, In e l -> f e = false).
  intros.
  assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)).
  case_eq (f e); simpl; intros; auto.
  elim (StrictOrder_Irreflexive e).
  transitivity a; auto.
replace (List.filter f l) with (@nil A); auto.
generalize H3; clear; induction l; simpl; auto.
case_eq (f a); auto; intros.
rewrite H3 in H; auto; try discriminate.
Qed.

End Filter.
End Type_with_equality.

Hint Constructors InA eqlistA NoDupA sort lelistA.

Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _.
Arguments equivlistA_nil_eq {A} eqA {eqA_equiv} l _.

Section Find.

Variable A B : Type.
Variable eqA : A -> A -> Prop.
Hypothesis eqA_equiv : Equivalence eqA.
Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.

Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B :=
 match l with
  | nil => None
  | (a,b)::l => if f a then Some b else findA f l
 end.

Lemma findA_NoDupA :
 forall l a b,
 NoDupA (fun p p' => eqA (fst p) (fst p')) l ->
 (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <->
  findA (fun a' => if eqA_dec a a' then true else false) l = Some b).
Proof.
set (eqk := fun p p' : A*B => eqA (fst p) (fst p')).
set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p').
induction l; intros; simpl.
split; intros; try discriminate.
invlist InA.
destruct a as (a',b'); rename a0 into a.
invlist NoDupA.
split; intros.
invlist InA.
compute in H2; destruct H2. subst b'.
destruct (eqA_dec a a'); intuition.
destruct (eqA_dec a a') as [HeqA|]; simpl.
contradict H0.
revert HeqA H2; clear - eqA_equiv.
induction l.
intros; invlist InA.
intros; invlist InA; auto.
destruct a0.
compute in H; destruct H.
subst b.
left; auto.
compute.
transitivity a; auto. symmetry; auto.
rewrite <- IHl; auto.
destruct (eqA_dec a a'); simpl in *.
left; split; simpl; congruence.
right. rewrite IHl; auto.
Qed.

End Find.

(** Compatibility aliases. [Proper] is rather to be used directly now.*)

Definition compat_bool {A} (eqA:A->A->Prop)(f:A->bool) :=
 Proper (eqA==>Logic.eq) f.

Definition compat_nat {A} (eqA:A->A->Prop)(f:A->nat) :=
 Proper (eqA==>Logic.eq) f.

Definition compat_P {A} (eqA:A->A->Prop)(P:A->Prop) :=
 Proper (eqA==>impl) P.

Definition compat_op {A B} (eqA:A->A->Prop)(eqB:B->B->Prop)(f:A->B->B) :=
 Proper (eqA==>eqB==>eqB) f.


(* Borrowed from my proof of Puiseux' theorem, file Fsummation.v
   with some changes, applied only on ℝ, not any ring and with
   some theorems more. The two versions should be unified one day. *)
(* Compiled with Coq 8.6 *)

Require Import Utf8 Reals Psatz.

Notation "x '≤' y" := (Rle x y) : R_scope.
Notation "x ≤ y < z" := (x <= y ∧ y < z)%nat (at level 70, y at next level).
Notation "x ≤ y ≤ z" := (x <= y ∧ y ≤ z)%nat (at level 70, y at next level).

Fixpoint summation_aux b len g :=
  match len with
  | O => 0%R
  | S len₁ => (g b + summation_aux (S b) len₁ g)%R
  end.

Definition summation b e g := summation_aux b (S e - b) g.

Notation "'Σ' ( i = b , e ) , g" := (summation b e (λ i, (g)%R))
  (at level 0, i at level 0, b at level 60, e at level 60, g at level 0).

Theorem summation_aux_eq_compat : ∀ g h b₁ b₂ len,
  (∀ i, 0 ≤ i < len → (g (b₁ + i)%nat = h (b₂ + i)%nat)%R)
  → (summation_aux b₁ len g = summation_aux b₂ len h)%R.
Proof.
intros g h b₁ b₂ len Hgh.
revert b₁ b₂ Hgh.
induction len; intros; [ easy | simpl ].
erewrite IHlen.
 f_equal.
 assert (0 ≤ 0 < S len) as H.
  split; [ easy | apply Nat.lt_0_succ ].

  apply Hgh in H.
  now do 2 rewrite Nat.add_0_r in H.

 intros i Hi.
 do 2 rewrite Nat.add_succ_l, <- Nat.add_succ_r.
 apply Hgh.
 split; [ apply Nat.le_0_l | ].
 apply lt_n_S.
 now destruct Hi.
Qed.

Theorem summation_eq_compat : ∀ g h b k,
  (∀ i, b ≤ i ≤ k → (g i = h i)%R)
  → (Σ (i = b, k), (g i) = Σ (i = b, k), (h i))%R.
Proof.
intros g h b k Hgh.
apply summation_aux_eq_compat.
intros i (_, Hi).
apply Hgh.
split; [ apply Nat.le_add_r | idtac ].
apply Nat.lt_add_lt_sub_r, le_S_n in Hi.
now rewrite Nat.add_comm.
Qed.

Theorem summation_empty : ∀ g b k, (k < b)%nat → (Σ (i = b, k), (g i) = 0%R).
Proof.
intros.
unfold summation.
now replace (S k - b)%nat with O by lia.
Qed.

Theorem summation_only_one : ∀ g n, (Σ (i = n, n), (g i) = g n)%R.
Proof.
intros g n.
unfold summation.
rewrite Nat.sub_succ_l; [ | easy ].
rewrite Nat.sub_diag; simpl.
now rewrite Rplus_0_r.
Qed.

Theorem summation_aux_succ_last : ∀ g b len,
  (summation_aux b (S len) g =
   summation_aux b len g + g (b + len)%nat)%R.
Proof.
intros g b len.
revert b.
induction len; intros.
 simpl.
 now rewrite Rplus_0_l, Rplus_0_r, Nat.add_0_r.

 remember (S len) as x; simpl; subst x.
 rewrite IHlen.
 simpl.
 now rewrite Rplus_assoc, Nat.add_succ_r.
Qed.

Theorem summation_split_last : ∀ g b k,
  (b ≤ S k)
  → (Σ (i = b, S k), (g i) = Σ (i = b, k), (g i) + g (S k))%R.
Proof.
intros g b k Hbk.
unfold summation.
rewrite Nat.sub_succ_l; [ | easy ].
rewrite summation_aux_succ_last.
rewrite Nat.add_sub_assoc; [ idtac | assumption ].
rewrite Nat.add_comm, Nat.add_sub.
reflexivity.
Qed.

Theorem summation_add_distr : ∀ g h b k,
  (Σ (i = b, k), (g i + h i) =
   Σ (i = b, k), (g i) + Σ (i = b, k), (h i))%R.
Proof.
intros g h b k.
destruct (le_dec b k) as [Hbk| Hbk].
 revert b Hbk.
 induction k; intros.
  destruct b.
   now do 3 rewrite summation_only_one.

   now unfold summation; simpl; rewrite Rplus_0_r.

  rewrite summation_split_last; [ idtac | easy ].
  rewrite summation_split_last; [ idtac | easy ].
  rewrite summation_split_last; [ idtac | easy ].
  destruct (eq_nat_dec b (S k)) as [H₂| H₂].
   subst b.
   unfold summation; simpl.
   rewrite Nat.sub_diag; simpl.
   now do 3 rewrite Rplus_0_l.

   assert (H : (b ≤ k)%nat) by lia.
   clear Hbk; rename H into Hbk.
   rewrite IHk; [ lra | easy ].

 unfold summation.
 apply Nat.nle_gt in Hbk.
 replace (S k - b) with O by lia; simpl.
 now rewrite Rplus_0_r.
Qed.

Theorem summation_opp_distr : ∀ g b k,
  (- Σ (i = b, k), (g i) = Σ (i = b, k), (- g i))%R.
Proof.
intros.
destruct (le_dec b k) as [Hbk| Hbk].
 revert b Hbk.
 induction k; intros.
  destruct b.
   now do 2 rewrite summation_only_one.

   unfold summation; simpl; lra.

  rewrite summation_split_last; [ | easy ].
  rewrite summation_split_last; [ | easy ].
  rewrite Ropp_plus_distr.
  destruct (eq_nat_dec b (S k)) as [H₂| H₂].
   subst b.
   unfold summation; simpl.
   rewrite Nat.sub_diag; simpl; lra.

   assert (H : (b ≤ k)%nat) by lia.
   clear Hbk; rename H into Hbk.
   now rewrite IHk.

 unfold summation.
 apply Nat.nle_gt in Hbk.
 replace (S k - b) with O by lia; simpl.
 now rewrite Ropp_0.
Qed.

Theorem summation_sub_distr : ∀ g h b k,
  (Σ (i = b, k), (g i - h i) =
   Σ (i = b, k), (g i) - Σ (i = b, k), (h i))%R.
Proof.
intros g h b k.
unfold Rminus.
rewrite summation_add_distr.
f_equal.
now rewrite summation_opp_distr.
Qed.

Theorem summation_swap : ∀ b₁ k₁ b₂ k₂ f,
  Σ (i = b₁, k₁), Σ (j = b₂, k₂), (f i j) =
  Σ (j = b₂, k₂), Σ (i = b₁, k₁), (f i j).
Proof.
intros.
unfold summation.
remember (S k₁ - b₁) as len₁ eqn:Hlen₁.
remember (S k₂ - b₂) as len₂ eqn:Hlen₂.
clear Hlen₁ Hlen₂; clear.
revert b₁ b₂ len₂.
induction len₁; intros; simpl.
 revert b₂.
 induction len₂; intros; [ easy | simpl ].
 rewrite <- IHlen₂; lra.

 rewrite IHlen₁.
 clear.
 revert b₁ b₂ len₁.
 induction len₂; intros; simpl; [ lra | ].
 rewrite <- IHlen₂; lra.
Qed.

Theorem summation_mul_distr_r : ∀ f b k a,
  (Σ (i = b, k), (f i) * a)%R =
  Σ (i = b, k), (f i * a).
Proof.
intros.
unfold summation.
remember (S k - b) as len eqn:Hlen.
clear; revert b.
induction len; intros; simpl; [ lra | ].
rewrite Rmult_plus_distr_r.
now rewrite IHlen.
Qed.

Theorem summation_mul_distr_l : ∀ f b k a,
  (a * Σ (i = b, k), (f i))%R =
  Σ (i = b, k), (a * f i).
Proof.
intros.
rewrite Rmult_comm, summation_mul_distr_r.
apply summation_eq_compat; intros; apply Rmult_comm.
Qed.

Theorem summation_summation_mul_distr : ∀ f g b k,
  (Σ (i = b, k), (f i) * Σ (i = b, k), (g i))%R =
  Σ (i = b, k), Σ (j = b, k), (f i * g j).
Proof.
intros.
revert b.
induction k; intros.
 destruct b.
  now do 4 rewrite summation_only_one.

  rewrite summation_empty; [ | lia ].
  rewrite summation_empty; [ | lia ].
  rewrite summation_empty; [ lra | lia ].

 destruct (le_dec b (S k)) as [Hbk| Hbk].
  rewrite summation_split_last; [ idtac | easy ].
  rewrite summation_split_last; [ idtac | easy ].
  rewrite summation_split_last; [ idtac | easy ].
  rewrite summation_split_last; [ idtac | easy ].
  rewrite Rmult_plus_distr_l.
  do 2 rewrite Rmult_plus_distr_r.
  rewrite IHk.
  rewrite summation_swap; symmetry.
  rewrite summation_swap; symmetry.
  rewrite summation_split_last; [ | easy ].
  do 2 rewrite Rplus_assoc; f_equal.
  rewrite Rplus_comm, Rplus_assoc.
  f_equal; [ apply summation_mul_distr_r | ].
  rewrite Rplus_comm; f_equal.
  apply summation_mul_distr_l.

  apply Nat.nle_gt in Hbk.
  rewrite summation_empty; [ | lia ].
  rewrite summation_empty; [ | lia ].
  rewrite summation_empty; [ lra | lia ].
Qed.

Theorem summation_aux_le_compat : ∀ g h b₁ b₂ len,
  (∀ i, 0 ≤ i < len → (g (b₁ + i)%nat ≤ h (b₂ + i)%nat)%R)
  → (summation_aux b₁ len g ≤ summation_aux b₂ len h)%R.
Proof.
intros g h b₁ b₂ len Hgh.
revert b₁ b₂ Hgh.
induction len; intros; simpl; [ lra | ].
apply Rplus_le_compat.
 assert (H : 0 ≤ 0 < S len) by lia.
 apply Hgh in H.
 now do 2 rewrite Nat.add_0_r in H.

 apply IHlen; intros i Hi.
 do 2 rewrite Nat.add_succ_comm.
 apply Hgh; lia.
Qed.

Theorem summation_le_compat : ∀ b k f g,
  (∀ i, (b ≤ i ≤ k) → (f i ≤ g i)%R)
  → (Σ (i = b, k), (f i) ≤ Σ (i = b, k), (g i))%R.
Proof.
intros * Hfg.
unfold summation.
apply summation_aux_le_compat; intros i Hi.
apply Hfg; lia.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(** * FMapPositive : an implementation of FMapInterface for [positive] keys. *)

Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface.

Set Implicit Arguments.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.

(** This file is an adaptation to the [FMap] framework of a work by
  Xavier Leroy and Sandrine Blazy (used for building certified compilers).
  Keys are of type [positive], and maps are binary trees: the sequence
  of binary digits of a positive number corresponds to a path in such a tree.
  This is quite similar to the [IntMap] library, except that no path
  compression is implemented, and that the current file is simple enough to be
  self-contained. *)

(** First, some stuff about [positive] *)

Fixpoint append (i j : positive) : positive :=
    match i with
      | xH => j
      | xI ii => xI (append ii j)
      | xO ii => xO (append ii j)
    end.

Lemma append_assoc_0 :
  forall (i j : positive), append i (xO j) = append (append i (xO xH)) j.
Proof.
 induction i; intros; destruct j; simpl;
 try rewrite (IHi (xI j));
 try rewrite (IHi (xO j));
 try rewrite <- (IHi xH);
 auto.
Qed.

Lemma append_assoc_1 :
  forall (i j : positive), append i (xI j) = append (append i (xI xH)) j.
Proof.
 induction i; intros; destruct j; simpl;
 try rewrite (IHi (xI j));
 try rewrite (IHi (xO j));
 try rewrite <- (IHi xH);
 auto.
Qed.

Lemma append_neutral_r : forall (i : positive), append i xH = i.
Proof.
 induction i; simpl; congruence.
Qed.

Lemma append_neutral_l : forall (i : positive), append xH i = i.
Proof.
 simpl; auto.
Qed.

(** The module of maps over positive keys *)

Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.

  Module E:=PositiveOrderedTypeBits.
  Module ME:=KeyOrderedType E.

  Definition key := positive.

  Inductive tree (A : Type) :=
    | Leaf : tree A
    | Node : tree A -> option A -> tree A -> tree A.

  Scheme tree_ind := Induction for tree Sort Prop.

  Definition t := tree.

  Section A.
  Variable A:Type.

  Arguments Leaf [A].

  Definition empty : t A := Leaf.

  Fixpoint is_empty (m : t A) : bool :=
   match m with
    | Leaf => true
    | Node l None r => (is_empty l) && (is_empty r)
    | _ => false
   end.

  Fixpoint find (i : positive) (m : t A) : option A :=
    match m with
    | Leaf => None
    | Node l o r =>
        match i with
        | xH => o
        | xO ii => find ii l
        | xI ii => find ii r
        end
    end.

  Fixpoint mem (i : positive) (m : t A) : bool :=
    match m with
    | Leaf => false
    | Node l o r =>
        match i with
        | xH => match o with None => false | _ => true end
        | xO ii => mem ii l
        | xI ii => mem ii r
        end
    end.

  Fixpoint add (i : positive) (v : A) (m : t A) : t A :=
    match m with
    | Leaf =>
        match i with
        | xH => Node Leaf (Some v) Leaf
        | xO ii => Node (add ii v Leaf) None Leaf
        | xI ii => Node Leaf None (add ii v Leaf)
        end
    | Node l o r =>
        match i with
        | xH => Node l (Some v) r
        | xO ii => Node (add ii v l) o r
        | xI ii => Node l o (add ii v r)
        end
    end.

  Fixpoint remove (i : positive) (m : t A) : t A :=
    match i with
    | xH =>
        match m with
        | Leaf => Leaf
        | Node Leaf o Leaf => Leaf
        | Node l o r => Node l None r
        end
    | xO ii =>
        match m with
        | Leaf => Leaf
        | Node l None Leaf =>
            match remove ii l with
            | Leaf => Leaf
            | mm => Node mm None Leaf
            end
        | Node l o r => Node (remove ii l) o r
        end
    | xI ii =>
        match m with
        | Leaf => Leaf
        | Node Leaf None r =>
            match remove ii r with
            | Leaf => Leaf
            | mm => Node Leaf None mm
            end
        | Node l o r => Node l o (remove ii r)
        end
    end.

  (** [elements] *)

    Fixpoint xelements (m : t A) (i : positive) : list (positive * A) :=
      match m with
      | Leaf => nil
      | Node l None r =>
          (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH)))
      | Node l (Some x) r =>
          (xelements l (append i (xO xH)))
          ++ ((i, x) :: xelements r (append i (xI xH)))
      end.

  (* Note: function [xelements] above is inefficient.  We should apply
     deforestation to it, but that makes the proofs even harder. *)

  Definition elements (m : t A) := xelements m xH.

  (** [cardinal] *)

  Fixpoint cardinal (m : t A) : nat :=
    match m with
      | Leaf => 0%nat
      | Node l None r => (cardinal l + cardinal r)%nat
      | Node l (Some _) r => S (cardinal l + cardinal r)
    end.

  Section CompcertSpec.

  Theorem gempty:
    forall (i: positive), find i empty = None.
  Proof.
    destruct i; simpl; auto.
  Qed.

  Theorem gss:
    forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x.
  Proof.
    induction i; destruct m; simpl; auto.
  Qed.

  Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None.
  Proof. exact gempty. Qed.

  Theorem gso:
    forall (i j: positive) (x: A) (m: t A),
    i <> j -> find i (add j x m) = find i m.
  Proof.
    induction i; intros; destruct j; destruct m; simpl;
       try rewrite <- (gleaf i); auto; try apply IHi; congruence.
  Qed.

  Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf.
  Proof. destruct i; simpl; auto. Qed.

  Theorem grs:
    forall (i: positive) (m: t A), find i (remove i m) = None.
  Proof.
    induction i; destruct m.
     simpl; auto.
     destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto.
      rewrite (rleaf i); auto.
      cut (find i (remove i (Node ll oo rr)) = None).
        destruct (remove i (Node ll oo rr)); auto; apply IHi.
        apply IHi.
     simpl; auto.
     destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto.
      rewrite (rleaf i); auto.
      cut (find i (remove i (Node ll oo rr)) = None).
        destruct (remove i (Node ll oo rr)); auto; apply IHi.
        apply IHi.
     simpl; auto.
     destruct m1; destruct m2; simpl; auto.
  Qed.

  Theorem gro:
    forall (i j: positive) (m: t A),
    i <> j -> find i (remove j m) = find i m.
  Proof.
    induction i; intros; destruct j; destruct m;
        try rewrite (rleaf (xI j));
        try rewrite (rleaf (xO j));
        try rewrite (rleaf 1); auto;
        destruct m1; destruct o; destruct m2;
        simpl;
        try apply IHi; try congruence;
        try rewrite (rleaf j); auto;
        try rewrite (gleaf i); auto.
     cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2));
        [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto
        | apply IHi; congruence ].
     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
        auto.
     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
        auto.
     cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2));
        [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto
        | apply IHi; congruence ].
     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
        auto.
     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
        auto.
  Qed.

  Lemma xelements_correct:
      forall (m: t A) (i j : positive) (v: A),
      find i m = Some v -> List.In (append j i, v) (xelements m j).
    Proof.
      induction m; intros.
       rewrite (gleaf i) in H; congruence.
       destruct o; destruct i; simpl; simpl in H.
        rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
          apply IHm2; auto.
        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
        rewrite append_neutral_r; apply in_or_app; injection H;
          intro EQ; rewrite EQ; right; apply in_eq.
        rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto.
        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
        congruence.
    Qed.

  Theorem elements_correct:
    forall (m: t A) (i: positive) (v: A),
    find i m = Some v -> List.In (i, v) (elements m).
  Proof.
    intros m i v H.
    exact (xelements_correct m i xH H).
  Qed.

  Fixpoint xfind (i j : positive) (m : t A) : option A :=
      match i, j with
      | _, xH => find i m
      | xO ii, xO jj => xfind ii jj m
      | xI ii, xI jj => xfind ii jj m
      | _, _ => None
      end.

   Lemma xfind_left :
      forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A),
      xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
    Proof.
      induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
      destruct i; simpl in *; auto.
    Qed.

    Lemma xelements_ii :
      forall (m: t A) (i j : positive) (v: A),
      List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
         apply in_or_app.
        left; apply IHm1; auto.
        right; destruct (in_inv H0).
         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
         apply in_cons; apply IHm2; auto.
        left; apply IHm1; auto.
        right; apply IHm2; auto.
    Qed.

    Lemma xelements_io :
      forall (m: t A) (i j : positive) (v: A),
      ~List.In (xI i, v) (xelements m (xO j)).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        apply (IHm1 _ _ _ H0).
        destruct (in_inv H0).
         congruence.
         apply (IHm2 _ _ _ H1).
        apply (IHm1 _ _ _ H0).
        apply (IHm2 _ _ _ H0).
    Qed.

    Lemma xelements_oo :
      forall (m: t A) (i j : positive) (v: A),
      List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
         apply in_or_app.
        left; apply IHm1; auto.
        right; destruct (in_inv H0).
         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
         apply in_cons; apply IHm2; auto.
        left; apply IHm1; auto.
        right; apply IHm2; auto.
    Qed.

    Lemma xelements_oi :
      forall (m: t A) (i j : positive) (v: A),
      ~List.In (xO i, v) (xelements m (xI j)).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        apply (IHm1 _ _ _ H0).
        destruct (in_inv H0).
         congruence.
         apply (IHm2 _ _ _ H1).
        apply (IHm1 _ _ _ H0).
        apply (IHm2 _ _ _ H0).
    Qed.

    Lemma xelements_ih :
      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
      List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH).
    Proof.
      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
        destruct (in_inv H0).
         congruence.
         apply xelements_ii; auto.
        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
        apply xelements_ii; auto.
    Qed.

    Lemma xelements_oh :
      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
      List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH).
    Proof.
      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
        apply xelements_oo; auto.
        destruct (in_inv H0).
         congruence.
         absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
        apply xelements_oo; auto.
        absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
    Qed.

    Lemma xelements_hi :
      forall (m: t A) (i : positive) (v: A),
      ~List.In (xH, v) (xelements m (xI i)).
    Proof.
      induction m; intros.
       simpl; auto.
       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        generalize H0; apply IHm1; auto.
        destruct (in_inv H0).
         congruence.
         generalize H1; apply IHm2; auto.
        generalize H0; apply IHm1; auto.
        generalize H0; apply IHm2; auto.
    Qed.

    Lemma xelements_ho :
      forall (m: t A) (i : positive) (v: A),
      ~List.In (xH, v) (xelements m (xO i)).
    Proof.
      induction m; intros.
       simpl; auto.
       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        generalize H0; apply IHm1; auto.
        destruct (in_inv H0).
         congruence.
         generalize H1; apply IHm2; auto.
        generalize H0; apply IHm1; auto.
        generalize H0; apply IHm2; auto.
    Qed.

    Lemma find_xfind_h :
      forall (m: t A) (i: positive), find i m = xfind i xH m.
    Proof.
      destruct i; simpl; auto.
    Qed.

    Lemma xelements_complete:
      forall (i j : positive) (m: t A) (v: A),
      List.In (i, v) (xelements m j) -> xfind i j m = Some v.
    Proof.
      induction i; simpl; intros; destruct j; simpl.
       apply IHi; apply xelements_ii; auto.
       absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io.
       destruct m.
        simpl in H; tauto.
        rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H).
       absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi.
       apply IHi; apply xelements_oo; auto.
       destruct m.
        simpl in H; tauto.
        rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H).
       absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi.
       absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho.
       destruct m.
        simpl in H; tauto.
        destruct o; simpl in H; destruct (in_app_or _ _ _ H).
         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
         destruct (in_inv H0).
          congruence.
          absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
         absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
    Qed.

  Theorem elements_complete:
    forall (m: t A) (i: positive) (v: A),
    List.In (i, v) (elements m) -> find i m = Some v.
  Proof.
    intros m i v H.
    unfold elements in H.
    rewrite find_xfind_h.
    exact (xelements_complete i xH m v H).
  Qed.

  Lemma cardinal_1 :
   forall (m: t A), cardinal m = length (elements m).
  Proof.
   unfold elements.
   intros m; set (p:=1); clearbody p; revert m p.
   induction m; simpl; auto; intros.
   rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto.
   destruct o; rewrite app_length; simpl; omega.
  Qed.

  End CompcertSpec.

  Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v.

  Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m.

  Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m.

  Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p').

  Definition eq_key_elt (p p':positive*A) :=
          E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p').

  Global Instance eqk_equiv : Equivalence eq_key := _.
  Global Instance eqke_equiv : Equivalence eq_key_elt := _.
  Global Instance ltk_strorder : StrictOrder lt_key := _.

  Lemma mem_find :
    forall m x, mem x m = match find x m with None => false | _ => true end.
  Proof.
  induction m; destruct x; simpl; auto.
  Qed.

  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
  Proof.
  unfold Empty, MapsTo.
  intuition.
  generalize (H a).
  destruct (find a m); intuition.
  elim (H0 a0); auto.
  rewrite H in H0; discriminate.
  Qed.

  Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r.
  Proof.
  intros l o r.
  split.
  rewrite Empty_alt.
  split.
  destruct o; auto.
  generalize (H 1); simpl; auto.
  split; rewrite Empty_alt; intros.
  generalize (H (xO a)); auto.
  generalize (H (xI a)); auto.
  intros (H,(H0,H1)).
  subst.
  rewrite Empty_alt; intros.
  destruct a; auto.
  simpl; generalize H1; rewrite Empty_alt; auto.
  simpl; generalize H0; rewrite Empty_alt; auto.
  Qed.

  Section FMapSpec.

  Lemma mem_1 : forall m x, In x m -> mem x m = true.
  Proof.
  unfold In, MapsTo; intros m x; rewrite mem_find.
  destruct 1 as (e0,H0); rewrite H0; auto.
  Qed.

  Lemma mem_2 : forall m x, mem x m = true -> In x m.
  Proof.
  unfold In, MapsTo; intros m x; rewrite mem_find.
  destruct (find x m).
  exists a; auto.
  intros; discriminate.
  Qed.

  Variable  m m' m'' : t A.
  Variable x y z : key.
  Variable e e' : A.

  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
  Proof. intros; rewrite <- H; auto. Qed.

  Lemma find_1 : MapsTo x e m -> find x m = Some e.
  Proof. unfold MapsTo; auto. Qed.

  Lemma find_2 : find x m = Some e -> MapsTo x e m.
  Proof. red; auto. Qed.

  Lemma empty_1 : Empty empty.
  Proof.
  rewrite Empty_alt; apply gempty.
  Qed.

  Lemma is_empty_1 : Empty m -> is_empty m = true.
  Proof.
  induction m; simpl; auto.
  rewrite Empty_Node.
  intros (H,(H0,H1)).
  subst; simpl.
  rewrite IHt0_1; simpl; auto.
  Qed.

  Lemma is_empty_2 : is_empty m = true -> Empty m.
  Proof.
  induction m; simpl; auto.
  rewrite Empty_alt.
  intros _; exact gempty.
  rewrite Empty_Node.
  destruct o.
  intros; discriminate.
  intro H; destruct (andb_prop _ _ H); intuition.
  Qed.

  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
  Proof.
  unfold MapsTo.
  intro H; rewrite H; clear H.
  apply gss.
  Qed.

  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof.
  unfold MapsTo.
  intros; rewrite gso; auto.
  Qed.

  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof.
  unfold MapsTo.
  intro H; rewrite gso; auto.
  Qed.

  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
  Proof.
  intros; intro.
  generalize (mem_1 H0).
  rewrite mem_find.
  red in H.
  rewrite H.
  rewrite grs.
  intros; discriminate.
  Qed.

  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof.
  unfold MapsTo.
  intro H; rewrite gro; auto.
  Qed.

  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
  Proof.
  unfold MapsTo.
  destruct (E.eq_dec x y).
  subst.
  rewrite grs; intros; discriminate.
  rewrite gro; auto.
  Qed.

  Lemma elements_1 :
     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof.
  unfold MapsTo.
  rewrite InA_alt.
  intro H.
  exists (x,e).
  split.
  red; simpl; unfold E.eq; auto.
  apply elements_correct; auto.
  Qed.

  Lemma elements_2 :
     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof.
  unfold MapsTo.
  rewrite InA_alt.
  intros ((e0,a),(H,H0)).
  red in H; simpl in H; unfold E.eq in H; destruct H; subst.
  apply elements_complete; auto.
  Qed.

  Lemma xelements_bits_lt_1 : forall p p0 q m v,
     List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p.
  Proof.
  intros.
  generalize (xelements_complete _ _ _ _ H); clear H; intros.
  revert p0 q m v H.
  induction p; destruct p0; simpl; intros; eauto; try discriminate.
  Qed.

  Lemma xelements_bits_lt_2 : forall p p0 q m v,
     List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0.
  Proof.
  intros.
  generalize (xelements_complete _ _ _ _ H); clear H; intros.
  revert p0 q m v H.
  induction p; destruct p0; simpl; intros; eauto; try discriminate.
  Qed.

  Lemma xelements_sort : forall p, sort lt_key (xelements m p).
  Proof.
  induction m.
  simpl; auto.
  destruct o; simpl; intros.
  (* Some *)
  apply (SortA_app (eqA:=eq_key_elt)); auto with *.
  constructor; auto.
  apply In_InfA; intros.
  destruct y0.
  red; red; simpl.
  eapply xelements_bits_lt_2; eauto.
  intros x0 y0.
  do 2 rewrite InA_alt.
  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
  red; red; simpl.
  destruct H0.
  injection H0; clear H0; intros _ H0; subst.
  eapply xelements_bits_lt_1; eauto.
  apply E.bits_lt_trans with p.
  eapply xelements_bits_lt_1; eauto.
  eapply xelements_bits_lt_2; eauto.
  (* None *)
  apply (SortA_app (eqA:=eq_key_elt)); auto with *.
  intros x0 y0.
  do 2 rewrite InA_alt.
  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
  red; red; simpl.
  apply E.bits_lt_trans with p.
  eapply xelements_bits_lt_1; eauto.
  eapply xelements_bits_lt_2; eauto.
  Qed.

  Lemma elements_3 : sort lt_key (elements m).
  Proof.
  unfold elements.
  apply xelements_sort; auto.
  Qed.

  Lemma elements_3w : NoDupA eq_key (elements m).
  Proof.
  change eq_key with (@ME.eqk A).
  apply ME.Sort_NoDupA; apply elements_3; auto.
  Qed.

  End FMapSpec.

  (** [map] and [mapi] *)

  Variable B : Type.

  Section Mapi.

    Variable f : positive -> A -> B.

    Fixpoint xmapi (m : t A) (i : positive) : t B :=
       match m with
        | Leaf => @Leaf B
        | Node l o r => Node (xmapi l (append i (xO xH)))
                             (option_map (f i) o)
                             (xmapi r (append i (xI xH)))
       end.

    Definition mapi m := xmapi m xH.

  End Mapi.

  Definition map (f : A -> B) m := mapi (fun _ => f) m.

  End A.

  Lemma xgmapi:
      forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A),
      find i (xmapi f m j) = option_map (f (append j i)) (find i m).
  Proof.
  induction i; intros; destruct m; simpl; auto.
  rewrite (append_assoc_1 j i); apply IHi.
  rewrite (append_assoc_0 j i); apply IHi.
  rewrite (append_neutral_r j); auto.
  Qed.

  Theorem gmapi:
    forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A),
    find i (mapi f m) = option_map (f i) (find i m).
  Proof.
  intros.
  unfold mapi.
  replace (f i) with (f (append xH i)).
  apply xgmapi.
  rewrite append_neutral_l; auto.
  Qed.

  Lemma mapi_1 :
    forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
    MapsTo x e m ->
    exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof.
  intros.
  exists x.
  split; [red; auto|].
  apply find_2.
  generalize (find_1 H); clear H; intros.
  rewrite gmapi.
  rewrite H.
  simpl; auto.
  Qed.

  Lemma mapi_2 :
    forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'),
    In x (mapi f m) -> In x m.
  Proof.
  intros.
  apply mem_2.
  rewrite mem_find.
  destruct H as (v,H).
  generalize (find_1 H); clear H; intros.
  rewrite gmapi in H.
  destruct (find x m); auto.
  simpl in *; discriminate.
  Qed.

  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
    MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof.
  intros; unfold map.
  destruct (mapi_1 (fun _ => f) H); intuition.
  Qed.

  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
    In x (map f m) -> In x m.
  Proof.
  intros; unfold map in *; eapply mapi_2; eauto.
  Qed.

  Section map2.
  Variable A B C : Type.
  Variable f : option A -> option B -> option C.

  Arguments Leaf [A].

  Fixpoint xmap2_l (m : t A) : t C :=
      match m with
      | Leaf => Leaf
      | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
      end.

  Lemma xgmap2_l : forall (i : positive) (m : t A),
          f None None = None -> find i (xmap2_l m) = f (find i m) None.
    Proof.
      induction i; intros; destruct m; simpl; auto.
    Qed.

  Fixpoint xmap2_r (m : t B) : t C :=
      match m with
      | Leaf => Leaf
      | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
      end.

  Lemma xgmap2_r : forall (i : positive) (m : t B),
          f None None = None -> find i (xmap2_r m) = f None (find i m).
    Proof.
      induction i; intros; destruct m; simpl; auto.
    Qed.

  Fixpoint _map2 (m1 : t A)(m2 : t B) : t C :=
    match m1 with
    | Leaf => xmap2_r m2
    | Node l1 o1 r1 =>
        match m2 with
        | Leaf => xmap2_l m1
        | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2)
        end
    end.

    Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B),
      f None None = None ->
      find i (_map2 m1 m2) = f (find i m1) (find i m2).
    Proof.
      induction i; intros; destruct m1; destruct m2; simpl; auto;
      try apply xgmap2_r; try apply xgmap2_l; auto.
    Qed.

  End map2.

  Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') :=
   _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end).

  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In x m \/ In x m' ->
    find x (map2 f m m') = f (find x m) (find x m').
  Proof.
  intros.
  unfold map2.
  rewrite gmap2; auto.
  generalize (@mem_1 _ m x) (@mem_1 _ m' x).
  do 2 rewrite mem_find.
  destruct (find x m); simpl; auto.
  destruct (find x m'); simpl; auto.
  intros.
  destruct H; intuition; try discriminate.
  Qed.

  Lemma  map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In x (map2 f m m') -> In x m \/ In x m'.
  Proof.
  intros.
  generalize (mem_1 H); clear H; intros.
  rewrite mem_find in H.
  unfold map2 in H.
  rewrite gmap2 in H; auto.
  generalize (@mem_2 _ m x) (@mem_2 _ m' x).
  do 2 rewrite mem_find.
  destruct (find x m); simpl in *; auto.
  destruct (find x m'); simpl in *; auto.
  Qed.

  Section Fold.

    Variables A B : Type.
    Variable f : positive -> A -> B -> B.

    Fixpoint xfoldi (m : t A) (v : B) (i : positive) :=
      match m with
        | Leaf _ => v
        | Node l (Some x) r =>
          xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3)
        | Node l None r =>
          xfoldi r (xfoldi l v (append i 2)) (append i 3)
      end.

    Lemma xfoldi_1 :
      forall m v i,
      xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v.
    Proof.
      set (F := fun a p => f (fst p) (snd p) a).
      induction m; intros; simpl; auto.
      destruct o.
      rewrite fold_left_app; simpl.
      rewrite <- IHm1.
      rewrite <- IHm2.
      unfold F; simpl; reflexivity.
      rewrite fold_left_app; simpl.
      rewrite <- IHm1.
      rewrite <- IHm2.
      reflexivity.
    Qed.

    Definition fold m i := xfoldi m i 1.

  End Fold.

  Lemma fold_1 :
    forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B),
    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof.
    intros; unfold fold, elements.
    rewrite xfoldi_1; reflexivity.
  Qed.

  Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool :=
    match m1, m2 with
      | Leaf _, _ => is_empty m2
      | _, Leaf _ => is_empty m1
      | Node l1 o1 r1, Node l2 o2 r2 =>
           (match o1, o2 with
             | None, None => true
             | Some v1, Some v2 => cmp v1 v2
             | _, _ => false
            end)
           && equal cmp l1 l2 && equal cmp r1 r2
     end.

  Definition Equal (A:Type)(m m':t A) :=
    forall y, find y m = find y m'.
  Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp).

  Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
    Equivb cmp m m' -> equal cmp m m' = true.
  Proof.
  induction m.
  (* m = Leaf *)
  destruct 1.
  simpl.
  apply is_empty_1.
  red; red; intros.
  assert (In a (Leaf A)).
  rewrite H.
  exists e; auto.
  destruct H2; red in H2.
  destruct a; simpl in *; discriminate.
  (* m = Node *)
  destruct m'.
  (* m' = Leaf *)
  destruct 1.
  simpl.
  destruct o.
  assert (In xH (Leaf A)).
  rewrite <- H.
  exists a; red; auto.
  destruct H1; red in H1; simpl in H1; discriminate.
  apply andb_true_intro; split; apply is_empty_1; red; red; intros.
  assert (In (xO a) (Leaf A)).
  rewrite <- H.
  exists e; auto.
  destruct H2; red in H2; simpl in H2; discriminate.
  assert (In (xI a) (Leaf A)).
  rewrite <- H.
  exists e; auto.
  destruct H2; red in H2; simpl in H2; discriminate.
  (* m' = Node *)
  destruct 1.
  assert (Equivb cmp m1 m'1).
    split.
    intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto.
    intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto.
  assert (Equivb cmp m2 m'2).
    split.
    intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto.
    intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto.
  simpl.
  destruct o; destruct o0; simpl.
  repeat (apply andb_true_intro; split); auto.
  apply (H0 xH); red; auto.
  generalize (H xH); unfold In, MapsTo; simpl; intuition.
  destruct H4; try discriminate; eauto.
  generalize (H xH); unfold In, MapsTo; simpl; intuition.
  destruct H5; try discriminate; eauto.
  apply andb_true_intro; split; auto.
  Qed.

  Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
    equal cmp m m' = true -> Equivb cmp m m'.
  Proof.
  induction m.
  (* m = Leaf *)
  simpl.
  split; intros.
  split.
  destruct 1; red in H0; destruct k; discriminate.
  destruct 1; elim (is_empty_2 H H0).
  red in H0; destruct k; discriminate.
  (* m = Node *)
  destruct m'.
  (* m' = Leaf *)
  simpl.
  destruct o; intros; try discriminate.
  destruct (andb_prop _ _ H); clear H.
  split; intros.
  split; unfold In, MapsTo; destruct 1.
  destruct k; simpl in *; try discriminate.
  destruct (is_empty_2 H1 (find_2 _ _ H)).
  destruct (is_empty_2 H0 (find_2 _ _ H)).
  destruct k; simpl in *; discriminate.
  unfold In, MapsTo; destruct k; simpl in *; discriminate.
  (* m' = Node *)
  destruct o; destruct o0; simpl; intros; try discriminate.
  destruct (andb_prop _ _ H); clear H.
  destruct (andb_prop _ _ H0); clear H0.
  destruct (IHm1 _ _ H2); clear H2 IHm1.
  destruct (IHm2 _ _ H1); clear H1 IHm2.
  split; intros.
  destruct k; unfold In, MapsTo in *; simpl; auto.
  split; eauto.
  destruct k; unfold In, MapsTo in *; simpl in *.
  eapply H4; eauto.
  eapply H3; eauto.
  congruence.
  destruct (andb_prop _ _ H); clear H.
  destruct (IHm1 _ _ H0); clear H0 IHm1.
  destruct (IHm2 _ _ H1); clear H1 IHm2.
  split; intros.
  destruct k; unfold In, MapsTo in *; simpl; auto.
  split; eauto.
  destruct k; unfold In, MapsTo in *; simpl in *.
  eapply H3; eauto.
  eapply H2; eauto.
  try discriminate.
  Qed.

End PositiveMap.

(** Here come some additionnal facts about this implementation.
  Most are facts that cannot be derivable from the general interface. *)

Module PositiveMapAdditionalFacts.
  Import PositiveMap.

  (* Derivable from the Map interface *)
  Theorem gsspec:
    forall (A:Type)(i j: positive) (x: A) (m: t A),
    find i (add j x m) = if E.eq_dec i j then Some x else find i m.
  Proof.
    intros.
    destruct (E.eq_dec i j); [ rewrite e; apply gss | apply gso; auto ].
  Qed.

   (* Not derivable from the Map interface *)
  Theorem gsident:
    forall (A:Type)(i: positive) (m: t A) (v: A),
    find i m = Some v -> add i v m = m.
  Proof.
    induction i; intros; destruct m; simpl; simpl in H; try congruence.
     rewrite (IHi m2 v H); congruence.
     rewrite (IHi m1 v H); congruence.
  Qed.

  Lemma xmap2_lr :
      forall (A B : Type)(f g: option A -> option A -> option B)(m : t A),
      (forall (i j : option A), f i j = g j i) ->
      xmap2_l f m = xmap2_r g m.
    Proof.
      induction m; intros; simpl; auto.
      rewrite IHm1; auto.
      rewrite IHm2; auto.
      rewrite H; auto.
    Qed.

  Theorem map2_commut:
    forall (A B: Type) (f g: option A -> option A -> option B),
    (forall (i j: option A), f i j = g j i) ->
    forall (m1 m2: t A),
    _map2 f m1 m2 = _map2 g m2 m1.
  Proof.
    intros A B f g Eq1.
    assert (Eq2: forall (i j: option A), g i j = f j i).
      intros; auto.
    induction m1; intros; destruct m2; simpl;
      try rewrite Eq1;
      repeat rewrite (xmap2_lr f g);
      repeat rewrite (xmap2_lr g f);
      auto.
     rewrite IHm1_1.
     rewrite IHm1_2.
     auto.
  Qed.

End PositiveMapAdditionalFacts.


Require Import List.
Require Import util.
Require Import Le.
Require Import Lt.
Set Implicit Arguments.

Section with_eq_dec.

Variables (X: Type) (Xeq: forall x x': X, decision (x = x')).

Lemma remove_incl
  (x: X) (l: list X): incl (remove Xeq x l) l.
Proof with auto.
  induction l; simpl.
    apply incl_refl.
  destruct (Xeq x a).
    apply incl_tl...
  do 2 intro. destruct H.
    subst. left...
  right...
Qed.

Lemma remove_length_le (x: X) (l: list X): length (remove Xeq x l) <= length l.
Proof with auto.
  induction l...
  simpl.
  destruct (Xeq x a)...
  apply le_n_S...
Qed.

Lemma remove_length_lt (x: X) (l: list X): In x l ->
    length (remove Xeq x l) < length l.
Proof with auto.
  induction l; intros.
    inversion H.
  simpl.
  destruct (Xeq x a).
    apply le_n_S.
    apply remove_length_le.
  destruct H. elimtype False...
  apply lt_n_S...
Qed.

Definition intersection (a: list X): list X -> list X :=
  filter (fun e => unsumbool (In_dec Xeq e a)).

Definition subtr: list X -> list X -> list X := fold_right (remove Xeq).
    (* removes elements in latter list from former list *)

Lemma remove_eq_filter (x: X) (l: list X):
  remove Xeq x l = filter (fun y => negb (unsumbool (Xeq x y))) l.
Proof with auto.
  induction l...
  simpl.
  destruct (Xeq x a)...
  simpl. rewrite IHl...
Qed.

Definition In_remove (l: list X) (x y: X): (In x l /\ y <> x) <-> In x (remove Xeq y l).
Proof with auto.
  intros.
  rewrite remove_eq_filter.
  destruct (filter_In (fun y0 : X => negb (unsumbool (Xeq y y0))) x l).
  split; intro.
    apply H0. destruct H1.
    destruct (Xeq y x)...
  destruct (H H1).
  destruct (Xeq y x)...
  discriminate.
Qed.

Definition In_remove' (l: list X) (x y: X): In x l -> y <> x -> In x (remove Xeq y l).
  (* redundant, but easier to apply and use as hint. *)
Proof. intros. apply (In_remove l x y); auto. Qed.

Lemma incl_filter (p: X -> bool) (l: list X): incl (filter p l) l.
Proof with auto.
  unfold incl.
  induction l; simpl...
  intros.
  destruct (p a); firstorder.
Qed.

Definition incl_remove (l: list X) (x: X): incl (remove Xeq x l) l.
Proof. intros. rewrite remove_eq_filter. apply incl_filter. Qed.

Lemma In_subtr a b x: In x (subtr a b) -> (In x a /\ ~ In x b).
Proof with auto.
  revert a b x.
  induction b...
  simpl.
  rewrite remove_eq_filter.
  intros.
  destruct (fst (filter_In _ x (subtr a b)) H).
  destruct (IHb _ H0).
  split...
  intro.
  destruct H4...
  subst.
  destruct (Xeq x x)...
  discriminate.
Qed.

Lemma subtr_In a b x: In x a -> ~ In x b -> In x (subtr a b).
Proof with auto.
  induction b...
  simpl. intros.
  apply (In_remove (subtr a b) x a0).
  split...
Qed.

Lemma incl_subtr a b: incl (subtr a b) a.
Proof with auto.
  induction b.
    simpl. apply incl_refl.
  simpl.
  apply incl_tran with (subtr a b)...
  apply incl_remove.
Qed.

Lemma intersection_In' (x: X) a b:
  In x a -> In x b -> In x (intersection a b).
Proof with auto.
  unfold intersection.
  intros.
  apply (filter_In (fun e : X => unsumbool (In_dec Xeq e a)) x b).
  destruct (In_dec Xeq x a)...
Qed.

Lemma intersection_In (x: X) a b:
  In x (intersection a b) -> (In x a /\ In x b).
Proof with auto.
  induction a...
    unfold intersection.
    simpl.
    intros.
    destruct (filter_In (fun _ => false) x b).
    destruct (H0 H). discriminate.
  unfold intersection in *.
  intros.
  destruct (filter_In (fun e : X => unsumbool (In_dec Xeq e (a :: a0))) x b).
  set (H0 H). clearbody a1. clear H0 H H1.
  destruct a1.
  destruct (In_dec Xeq x (a :: a0))...
  discriminate.
Qed.

Lemma incl_intersection_left (a b c: list X):
  incl a c -> incl (intersection a b) c.
Proof with auto.
  repeat intro.
  destruct (intersection_In a0 a b H0)...
Qed.

Lemma NoDup_map (A B: Type) (f: A -> B) l:
  (forall x y, In x l -> In y l -> f x = f y -> x = y) -> NoDup l -> NoDup (map f l).
Proof with simpl; auto.
  induction l...
    intros.
    apply NoDup_nil.
  intros.
  simpl.
  inversion_clear H0.
  apply NoDup_cons...
  intro.
  apply H1.
  destruct (fst (in_map_iff f l (f a)) H0).
  destruct H3.
  rewrite H with a x...
Qed.

Lemma NoDup_filter (p: X -> bool) (l: list X):
  NoDup l -> NoDup (filter p l).
Proof with auto.
  induction l...
  simpl.
  intros.
  inversion_clear H.
  destruct (p a)...
  apply NoDup_cons...
  intro.
  apply H0...
  apply (incl_filter p l)...
Qed.

Lemma NoDup_intersection_right a b: NoDup b -> NoDup (intersection a b).
Proof with auto.
  unfold intersection.
  intros.
  apply NoDup_filter...
Qed.

Lemma not_In_filter (x: X) p l: ~ In x (filter p l) ->
  In x l -> p x = false.
Proof with auto.
  induction l.
    simpl.
    intros.
    elimtype False...
  simpl.
  intros.
  destruct H0.
    subst.
    case_eq (p x)...
    intros.
    rewrite H0 in H.
    elimtype False.
    apply H. left...
  apply IHl...
  destruct (p a)...
Qed.

Lemma not_In_filter' (x: X) p l: ~ In x (filter p l) ->
  (~ In x l \/ p x = false).
Proof with auto.
  intros.
  destruct (In_dec Xeq x l).
    right. apply not_In_filter with l...
  left...
Qed.

Lemma not_in_app (x: X) a b: ~ In x (a ++ b) -> ~ In x a \/ ~ In x b.
Proof with auto.
  induction a...
  simpl.
  intros.
  firstorder.
Qed.

Lemma NoDup_app (a b: list X): NoDup a -> NoDup b ->
  (forall x, In x a -> ~ In x b) -> NoDup (a ++ b).
Proof with auto.
  induction a...
  intros.
  simpl.
  inversion_clear H.
  apply NoDup_cons.
    intro.
    destruct (in_app_or _ _ _ H)...
    apply (H1 a)...
  apply IHa...
Qed.

Lemma NoDup_subtr a b: NoDup a -> NoDup (subtr a b).
Proof with auto.
  induction b...
  simpl. intros.
  rewrite remove_eq_filter.
  apply NoDup_filter...
Qed.

Lemma NoDup_remove a: NoDup a -> forall b, NoDup (remove Xeq b a).
Proof.
  intros.
  rewrite remove_eq_filter.
  apply NoDup_filter.
  assumption.
Qed.

Definition NoDup_dec (l: list X): decision (NoDup l).
Proof with auto.
  induction l.
    left. apply NoDup_nil.
  destruct IHl.
    destruct (In_dec Xeq a l).
      right.
      intro.
      inversion H. apply (H2 i).
    left. apply NoDup_cons; assumption.
  right. intro. apply n. inversion H...
Defined.

End with_eq_dec.

Lemma NoDup_flat_map (A B: Type) (f: A -> list B) l:
  (forall x a b, In a l -> In b l -> In x (f a) -> In x (f b)
    -> a = b) ->
  (forall x, In x l -> NoDup (f x)) ->
  NoDup l -> NoDup (flat_map f l).
Proof with simpl; auto.
  induction l; simpl; intros.
    apply NoDup_nil.
  inversion_clear H1...
  apply NoDup_app...
    apply IHl...
    intros.
    apply H with x...
  intros. intro.
  destruct (fst (in_flat_map f l x) H4).
  destruct H5.
  apply H2.
  rewrite <- (H x x0 a )...
Qed.

Hint Resolve NoDup_subtr.
Hint Resolve NoDup_filter.
Hint Resolve NoDup_remove.
Hint Resolve NoDup_intersection_right.
Hint Resolve subtr_In.
Hint Resolve In_remove'.
Hint Resolve in_or_app.
Hint Resolve intersection_In'.
Hint Resolve in_eq.
Hint Resolve in_cons.
Hint Resolve NoDup_cons.
Hint Resolve NoDup_nil.

Lemma in_filter (A : Type) (f : A -> bool) (x : A) (l : list A) :
  In x l -> f x = true -> In x (filter f l).
Proof.
  intros. destruct filter_In with A f x l. firstorder.
Qed.

Lemma existsb_forall :
  forall A (l : list A) P x,
    existsb P l = false -> In x l -> P x = false.
Proof.
  induction l; intros.
  contradiction.
  destruct (Bool.orb_false_elim _ _ H).
  destruct H0.
  subst. hyp.
  apply IHl; hyp.
Qed.

Lemma filter_app (A : Type) (f : A -> bool) ls ls' :
  filter f ls ++ filter f ls' =
  filter f (ls ++ ls').
Proof.
  induction ls. ref. intros.
  simpl. destruct (f a); simpl. rewrite IHls. ref. apply IHls.
Qed.

Section ExhaustivePairList.

  Context {A B} {EA: ExhaustiveList A} {EB: ExhaustiveList B}.

  Global Instance ExhaustivePairList:
     ExhaustiveList (A*B)
      := { exhaustive_list := flat_map (fun i => map (pair i) EB) EA }.
  Proof.
    intros [a b].
    destruct (in_flat_map (fun i => map (pair i) EB) EA (a, b)).
    eauto.
  Defined.

  Lemma NoDup_ExhaustivePairList:
    NoDup EA -> NoDup EB -> NoDup ExhaustivePairList.
  Proof with auto.
    intros H H0.
    simpl.
    apply NoDup_flat_map; intros...
      destruct (fst (in_map_iff (pair a) EB x) H3) as [x0 [C D]].
      destruct (fst (in_map_iff (pair b) EB x) H4) as [x1 [E F]].
      subst. inversion E...
    apply NoDup_map...
    intros. inversion H4...
  Qed.

End ExhaustivePairList.

Instance decide_exists_in {T} {P} `{forall x: T, decision (P x)} l: decision (exists x, In x l /\ P x).
Proof.
  repeat intro.
  case_eq (existsb H l); intro.
    left.
    destruct (fst (existsb_exists _ _) H0).
    exists x.
    destruct H1.
    split. assumption.
    apply (decision_true _ H2).
  right.
  intros [x [H1 H2]].
  exact (decision_false _ (existsb_forall l H x H0 H1) H2).
Defined.

Instance decide_exists {T} {P} `{ExhaustiveList T} `{forall x: T, decision (P x)}: decision (exists x, P x).
Proof.
  intros. destruct (decide_exists_in H); [left | right]; firstorder.
Defined.

Program Instance overestimate_exists_in
   {T} {P} `{H: forall x: T, overestimation (P x)} l: overestimation (exists x, In x l /\ P x) := existsb H l.
Next Obligation.
  intros [x [A B]].
  rewrite (snd (existsb_exists H l)) in H0.
    discriminate.
  eauto 20 using overestimation_true.
Defined.

Instance overestimate_exists {T} {P} `{ExhaustiveList T} `{forall x: T, overestimation (P x)}: overestimation (exists x, P x).
Proof.
  intros.
  exists (overestimate_exists_in H).
  intro.
  pose proof (overestimation_false _ H1).
  firstorder.
Defined.

Instance In_decision {T} `{EquivDec.EqDec T eq} (x: T) y: decision (In x y) := In_dec EquivDec.equiv_dec x y.

Section carts.

  Variables (A B: Type) (a: list A) (b: list B).

  Definition cart: list (A * B) :=
    flat_map (fun x => map (pair x) b) a.

  Lemma in_cart (ab: A * B): In (fst ab) a -> In (snd ab) b -> In ab cart.
  Proof with auto.
    intros.
    apply <- in_flat_map.
    destruct ab.
    eauto.
  Qed.

  Lemma NoDup_cart: NoDup a -> NoDup b -> NoDup cart.
  Proof with auto.
    intros.
    apply NoDup_flat_map; intros...
      destruct (fst (in_map_iff _ _ _) H3).
      destruct (fst (in_map_iff _ _ _) H4).
      intuition.
      congruence.
    apply NoDup_map...
    congruence.
  Qed.

End carts.

Section List_prods.

  Variable A : Type.

  (* [list_combine [x_1; ... x_n] [y_1; ... y_n] = [x_1::y_1; ... x_n::y_n; x_2::y_1 ... x_n::y_n]] *)
  Fixpoint list_combine (l : list A) (l' : list (list A)) : list (list A) :=
    match l with
    | [] => []
    | x::xs => List.map (fun y_i => x::y_i) l' ++ list_combine xs l'
    end.

  (* list_prod_tuple [xs_1; ... xs_n] gives a list containing every
     list of the form [x_1; ... x_n] where [In x_1 xs_1], ... [In x_n xs_n].
   *)
  Fixpoint list_prod_tuple (elts : list (list A)) : list (list A) :=
    match elts with
    | [] => [[]]
    | x::xs => list_combine x (list_prod_tuple xs)
    end.

End List_prods.

(*
Eval vm_compute in list_combine [1; 2] [[3;4]; [5;6]].
Eval vm_compute in list_prod_tuple [[1;2]; [3;4]; [5;6]].
*)

Ltac NoDup_simpl :=
  repeat
    match goal with
    | |- NoDup (_ ++ _) => apply NoDup_app
    | |- NoDup (map _ _) => apply NoDup_map
    | H : NoDup (_::_) |- _ => inversion H; clear H
    end.

Ltac list_simpl :=
  repeat
    match goal with
    | H : In _ (?l ++ ?m) |- _ =>
        destruct (in_app_or l m _ H); clear H
    | H : In _ (map _ _) |- _ =>
        destruct (proj1 (in_map_iff _ _ _) H); clear H
    end.


Definition var := nat.

Require Import Arith MSetList Setoid.

Declare Module Var_as_OT : UsualOrderedType
  with Definition t := var.
Module Import VarSet := MSetList.Make Var_as_OT.

Definition vars := VarSet.t.

Notation "{}" := (VarSet.empty).
Notation "{{ x }}" := (VarSet.singleton x).
Notation "s [=] t " := (VarSet.Equal s t) (at level 70, no associativity).
Notation "E \u F" := (VarSet.union E F)  (at level 68, left associativity).
Notation "x \in E" := (VarSet.In x E) (at level 69).
Notation "x \notin E" := (~ VarSet.In x E) (at level 69).
Notation "E << F" := (VarSet.Subset E F) (at level 70, no associativity).
Notation "E \rem F" := (VarSet.remove F E) (at level 70).

Lemma eq_var_dec : forall x y : var, {x = y} + {x <> y}.
Proof. exact eq_nat_dec. Qed.

Notation "x == y" := (eq_var_dec x y) (at level 67).
Notation "i === j" := (Peano_dec.eq_nat_dec i j) (at level 67).

(** Pre-terms are defined according to the following grammar: *)
Inductive pterm : Set :=
  | pterm_bvar : nat -> pterm
  | pterm_fvar : var -> pterm
  | pterm_app  : pterm -> pterm -> pterm
  | pterm_abs  : pterm -> pterm
  | pterm_labs  : pterm -> pterm.

Fixpoint fv (t : pterm) : vars :=
  match t with
  | pterm_bvar i    => {}
  | pterm_fvar x    => {{x}}
  | pterm_app t1 t2 => (fv t1) \u (fv t2)
  | pterm_abs t1    => (fv t1)
  | pterm_labs t1    => (fv t1)
  end.

Ltac gather_vars_with F :=
  let rec gather V :=
    match goal with
    | H: ?S |- _ =>
      let FH := constr:(F H) in
      match V with
      | {} => gather FH
      | context [FH] => fail 1
      | _ => gather (FH \u V)
      end
    | _ => V
    end in
  let L := gather {} in eval simpl in L.

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => {{ x }}) in
  let D := gather_vars_with (fun x : pterm => fv x) in
  constr:(A \u B \u D).

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | ?E1 \u ?E2 => let Acc1 := go Acc E1 in
                     go Acc1 E2
     | {}  => Acc
     | ?E1 => match Acc with
              | {} => E1
              | _ => constr:(Acc \u E1)
              end
     end
  in go {} V.

Require Import List Omega.
Open Scope list_scope.

Lemma max_lt_l :
  forall (x y z : nat), x <= y -> x <= max y z.
Proof.
  induction x; auto with arith.
  induction y; induction z; simpl; auto with arith.
Qed.

Lemma finite_nat_list_max : forall (l : list nat),
  { n : nat | forall x, In x l -> x <= n }.
Proof.
  induction l as [ | l ls IHl ].
  - exists 0; intros x H; inversion H.
  - inversion IHl as [x H]; clear IHl.
    exists (max x l).
    intros x' Hin.
    inversion Hin; subst.
    + auto with arith.
    + assert (x' <= x); auto using max_lt_l.
Qed.

Lemma finite_nat_list_max' : forall (l : list nat),
  { n : nat | ~ In n l }.
Proof.
  intros l. case (finite_nat_list_max l); intros x H.
  exists (S x). intros J. assert (K := H _ J); omega.
Qed.

Definition var_gen (L : vars) : var :=
  proj1_sig (finite_nat_list_max' (elements L)).

Lemma var_gen_spec : forall E, (var_gen E) \notin E.
Proof.
  unfold var_gen. intros E.
  destruct (finite_nat_list_max' (elements E)) as [n pf].
  simpl. intros a.
  destruct pf.
  apply elements_spec1 in a.
  rewrite InA_alt in a.
  destruct a as [y [H1 H2]].
  subst; assumption.
Qed.

Lemma var_fresh : forall (L : vars), { x : var | x \notin L }.
Proof.
  intros L. exists (var_gen L). apply var_gen_spec.
Qed.

Ltac pick_fresh_gen L Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (var_fresh L) as [Y Fr]).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Fixpoint open_rec (k : nat) (u : pterm) (t : pterm) : pterm :=
  match t with
  | pterm_bvar i    => if k === i then u else (pterm_bvar i)
  | pterm_fvar x    => pterm_fvar x
  | pterm_app t1 t2 => pterm_app (open_rec k u t1) (open_rec k u t2)
  | pterm_abs t1    => pterm_abs (open_rec (S k) u t1)
  | pterm_labs t1    => pterm_labs (open_rec (S k) u t1)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (pterm_fvar x)).

(** Check how close operation is being used in the formalization.
Fixpoint close_rec  (k : nat) (x : var) (t : pterm) : pterm :=
  match t with
  | pterm_bvar i    => pterm_bvar i
  | pterm_fvar x'    => if x' == x then (pterm_bvar k) else pterm_fvar x'
  | pterm_app t1 t2 => pterm_app (close_rec k x t1) (close_rec k x t2)
  | pterm_abs t1    => pterm_abs (close_rec (S k) x t1)
  | pterm_sub t1 t2 => pterm_sub (close_rec (S k) x t1) (close_rec k x t2)
  end.

Definition close t x := close_rec 0 x t. *)
(* end hide *)
(** ES terms are expressions without dangling deBruijn indexes. *)

Inductive term : pterm -> Prop :=
  | term_var : forall x,
      term (pterm_fvar x)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (pterm_app t1 t2)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (pterm_abs t1).

Inductive lterm : pterm -> Prop :=
  | term_lvar : forall x,
      lterm (pterm_fvar x)
  | term_lapp : forall t1 t2,
      lterm t1 ->
      lterm t2 ->
      lterm (pterm_app t1 t2)
  | term_lrdx : forall L t1 t2,
      (forall x, x \notin L -> lterm (t1 ^ x)) ->
      lterm t2 ->
      lterm (pterm_app (pterm_labs t1) t2)
  | term_labs : forall L t1,
      (forall x, x \notin L -> lterm (t1 ^ x)) ->
      lterm (pterm_abs t1).

Hint Constructors lterm term.

Definition Rel (A:Type) := A -> A -> Prop.

Inductive contextual_closure (R: Rel pterm) : Rel pterm :=
  | redex : forall t s, R t s -> contextual_closure R t s
  | app_left : forall t t' u, contextual_closure R t t' -> term u ->
	  		      contextual_closure R (pterm_app t u) (pterm_app t' u)
  | app_right : forall t u u', contextual_closure R u u' -> term t ->
	  		       contextual_closure R (pterm_app t u) (pterm_app t u')
  | abs_in : forall t t' L, (forall x, x \notin L -> contextual_closure R (t^x) (t'^x)) ->
                               contextual_closure R (pterm_abs t) (pterm_abs t').

Definition body t := exists L, forall x, x \notin L -> term (t ^ x).

Inductive rule_b : Rel pterm  :=
  reg_rule_b : forall (t u:pterm),
    body t -> term u ->
    rule_b (pterm_app(pterm_abs t) u) (t ^^ u).
Notation "t -->>B u" := (contextual_closure rule_b t u) (at level 60).

Inductive rule_lb : Rel pterm  :=
  | reg_rule_bb : forall (t u:pterm),
    body t -> term u ->
    rule_lb (pterm_app(pterm_abs t) u) (t ^^ u)
  | reg_rule_lb : forall (t u:pterm),
    body t -> term u ->
    rule_lb (pterm_app(pterm_labs t) u) (t ^^ u).
Notation "t -->> u" := (contextual_closure rule_lb t u) (at level 60).

Fixpoint phi (t:pterm) : pterm :=
  match t with
  | pterm_app t1 t2 => match t1 with
                      | pterm_labs t1' => (phi t1') ^^ (phi t2)
                      | _ => pterm_app (phi t1) (phi t2)
                      end
  | pterm_abs t1 => pterm_abs (phi t1)
  | _ => t
  end.

Fixpoint erase (t:pterm) : pterm :=
  match t with
  | pterm_app t1 t2 => pterm_app (erase t1) (erase t2)
  | pterm_abs t1 => pterm_abs (erase t1)
  | pterm_labs t1 => pterm_abs (erase t1)
  | _ => t
  end.

Lemma erase_prop : forall M N M' N': pterm, term M -> term N -> (M -->>B N) -> erase M' = M -> erase N' = N ->  (M' -->> N').
Proof.
  Admitted.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(*                              Le_lt_compl.v                               *)

(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*
 This file gives some additionnal lemmas to the modules
Le and Lt of the distribution: ($COQTH/ARITH/[Le,Lt] )

 Please notice that some lemmas and proofs use the constants
 one,two,three,four declared in the "Constants" module
*)

Require Import Arith.
Require Import Constants.

Lemma lt_or_Zero : forall q : nat, 0 < q \/ q = 0.
(************************************)
Proof.
  simple induction q; auto with arith.
Qed.

Lemma one_cases : forall q : nat, 1 < q \/ q = 0 \/ q = 1.
(************************************************)
Proof.
 simple induction q; auto with arith.
 simple induction n; auto with arith.
Qed.

Lemma enum1 : forall n : nat, n < two -> n = 0 \/ n = 1.
(******************************************)
Proof.
 intro n; case (one_cases n); [ idtac | auto with arith ].
 intros; absurd (two <= n); auto with arith.
Qed.

Lemma le5 :
 forall P : nat -> Prop,
 P 0 ->
 P one ->
 P two ->
 P three ->
 P four -> (forall n : nat, four < n -> P n) -> forall n : nat, P n.
(************************************)
Proof.
simple induction n;
 [ auto 2 with arith
 | simple induction n0;
    [ auto 2 with arith
    | simple induction n1;
       [ auto 2 with arith
       | simple induction n2;
          [ auto 2 with arith
          | simple induction n3;
             [ auto 2 with arith
             | intros; apply H4; unfold four in |- *; repeat apply lt_n_S;
                auto with arith ] ] ] ] ].
Qed.

Lemma enum4 :
 forall n : nat,
 n < S four -> n = 0 \/ n = one \/ n = two \/ n = three \/ n = four.
(*********************************************)
Proof.
 intro n; pattern n in |- *; apply le5; auto with arith.
 intros.
 absurd (n0 < S four); auto with arith.
Qed.

Lemma not_le_lt : forall n m : nat, ~ n <= m -> m < n.
(*******************************************)
Proof.
 intros; case (le_or_lt n m); [ intro | auto with arith ].
 elim (H H0).
Qed.
Hint Immediate not_le_lt: arith.

Lemma not_lt_le : forall n m : nat, ~ n < m -> m <= n.
(*******************************************)
Proof.
 intros; case (le_or_lt m n); [ auto with arith | intro ].
 elim (H H0).
Qed.
Hint Immediate not_lt_le: arith.

Lemma lt_not_lt : forall n p : nat, n < p -> ~ p < S n.
(***************************************************)
Proof.
 auto with arith.
Qed.

Lemma lt_a_a_plus_b : forall a b : nat, 0 < b -> a < a + b.
(*******************************************************)
Proof.
 intros.
 pattern a at 1 in |- *; rewrite (plus_n_O a); auto with arith.
Qed.

Hint Resolve lt_a_a_plus_b: arith.


Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. destruct c eqn:Ec.
  - reflexivity.
  - intros H. rewrite <- H. destruct b eqn: Eb.
    + simpl. reflexivity.
    + simpl. reflexivity.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* This file is a renaming for V5.10.14b, Oct 1995, of file Classical.v
   introduced in Coq V5.8.3, June 1993 *)

(** Classical Predicate Logic on Type *)

Require Import Classical_Prop.

Section Generic.
Variable U : Type.

(** de Morgan laws for quantifiers *)

Lemma not_all_not_ex :
 forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
Proof.
intros P notall.
apply NNPP.
intro abs.
apply notall.
intros n H.
apply abs; exists n; exact H.
Qed.

Lemma not_all_ex_not :
 forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
Proof.
intros P notall.
apply not_all_not_ex with (P:=fun x => ~ P x).
intro all; apply notall.
intro n; apply NNPP.
apply all.
Qed.

Lemma not_ex_all_not :
 forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
Proof. (* Intuitionistic *)
unfold not in |- *; intros P notex n abs.
apply notex.
exists n; trivial.
Qed.

Lemma not_ex_not_all :
 forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
Proof.
intros P H n.
apply NNPP.
red in |- *; intro K; apply H; exists n; trivial.
Qed.

Lemma ex_not_not_all :
 forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
Proof. (* Intuitionistic *)
unfold not in |- *; intros P exnot allP.
elim exnot; auto.
Qed.

Lemma all_not_not_ex :
 forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
Proof. (* Intuitionistic *)
unfold not in |- *; intros P allnot exP; elim exP; intros n p.
apply allnot with n; auto.
Qed.

End Generic.


Section update_def.
  Variables (A:Set) (A_eq_dec : forall x y :A, {x=y} + {x<>y}).
  Variables (B:A -> Set) (a:A) (v:B a) (f:forall x:A, B x).
  Definition update (x:A) : B x :=
    match A_eq_dec a x with
      | left h => eq_rec a B v x h
      | right h' => f x
    end.
End update_def.

Require Import Eqdep.

Theorem update_eq :
  forall (A:Set) (eq_dec:forall x y:A, {x = y} + {x<>y})
         (B:A->Set) (a:A) (v:B a) (f:forall x:A, B x),
    update A eq_dec B a v f a = v.
  intros. unfold update. case (eq_dec a a). intros.  symmetry. apply eq_rec_eq.
  unfold not. intros. elim (n (eq_refl a)).
Qed.


Require Import List.

Require Import NArith.
Require ZArith.

Import ListNotations.
Open Scope bool_scope.
Open Scope N_scope.

Fixpoint truncate_pos (n : nat) (xs : positive) : N :=
  match n, xs with
  | O, _ => 0
  | S _, xH => Npos xH
  | S n', xI xs' => Pos.Nsucc_double (truncate_pos n' xs')
  | S n', xO xs' => Pos.Ndouble (truncate_pos n' xs')
  end.

Definition truncate (n : nat) (xs : N) : N :=
  match xs with
  | N0 => 0
  | Npos xs' => truncate_pos n xs'
  end.

Fixpoint shiftl_pos (n : nat) (ys : positive) : positive :=
  match n with
  | O => ys
  | S n' => xO (shiftl_pos n' ys)
  end.

Fixpoint catbit_pos (n : nat) (xs : positive) (ys : positive) :
  positive :=
  match n, xs with
  | O, _ => ys
  | S n', xH => xI (shiftl_pos n' ys)
  | S n', xI xs' => xI (catbit_pos n' xs' ys)
  | S n', xO xs' => xO (catbit_pos n' xs' ys)
  end.

Definition catbit (n : nat) (xs : N) (ys : N) : N :=
  match ys with
  | N0 => xs
  | Npos ys' =>
    match xs with
    | N0 => Npos (shiftl_pos n ys')
    | Npos xs' => Npos (catbit_pos n xs' ys')
    end
  end.

Example ex_catbit : catbit 3 2 1 = 10. Proof. reflexivity. Qed.

Fixpoint hex' (hs : list N) : N :=
  match hs with
  | [] => 0
  | h :: hs' => catbit 4 h (hex' hs')
  end.

Definition hex hs := hex' (rev hs).

Example ex_hex : hex [1;0;0] = 256. Proof. reflexivity. Qed.

Definition N64 := N.

Notation A := 10%N.
Notation B := 11%N.
Notation C := 12%N.
Notation D := 13%N.
Notation E := 14%N.
Notation F := 15%N.

(* 0x9e3779b97f4a7c15 *)
Definition golden_gamma : N :=
  hex [9;E;3;7;7;9;B;9;7;F;4;A;7;C;1;5].

Definition shift_xor z n :=
  N.lxor z (N.shiftr z n).

Definition mix64 z :=
  (* 0xff51afd7ed558ccd *)
  let c0 := hex [F;F;5;1;A;F;D;7;E;D;5;5;8;C;C;D] in
  (* 0xc4ceb9fe1a85ec53 *)
  let c1 := hex [C;4;C;E;B;9;F;E;1;A;8;5;E;C;5;3] in
  let z := truncate 64 (shift_xor z 33 * c0) in
  let z := truncate 64 (shift_xor z 33 * c1) in
  truncate 64 (shift_xor z 33).

Definition mix64variant13 z :=
  (* 0xbf58476d1ce4e5b9 *)
  let c0 := hex [B;F;5;8;4;7;6;D;1;C;E;4;E;5;B;9] in
  (* 0x94d049bb133111eb *)
  let c1 := hex [9;4;D;0;4;9;B;B;1;3;3;1;1;1;E;B] in
  let z := truncate 64 (shift_xor z 30 * c0) in
  let z := truncate 64 (shift_xor z 27 * c1) in
  truncate 64 (shift_xor z 31).

Definition popcount_under (n : nat) (z : N) : bool :=
  match z with
  | N0 => true
  | Npos xs =>
    let fix popcount_under' n xs :=
        match n, xs with
        | O, _ => false
        | _, xO xs' => popcount_under' n xs'
        | S n', xI xs' => popcount_under' n' xs'
        | _, xH => true
        end in
    popcount_under' n xs
  end.

Definition mix_gamma z :=
  let z := N.lor (mix64 z) 1 in
  if popcount_under 24 (truncate 64 (shift_xor z 1)) then
    N.lxor z (hex [A;A;A;A;A;A;A;A;A;A;A;A;A;A;A;A])
  else
    z.

Record State := MkState {
  seed : N64;
  gamma : N64;
}.

Definition of_seed n : State :=
  {| seed := n; gamma := golden_gamma |}.

Definition mk_split s1 s2 :=
  {| seed := mix64variant13 s1;
     gamma := mix_gamma s2;
  |}.

Definition split '(MkState s0 g) :=
  let s1 := truncate 64 (s0 + g) in
  let s2 := truncate 64 (s1 + g) in
  let rng1 := mk_split s1 s2 in
  let rng2 := MkState s2 g in
  (rng1, rng2).

Definition next_int64 '(MkState s0 g) :=
  let s1 := truncate 64 (s0 + g) in
  (mix64variant13 s1, MkState s1 g).

(* Misc utils. *)

Import BinInt.

Definition two's (n : N) : Z :=
  if n <? 2 ^ 63 then
    Z.of_N n
  else
    Z.of_N n - 2 ^ 64.