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

(** Efficient implementation of [MSetInterface.S] for positive keys,
    inspired from the [FMapPositive] module.

   This module was adapted by Alexandre Ren, Damien Pous, and Thomas
   Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive]
   module of Pierre Letouzey and Jean-Christophe Filliâtre, which in
   turn comes from the [FMap] framework of a work by Xavier Leroy and
   Sandrine Blazy (used for building certified compilers).
*)

Require Import Bool BinPos Orders MSetInterface.

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

(** Even if [positive] can be seen as an ordered type with respect to the
  usual order (see above), we can also use a lexicographic order over bits
  (lower bits are considered first). This is more natural when using
  [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)

Module PositiveOrderedTypeBits <: UsualOrderedType.
  Definition t:=positive.
  Include HasUsualEq <+ UsualIsEq.
  Definition eqb := Pos.eqb.
  Definition eqb_eq := Pos.eqb_eq.
  Include HasEqBool2Dec.

  Fixpoint bits_lt (p q:positive) : Prop :=
   match p, q with
   | xH, xI _ => True
   | xH, _ => False
   | xO p, xO q => bits_lt p q
   | xO _, _ => True
   | xI p, xI q => bits_lt p q
   | xI _, _ => False
   end.

  Definition lt:=bits_lt.

  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
  Proof.
   induction x; simpl; auto.
  Qed.

  Lemma bits_lt_trans :
    forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
  Proof.
   induction x; destruct y,z; simpl; eauto; intuition.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
   intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
  Qed.

  Instance lt_strorder : StrictOrder lt.
  Proof.
   split; [ exact bits_lt_antirefl | exact bits_lt_trans ].
  Qed.

  Fixpoint compare x y :=
    match x, y with
      | x~1, y~1 => compare x y
      | x~1, _ => Gt
      | x~0, y~0 => compare x y
      | x~0, _ => Lt
      | 1, y~1 => Lt
      | 1, 1 => Eq
      | 1, y~0 => Gt
    end.

  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof.
   unfold eq, lt.
   induction x; destruct y; try constructor; simpl; auto.
    destruct (IHx y); subst; auto.
    destruct (IHx y); subst; auto.
  Qed.

End PositiveOrderedTypeBits.

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

  Module E:=PositiveOrderedTypeBits.

  Definition elt := positive.

  Inductive tree :=
    | Leaf : tree
    | Node : tree -> bool -> tree -> tree.

  Scheme tree_ind := Induction for tree Sort Prop.

  Definition t := tree.

  Definition empty := Leaf.

  Fixpoint is_empty (m : t) : bool :=
   match m with
    | Leaf => true
    | Node l b r => negb b &&& is_empty l &&& is_empty r
   end.

  Fixpoint mem (i : positive) (m : t) : bool :=
    match m with
    | Leaf => false
    | Node l o r =>
        match i with
        | 1 => o
        | i~0 => mem i l
        | i~1 => mem i r
        end
    end.

  Fixpoint add (i : positive) (m : t) : t :=
    match m with
    | Leaf =>
        match i with
        | 1 => Node Leaf true Leaf
        | i~0 => Node (add i Leaf) false Leaf
        | i~1 => Node Leaf false (add i Leaf)
        end
    | Node l o r =>
        match i with
        | 1 => Node l true r
        | i~0 => Node (add i l) o r
        | i~1 => Node l o (add i r)
        end
    end.

  Definition singleton i := add i empty.

  (** helper function to avoid creating empty trees that are not leaves *)

  Definition node l (b: bool) r :=
    if b then Node l b r else
     match l,r with
       | Leaf,Leaf => Leaf
       | _,_ => Node l false r end.

  Fixpoint remove (i : positive) (m : t) : t :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match i with
          | 1 => node l false r
          | i~0 => node (remove i l) o r
          | i~1 => node l o (remove i r)
        end
    end.

  Fixpoint union (m m': t) :=
    match m with
      | Leaf => m'
      | Node l o r =>
        match m' with
          | Leaf => m
          | Node l' o' r' => Node (union l l') (o||o') (union r r')
        end
    end.

  Fixpoint inter (m m': t) :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match m' with
          | Leaf => Leaf
          | Node l' o' r' => node (inter l l') (o&&o') (inter r r')
        end
    end.

  Fixpoint diff (m m': t) :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match m' with
          | Leaf => m
          | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
        end
    end.

  Fixpoint equal (m m': t): bool :=
    match m with
      | Leaf => is_empty m'
      | Node l o r =>
        match m' with
          | Leaf => is_empty m
          | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
        end
    end.

  Fixpoint subset (m m': t): bool :=
    match m with
      | Leaf => true
      | Node l o r =>
        match m' with
          | Leaf => is_empty m
          | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
        end
    end.

  (** reverses [y] and concatenate it with [x] *)

  Fixpoint rev_append y x :=
    match y with
      | 1 => x
      | y~1 => rev_append y x~1
      | y~0 => rev_append y x~0
    end.
  Infix "@" := rev_append (at level 60).
  Definition rev x := x@1.

  Section Fold.

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

    (** the additional argument, [i], records the current path, in
       reverse order (this should be more efficient: we reverse this argument
       only at present nodes only, rather than at each node of the tree).
       we also use this convention in all functions below
     *)

    Fixpoint xfold (m : t) (v : B) (i : positive) :=
      match m with
        | Leaf => v
        | Node l true r =>
          xfold r (f (rev i) (xfold l v i~0)) i~1
        | Node l false r =>
          xfold r (xfold l v i~0) i~1
      end.
    Definition fold m i := xfold m i 1.

  End Fold.

  Section Quantifiers.

    Variable f : positive -> bool.

    Fixpoint xforall (m : t) (i : positive) :=
      match m with
        | Leaf => true
        | Node l o r =>
          (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
      end.
    Definition for_all m := xforall m 1.

    Fixpoint xexists (m : t) (i : positive) :=
      match m with
        | Leaf => false
        | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
      end.
    Definition exists_ m := xexists m 1.

    Fixpoint xfilter (m : t) (i : positive) :=
      match m with
        | Leaf => Leaf
        | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
      end.
    Definition filter m := xfilter m 1.

    Fixpoint xpartition (m : t) (i : positive) :=
      match m with
        | Leaf => (Leaf,Leaf)
        | Node l o r =>
          let (lt,lf) := xpartition l i~0 in
          let (rt,rf) := xpartition r i~1 in
             if o then
               let fi := f (rev i) in
                 (node lt fi rt, node lf (negb fi) rf)
             else
                 (node lt false rt, node lf false rf)
      end.
    Definition partition m := xpartition m 1.

  End Quantifiers.

  (** uses [a] to accumulate values rather than doing a lot of concatenations *)

  Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
    match m with
      | Leaf => a
      | Node l false r => xelements l i~0 (xelements r i~1 a)
      | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
    end.

  Definition elements (m : t) := xelements m 1 nil.

  Fixpoint cardinal (m : t) : nat :=
    match m with
      | Leaf => O
      | Node l false r => (cardinal l + cardinal r)%nat
      | Node l true r => S (cardinal l + cardinal r)
    end.

  Definition omap (f: elt -> elt) x :=
    match x with
      | None => None
      | Some i => Some (f i)
    end.

  (** would it be more efficient to use a path like in the above functions ? *)

  Fixpoint choose (m: t) :=
    match m with
      | Leaf => None
      | Node l o r => if o then Some 1 else
        match choose l with
          | None => omap xI (choose r)
          | Some i => Some i~0
        end
    end.

  Fixpoint min_elt (m: t) :=
    match m with
      | Leaf => None
      | Node l o r =>
        match min_elt l with
          | None => if o then Some 1 else omap xI (min_elt r)
          | Some i => Some i~0
        end
    end.

  Fixpoint max_elt (m: t) :=
    match m with
      | Leaf => None
      | Node l o r =>
        match max_elt r with
          | None => if o then Some 1 else omap xO (max_elt l)
          | Some i => Some i~1
        end
    end.

  (** lexicographic product, defined using a notation to keep things lazy *)

  Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.

  Definition compare_bool a b :=
    match a,b with
      | false, true => Lt
      | true, false => Gt
      | _,_ => Eq
    end.

  Fixpoint compare (m m': t): comparison :=
    match m,m' with
      | Leaf,_ => if is_empty m' then Eq else Lt
      | _,Leaf => if is_empty m then Eq else Gt
      | Node l o r,Node l' o' r' =>
        lex (compare_bool o o') (lex (compare l l') (compare r r'))
    end.

  Definition In i t := mem i t = true.
  Definition Equal s s' := forall a : elt, In a  s <-> In a  s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).

  Definition eq := Equal.
  Definition lt m m' := compare m m' = Lt.

  (** Specification of [In] *)

  Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
  Proof.
   intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition.
  Qed.

  (** Specification of [eq] *)

  Local Instance eq_equiv : Equivalence eq.
  Proof. firstorder. Qed.

  (** Specification of [mem] *)

  Lemma mem_spec: forall s x, mem x s = true <-> In x s.
  Proof. unfold In. intuition. Qed.

  (** Additional lemmas for mem  *)

  Lemma mem_Leaf: forall x, mem x Leaf = false.
  Proof. destruct x; trivial. Qed.

  (** Specification of [empty] *)

  Lemma empty_spec : Empty empty.
  Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed.

  (** Specification of node  *)

  Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r).
  Proof.
    intros x l o r.
    case o; trivial.
    destruct l; trivial.
    destruct r; trivial.
    symmetry. destruct x.
      apply mem_Leaf.
      apply mem_Leaf.
      reflexivity.
  Qed.
  Local Opaque node.

  (** Specification of [is_empty] *)

  Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s.
  Proof.
    unfold Empty, In.
    induction s as [|l IHl o r IHr]; simpl.
      setoid_rewrite mem_Leaf. firstorder.
      rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr.
      destruct o; simpl; split.
        intuition discriminate.
        intro H. elim (H 1). reflexivity.
        intros H [a|a|]; apply H || intro; discriminate.
        intro H. split. split. reflexivity.
          intro a. apply (H a~0).
          intro a. apply (H a~1).
  Qed.

  (** Specification of [subset] *)

  Lemma subset_Leaf_s: forall s, Leaf [<=] s.
  Proof. intros s i Hi. apply empty_spec in Hi. elim Hi. Qed.

  Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'.
  Proof.
    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl.
      split; intros. apply subset_Leaf_s. reflexivity.

      split; intros. apply subset_Leaf_s. reflexivity.

      rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec.
      destruct o; simpl.
        split.
          intuition discriminate.
          intro H. elim (@empty_spec 1). apply H. reflexivity.
        split; intro H.
          destruct H as [[_ Hl] Hr].
          intros [i|i|] Hi.
            elim (Hr i Hi).
            elim (Hl i Hi).
            discriminate.
          split. split. reflexivity.
          unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption.
          unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption.

      rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear.
      destruct o; simpl.
       split; intro H.
         destruct H as [[Ho' Hl] Hr]. rewrite Ho'.
          intros i Hi. destruct i.
            apply (Hr i). assumption.
            apply (Hl i). assumption.
            assumption.
         split. split.
          destruct o'; trivial.
          specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity.
          intros i Hi. apply (H i~0). apply Hi.
          intros i Hi. apply (H i~1). apply Hi.
       split; intros.
         intros i Hi. destruct i; destruct H as [[H Hl] Hr].
           apply (Hr i). assumption.
           apply (Hl i). assumption.
            discriminate Hi.
         split. split. reflexivity.
           intros i Hi. apply (H i~0). apply Hi.
           intros i Hi. apply (H i~1). apply Hi.
  Qed.

  (** Specification of [equal] (via subset) *)

  Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
  Proof.
    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial.
      destruct o. reflexivity. rewrite andb_comm. reflexivity.
      rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true.
       rewrite 7andb_true_iff, eqb_true_iff.
      rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst.
       destruct o'; reflexivity.
       destruct o'; reflexivity.
       destruct o; auto. destruct o'; trivial.
  Qed.

  Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'.
  Proof.
    intros. rewrite equal_subset. rewrite andb_true_iff.
    rewrite 2subset_spec. unfold Equal, Subset. firstorder.
  Qed.

  Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
  Proof.
    unfold eq.
    intros. case_eq (equal s s'); intro H.
     left. apply equal_spec, H.
     right. rewrite <- equal_spec. congruence.
  Defined.

  (** (Specified) definition of [compare] *)

  Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' ->
    lex u v = CompOpp (lex u' v').
  Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed.

  Lemma compare_bool_inv: forall b b',
    compare_bool b b' = CompOpp (compare_bool b' b).
  Proof. intros [|] [|]; reflexivity. Qed.

  Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s).
  Proof.
    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial.
    unfold compare. case is_empty; reflexivity.
    unfold compare. case is_empty; reflexivity.
    simpl. rewrite compare_bool_inv.
     case compare_bool; simpl; trivial; apply lex_Opp; auto.
  Qed.

  Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
  Proof. intros u v; destruct u; intuition discriminate. Qed.

  Lemma compare_bool_Eq: forall b1 b2,
    compare_bool b1 b2 = Eq <-> eqb b1 b2 = true.
  Proof. intros [|] [|]; intuition discriminate. Qed.

  Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true.
  Proof.
    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r'].
     simpl. tauto.
     unfold compare, equal. case is_empty; intuition discriminate.
     unfold compare, equal. case is_empty; intuition discriminate.
     simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff.
     rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr.
     rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity.
  Qed.

  Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s.
  Proof.
    unfold lt. intros s s'. rewrite compare_inv.
     case compare; trivial; intros; discriminate.
  Qed.

  Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'.
  Proof.
    unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial.
  Qed.

  Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s').
  Proof.
    intros. case_eq (compare s s'); intro H; constructor.
    apply compare_eq, H.
    assumption.
    apply compare_gt, H.
  Qed.

  Section lt_spec.

  Inductive ct: comparison -> comparison -> comparison -> Prop :=
  | ct_xxx: forall x, ct x  x  x
  | ct_xex: forall x, ct x  Eq x
  | ct_exx: forall x, ct Eq x  x
  | ct_glx: forall x, ct Gt Lt x
  | ct_lgx: forall x, ct Lt Gt x.

  Lemma ct_cxe: forall x, ct (CompOpp x) x Eq.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xce: forall x, ct x (CompOpp x) Eq.
  Proof. destruct x; constructor. Qed.

  Lemma ct_lxl: forall x, ct Lt x Lt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_gxg: forall x, ct Gt x Gt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xll: forall x, ct x Lt Lt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xgg: forall x, ct x Gt Gt.
  Proof. destruct x; constructor. Qed.

  Local Hint Constructors ct: ct.
  Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct.
  Ltac ct := trivial with ct.

  Lemma ct_lex: forall u v w u' v' w',
    ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w').
  Proof.
    intros u v w u' v' w' H H'.
    inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct.
  Qed.

  Lemma ct_compare_bool:
    forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c).
  Proof.
    intros [|] [|] [|]; constructor.
  Qed.

  Lemma compare_x_Leaf: forall s,
    compare s Leaf = if is_empty s then Eq else Gt.
  Proof.
    intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity.
  Qed.

  Lemma compare_empty_x: forall a, is_empty a = true ->
    forall b, compare a b = if is_empty b then Eq else Lt.
  Proof.
    induction a as [|l IHl o r IHr]; trivial.
    destruct o. intro; discriminate.
    simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff.
    intros [Hl Hr].
    destruct b as [|l' [|] r']; simpl compare; trivial.
     rewrite Hl, Hr. trivial.
     rewrite (IHl Hl), (IHr Hr). simpl.
     case (is_empty l'); case (is_empty r'); trivial.
  Qed.

  Lemma compare_x_empty: forall a, is_empty a = true ->
    forall b, compare b a = if is_empty b then Eq else Gt.
  Proof.
    setoid_rewrite <- compare_x_Leaf.
    intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity.
  Qed.

  Lemma ct_compare:
    forall a b c, ct (compare a b) (compare b c) (compare a c).
  Proof.
    induction a as [|l IHl o r IHr]; intros s' s''.
     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct.
      rewrite compare_inv. ct.
      unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'.
       rewrite (compare_empty_x _ H'). ct.
       unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''.
        rewrite (compare_x_empty _ H''), H'. ct.
        ct.

     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r''].
      ct.
      unfold compare at 2. rewrite compare_x_Leaf.
      case_eq (is_empty (Node l o r)); intro H.
       rewrite (compare_empty_x _ H). ct.
       case_eq (is_empty (Node l'' o'' r'')); intro H''.
        rewrite (compare_x_empty _ H''), H. ct.
        ct.

      rewrite 2 compare_x_Leaf.
      case_eq (is_empty (Node l o r)); intro H.
       rewrite compare_inv, (compare_x_empty _ H). ct.
       case_eq (is_empty (Node l' o' r')); intro H'.
        rewrite (compare_x_empty _ H'), H. ct.
        ct.

      simpl compare. apply ct_lex. apply ct_compare_bool.
       apply ct_lex; trivial.
  Qed.

  End lt_spec.

  Instance lt_strorder : StrictOrder lt.
  Proof.
   unfold lt. split.
   intros x H.
   assert (compare x x = Eq).
    apply compare_equal, equal_spec. reflexivity.
   congruence.
   intros a b c. assert (H := ct_compare a b c).
    inversion_clear H; trivial; intros; discriminate.
  Qed.

  Local Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare.
  Proof.
   intros x x' Hx y y' Hy. subst y'.
   unfold eq in *. rewrite <- equal_spec, <- compare_equal in *.
   assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto.
  Qed.

  Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
  Proof.
   intros x x' Hx y y' Hy. rewrite Hx.
   rewrite compare_inv, Hy, <- compare_inv. reflexivity.
  Qed.

  Local Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
   intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition.
  Qed.

  (** Specification of [add] *)

  Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s.
  Proof.
    unfold In. intros s x y; revert x y s.
    induction x; intros [y|y|] [|l o r]; simpl mem;
    try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence.
  Qed.

  (** Specification of [remove] *)

  Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x.
  Proof.
    unfold In. intros s x y; revert x y s.
    induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node;
     simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf;
     intuition congruence.
  Qed.

  (** Specification of [singleton] *)

  Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x.
  Proof.
    unfold singleton. intros x y. rewrite add_spec. intuition.
    unfold In in *. rewrite mem_Leaf in *. discriminate.
  Qed.

  (** Specification of [union] *)

  Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'.
  Proof.
    unfold In. intros s s' x; revert x s s'.
    induction x; destruct s; destruct s'; simpl union; simpl mem;
      try (rewrite IHx; clear IHx); try intuition congruence.
      apply orb_true_iff.
  Qed.

  (** Specification of [inter] *)

  Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'.
  Proof.
    unfold In. intros s s' x; revert x s s'.
    induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node;
     simpl mem; try (rewrite IHx; clear IHx); try intuition congruence.
     apply andb_true_iff.
  Qed.

  (** Specification of [diff] *)

  Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'.
  Proof.
    unfold In. intros s s' x; revert x s s'.
    induction x; destruct s; destruct s' as [|l' o' r']; simpl diff;
     rewrite ?mem_node; simpl mem;
      try (rewrite IHx; clear IHx); try intuition congruence.
      rewrite andb_true_iff. destruct o'; intuition discriminate.
  Qed.

  (** Specification of [fold] *)

  Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A),
      fold f s i = fold_left (fun a e => f e a) (elements s) i.
  Proof.
    unfold fold, elements. intros s A i f. revert s i.
    set (f' := fun a e => f e a).
    assert (H: forall s i j acc,
      fold_left f' acc (xfold f s i j) =
      fold_left f' (xelements s j acc) i).

    induction s as [|l IHl o r IHr]; intros; trivial.
      destruct o; simpl xelements; simpl xfold.
        rewrite IHr, <- IHl. reflexivity.
        rewrite IHr. apply IHl.

    intros. exact (H s i 1 nil).
  Qed.

  (** Specification of [cardinal] *)

  Lemma cardinal_spec: forall s, cardinal s = length (elements s).
  Proof.
    unfold elements.
    assert (H: forall s j acc,
                (cardinal s + length acc)%nat = length (xelements s j acc)).

    induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b.
      rewrite <- IHl. simpl. rewrite <- IHr.
       rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity.
      rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity.

    intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity.
  Qed.

  (** Specification of [filter] *)

  Lemma xfilter_spec: forall f s x i,
    In x (xfilter f s i) <-> In x s /\ f (i@x) = true.
  Proof.
    intro f. unfold In.
    induction s as [|l IHl o r IHr]; intros x i; simpl xfilter.
     rewrite mem_Leaf. intuition discriminate.
     rewrite mem_node. destruct x; simpl.
       rewrite IHr. reflexivity.
       rewrite IHl. reflexivity.
       rewrite <- andb_lazy_alt. apply andb_true_iff.
  Qed.

  Lemma filter_spec: forall s x f, compat_bool E.eq f ->
    (In x (filter f s) <-> In x s /\ f x = true).
  Proof. intros. apply xfilter_spec. Qed.

  (** Specification of [for_all] *)

  Lemma xforall_spec: forall f s i,
    xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
  Proof.
    unfold For_all, In. intro f.
    induction s as [|l IHl o r IHr]; intros i; simpl.
     setoid_rewrite mem_Leaf. intuition discriminate.
     rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
     rewrite IHl, IHr. clear IHl IHr.
      split.
       intros [[Hi Hr] Hl] x. destruct x; simpl; intro H.
        apply Hr, H.
        apply Hl, H.
        rewrite H in Hi. assumption.
       intro H; intuition.
        specialize (H 1). destruct o. apply H. reflexivity. reflexivity.
        apply H. assumption.
        apply H. assumption.
  Qed.

  Lemma for_all_spec: forall s f, compat_bool E.eq f ->
    (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof. intros. apply xforall_spec. Qed.

  (** Specification of [exists] *)

  Lemma xexists_spec: forall f s i,
    xexists f s i = true <-> Exists (fun x => f (i@x) = true) s.
  Proof.
    unfold Exists, In. intro f.
    induction s as [|l IHl o r IHr]; intros i; simpl.
     setoid_rewrite mem_Leaf. firstorder.
     rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
     rewrite IHl, IHr. clear IHl IHr.
      split.
       intros [[Hi|[x Hr]]|[x Hl]].
        exists 1. exact Hi.
        exists x~1. exact Hr.
        exists x~0. exact Hl.
       intros [[x|x|] H]; eauto.
  Qed.

  Lemma exists_spec : forall s f, compat_bool E.eq f ->
    (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof. intros. apply xexists_spec. Qed.

  (** Specification of [partition] *)

  Lemma partition_filter : forall s f,
    partition f s = (filter f s, filter (fun x => negb (f x)) s).
  Proof.
    unfold partition, filter. intros s f. generalize 1 as j.
    induction s as [|l IHl o r IHr]; intro j.
      reflexivity.
      destruct o; simpl; rewrite IHl, IHr; reflexivity.
  Qed.

  Lemma partition_spec1 : forall s f, compat_bool E.eq f ->
      Equal (fst (partition f s)) (filter f s).
  Proof. intros. rewrite partition_filter. reflexivity. Qed.

  Lemma partition_spec2 : forall s f, compat_bool E.eq f ->
      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof. intros. rewrite partition_filter. reflexivity. Qed.

  (** Specification of [elements] *)

  Notation InL := (InA E.eq).

  Lemma xelements_spec: forall s j acc y,
    InL y (xelements s j acc)
    <->
    InL y acc \/ exists x, y=(j@x) /\ mem x s = true.
  Proof.
    induction s as [|l IHl o r IHr]; simpl.
      intros. split; intro H.
        left. assumption.
        destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_spec Hx').

      intros j acc y. case o.
        rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
          intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto.
            right. exists x~1. auto.
            right. exists x~0. auto.
          intros [H|[x [-> H]]].
            eauto.
            destruct x.
              left. right. right. exists x; auto.
              right. exists x; auto.
              left. left. reflexivity.

        rewrite IHl, IHr. clear IHl IHr. split.
          intros [[H|[x [-> H]]]|[x [-> H]]].
            eauto.
            right. exists x~1. auto.
            right. exists x~0. auto.
          intros [H|[x [-> H]]].
            eauto.
            destruct x.
              left. right.  exists x; auto.
              right. exists x; auto.
              discriminate.
  Qed.

  Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s.
  Proof.
   unfold elements. intros. rewrite xelements_spec.
   split; [ intros [A|(y & B & C)] | intros IN ].
   inversion A. simpl in *. congruence.
   right. exists x. auto.
  Qed.

  Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
  Proof. induction j; intros; simpl; auto. Qed.

  Lemma elements_spec2: forall s, sort E.lt (elements s).
  Proof.
    unfold elements.
    assert (H: forall s j acc,
      sort E.lt acc ->
      (forall x y, In x s ->  InL y acc -> E.lt (j@x) y) ->
      sort E.lt (xelements s j acc)).

    induction s as [|l IHl o r IHr]; simpl; trivial.
    intros j acc Hacc Hsacc. destruct o.
      apply IHl. constructor.
       apply IHr. apply Hacc.
       intros x y Hx Hy. apply Hsacc; assumption.
       case_eq (xelements r j~1 acc). constructor.
       intros z q H. constructor.
       assert (H': InL z (xelements r j~1 acc)).
        rewrite H. constructor. reflexivity.
       clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]].
         apply (Hsacc 1 z); trivial. reflexivity.
         simpl. apply lt_rev_append. exact I.
       intros x y Hx Hy. inversion_clear Hy.
         rewrite H. simpl. apply lt_rev_append. exact I.
         rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]].
           apply Hsacc; assumption.
           simpl. apply lt_rev_append. exact I.

      apply IHl. apply IHr. apply Hacc.
       intros x y Hx Hy. apply Hsacc; assumption.
       intros x y Hx Hy. rewrite xelements_spec in Hy.
        destruct Hy as [Hy|[z [-> Hy]]].
         apply Hsacc; assumption.
         simpl. apply lt_rev_append. exact I.

    intros. apply H. constructor.
      intros x y _ H'. inversion H'.
  Qed.

  Lemma elements_spec2w: forall s, NoDupA E.eq (elements s).
  Proof.
    intro. apply SortA_NoDupA with E.lt; auto with *.
    apply E.eq_equiv.
    apply elements_spec2.
  Qed.

  (** Specification of [choose] *)

  Lemma choose_spec1: forall s x, choose s = Some x -> In x s.
  Proof.
    induction s as [| l IHl o r IHr]; simpl.
      intros. discriminate.
      destruct o.
        intros x H. injection H; intros; subst. reflexivity.
        revert IHl. case choose.
          intros p Hp x H. injection H; intros; subst; clear H. apply Hp.
           reflexivity.
          intros _ x. revert IHr. case choose.
            intros p Hp H. injection H; intros; subst; clear H. apply Hp.
            reflexivity.
            intros. discriminate.
  Qed.

  Lemma choose_spec2: forall s, choose s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_spec.
      destruct o.
        discriminate.
        simpl in H. destruct (choose l).
          discriminate.
          destruct (choose r).
            discriminate.
            intros [a|a|].
              apply IHr. reflexivity.
              apply IHl. reflexivity.
              discriminate.
  Qed.

  Lemma choose_empty: forall s, is_empty s = true -> choose s = None.
  Proof.
    intros s Hs. case_eq (choose s); trivial.
    intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs.
     elim (Hs _ Hp).
  Qed.

  Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'.
  Proof.
    setoid_rewrite <- equal_spec.
    induction s as [|l IHl o r IHr].
      intros. symmetry. apply choose_empty. assumption.

      destruct s' as [|l' o' r'].
        generalize (Node l o r) as s. simpl. intros. apply choose_empty.
        rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H.
        assumption.

        simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff.
        intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity.
  Qed.

  Lemma choose_spec3: forall s s' x y,
    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
  Proof. intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed.

  (** Specification of [min_elt] *)

  Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s.
  Proof.
   unfold In.
   induction s as [| l IHl o r IHr]; simpl.
     intros. discriminate.
     intros x. destruct (min_elt l); intros.
       injection H. intros <-. apply IHl. reflexivity.
       destruct o; simpl.
         injection H. intros <-. reflexivity.
         destruct (min_elt r); simpl in *.
           injection H. intros <-. apply IHr. reflexivity.
           discriminate.
  Qed.

  Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_spec.
      intros [a|a|].
        apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial.
          case min_elt; intros; try discriminate. destruct o; discriminate.
        apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial.
         intro; discriminate.
        revert H. clear. simpl. case min_elt; intros; try discriminate.
         destruct o; discriminate.
  Qed.

  Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x.
  Proof.
    unfold In.
    induction s as [|l IHl o r IHr]; intros x y H H'.
      discriminate.
      simpl in H. case_eq (min_elt l).
        intros p Hp. rewrite Hp in H. injection H; intros <-.
        destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial.
        intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp.
        destruct o.
          injection H. intros <- Hl. clear H.
          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

          destruct (min_elt r).
            injection H. intros <-. clear H.
            destruct y as [z|z|].
              apply (IHr p z); trivial.
              elim (Hp _ H').
              discriminate.
            discriminate.
  Qed.

  (** Specification of [max_elt] *)

  Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s.
  Proof.
   unfold In.
   induction s as [| l IHl o r IHr]; simpl.
     intros. discriminate.
     intros x. destruct (max_elt r); intros.
       injection H. intros <-. apply IHr. reflexivity.
       destruct o; simpl.
         injection H. intros <-. reflexivity.
         destruct (max_elt l); simpl in *.
           injection H. intros <-. apply IHl. reflexivity.
           discriminate.
  Qed.

  Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_spec.
      intros [a|a|].
        apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial.
         intro; discriminate.
        apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial.
          case max_elt; intros; try discriminate. destruct o; discriminate.
        revert H. clear. simpl. case max_elt; intros; try discriminate.
         destruct o; discriminate.
  Qed.

  Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y.
  Proof.
    unfold In.
    induction s as [|l IHl o r IHr]; intros x y H H'.
      discriminate.
      simpl in H. case_eq (max_elt r).
        intros p Hp. rewrite Hp in H. injection H; intros <-.
        destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial.
        intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp.
        destruct o.
          injection H. intros <- Hl. clear H.
          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

          destruct (max_elt l).
            injection H. intros <-. clear H.
            destruct y as [z|z|].
              elim (Hp _ H').
              apply (IHl p z); trivial.
              discriminate.
            discriminate.
  Qed.

End PositiveSet.


Require Import String. Open Scope string_scope.

Definition var : Type := string.

Inductive cexp :=
  | CVal (n : nat)
  | CVar (x : var)
  | CApp (e0 e1 : cexp)
  | CLam (x : var) (e : cexp).

Inductive env :=
  | ENil
  | ECons (x : var) (v : cexp) (ρ ρ' : env).

Fixpoint lookup (ρ : env) (x : var) : option (cexp * env) :=
  match ρ with
  | ENil => None
  | ECons y v ρ ρ' => if (x =? y)%string then Some (v, ρ)
                      else lookup ρ' x
  end.

Inductive cont :=
  | KMt
  | KAr (e : cexp) (ρ : env) (k : cont)
  | KFn (v : cexp) (ρ : env) (k : cont). (* v is CLam *)

Definition state : Type := cexp * env * cont.

Reserved Notation "s --> s'" (at level 40).

Inductive step : state -> state -> Prop :=
  (* Variable lookup *)
  | SVar x ρ v ρ' k :
      lookup ρ x = Some (v, ρ') ->
      (CVar x, ρ, k) --> (v, ρ', k)
  (* Function application *)
  | SApp e0 e1 ρ k :
      (CApp e0 e1, ρ, k) --> (e0, ρ, KAr e1 ρ k)
  (* Function value *)
  | SFun v ρ e ρ' k : (* v is CLam *)
      (v, ρ, KAr e ρ' k) --> (e, ρ', KFn v ρ k)
  (* Argument value *)
  | SArg v ρ x e ρ' k : (* v is CLam *)
      (v, ρ, KFn (CLam x e) ρ' k) --> (e, ECons x v ρ ρ', k)
  where "s '-->' s'" := (step s s').

Reserved Notation "s1 -->* s2" (at level 40).

Inductive multistep : state -> state -> Prop :=
  | multistep_refl x :
      x -->* x
  | multistep_step x y z :
      x --> y ->
      y -->* z ->
      x -->* z
  where "s1 -->* s2" := (multistep s1 s2).

Definition inj (e : cexp) : state := (e, ENil, KMt).

(* (((λx.x λy.y) 42), ⊥, mt) |->> (42, ⊥, mt) *)
Goal
  (inj (CApp (CApp (CLam "x" (CVar "x")) (CLam "y" (CVar "y"))) (CVal 42)))
  -->*
  (inj (CVal 42)).
Proof. repeat econstructor. Qed.


Add LoadPath "somePath".

Require Export rel_cons_dec.

(*----------BES----------*)

Definition w_d(E:list block) := forall x:propVar, bnd E x <-> bnd_cnt E x=1.

Record BES : Set := makeBES {
  bes:> genBES;
  well_defined: w_d bes
}.

Fixpoint rhs_block (l:list booleanEquation)(x:propVar):propForm :=
match l with
| nil => var x
| cons (bEqn xc f) l' => if beq_nat xc x then f else rhs_block l' x
end.

Lemma bnd_block_dec : forall l:list booleanEquation, forall x:propVar,
{bnd_block l x} + {~bnd_block l x}.
Proof.
induction l;simpl;intros;auto.
destruct a as [y f];simpl in *.
destruct (eq_nat_decide x y).
rewrite (eq_nat_eq _ _ e) in *;auto.
destruct (IHl x);auto.
right;intro.
destruct H;auto.
apply n;apply eq_nat_is_eq;auto.
Qed.

Fixpoint rhs (E:BES)(x:propVar) : propForm :=
let fix helper (l:list block):propForm :=
match l with
| nil => bot
| bl::l' => if (bnd_block_dec bl x)
            then rhs_block bl x
            else helper l'
end in helper E.

Fixpoint bnd_block_number (e:list block)(x:propVar):=
match e with
| nil => 0
| bl::e' => if (bnd_block_dec bl x) then 0 else S(bnd_block_number e' x)
end.

Lemma bnd_dec : forall e:list block, forall x:propVar,
  {bnd e x} + {~bnd e x}.
Proof.
induction e;simpl in *;auto.

intros.
destruct (bnd_block_dec a x);auto.
destruct (IHe x);auto.
right;intro.
destruct H;auto.
Qed.

Definition rank (E:list block)(x:propVar) : nat := if (bnd_dec E x) then
match E with
| nil => 0
| bl::_ => if blockType bl
           then S(S(bnd_block_number E x))
           else S(bnd_block_number E x)
end
else 0.

Lemma eq_rank : forall e:list block, forall x y:propVar, rank e x=rank e y -> (bnd e x <-> bnd e y).
Proof.
induction e;simpl in *.
split;intro;auto.

unfold rank.
intros x y.
split;intro.
destruct (bnd_dec (a :: e) x).
destruct (bnd_dec (a :: e) y);auto.
exfalso.
destruct a.
simpl in H.
destruct blockType;inversion H.
exfalso.
apply n;simpl;auto.
destruct (bnd_dec (a :: e) x);auto.
destruct (bnd_dec (a::e) y);try contradiction.
destruct a.
simpl in H.
destruct blockType;inversion H.
Qed.


(** * Finite Modular Maps : Implementation for Positive Keys *)

(** Author : Pierre Letouzey (Université de Paris - INRIA),
    adapted from earlier works in Coq Standard Library, see README.md.
    Licence : LGPL 2.1, see file LICENSE. *)

From Coq Require Import Bool PeanoNat BinPos Orders OrdersEx OrdersLists.
From Tries.MMaps Require Import Utils Comparisons Interface.

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

(** This file is an adaptation to the [MMaps] 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 earlier [IntMap] library, except that no path
  compression is implemented, and that the current file is simple enough to be
  self-contained. *)

(** Reverses the positive [y] and concatenate it with [x] *)

Fixpoint rev_append (y x : positive) : positive :=
  match y with
    | 1 => x
    | y~1 => rev_append y x~1
    | y~0 => rev_append y x~0
  end.
Local Infix "@" := rev_append (at level 60).
Definition rev x := x@1.

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

Module PositiveMap <: S PositiveOrderedTypeBits.

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

  Definition key := positive : Type.

  Definition eq_key {A} := @ME.eqk A.
  Definition eq_key_elt {A} := @ME.eqke A.
  Definition lt_key {A} := @ME.ltk A.

  Instance eqk_equiv {A} : Equivalence (@eq_key A) := _.
  Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _.
  Instance ltk_strorder {A} : StrictOrder (@lt_key A) := _.

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

  Arguments Leaf {A}.

  Scheme tree_ind := Induction for tree Sort Prop.

  Definition t := tree.

  Definition empty {A} : t A := Leaf.

  Section A.
  Variable A:Type.

  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 : key) (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 : key) (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 : key) (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.

  Definition singleton x e := add x e Leaf.

  (** helper function to avoid creating empty trees that are not leaves *)

  Definition node (l : t A) (o: option A) (r : t A) : t A :=
    match o,l,r with
      | None,Leaf,Leaf => Leaf
      | _,_,_ => Node l o r
    end.

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

  (** [bindings] *)

  Fixpoint xbindings (m : t A) (i : positive) (a: list (key*A)) :=
    match m with
      | Leaf => a
      | Node l None r => xbindings l i~0 (xbindings r i~1 a)
      | Node l (Some e) r => xbindings l i~0 ((rev i,e) :: xbindings r i~1 a)
    end.

  Definition bindings (m : t A) := xbindings m 1 nil.

  (** [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.

  (** Specification proofs *)

  Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v.
  Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m.

  Lemma MapsTo_compat : Proper (E.eq==>eq==>eq==>iff) MapsTo.
  Proof.
   intros k k' Hk e e' He m m' Hm. red in Hk. now subst.
  Qed.

  Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m.
  Proof. reflexivity. Qed.

  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 mem_spec : forall m x, mem x m = true <-> In x m.
  Proof.
  unfold In, MapsTo; intros m x; rewrite mem_find.
  split.
  - destruct (find x m).
    exists a; auto.
    intros; discriminate.
  - destruct 1 as (e0,H0); rewrite H0; auto.
  Qed.

  Lemma gleaf : forall (i : key), find i Leaf = None.
  Proof. destruct i; simpl; auto. Qed.

  Theorem empty_spec:
    forall (i: key), find i empty = None.
  Proof. exact gleaf. Qed.

  Lemma is_empty_spec m :
   is_empty m = true <-> forall k, find k m = None.
  Proof.
  induction m; simpl.
  - intuition. apply empty_spec.
  - destruct o. split; try discriminate.
    intros H. now specialize (H xH).
    rewrite <- andb_lazy_alt, andb_true_iff, IHm1, IHm2.
    clear IHm1 IHm2.
    split.
    + intros (H1,H2) k. destruct k; simpl; auto.
    + intros H; split; intros k. apply (H (xO k)). apply (H (xI k)).
  Qed.

  Theorem add_spec1:
    forall (m: t A) (i: key) (x: A), find i (add i x m) = Some x.
  Proof.
    intros m i; revert m.
    induction i; destruct m; simpl; auto.
  Qed.

  Theorem add_spec2:
    forall (m: t A) (i j: key) (x: A),
    i <> j -> find j (add i x m) = find j m.
  Proof.
    intros m i j; revert m i.
    induction j; destruct i, m; simpl; intros;
     rewrite ?IHj, ?gleaf; auto; try congruence.
  Qed.

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

  Lemma gnode l o r i : find i (node l o r) = find i (Node l o r).
  Proof.
   destruct o,l,r; simpl; trivial.
   destruct i; simpl; now rewrite ?gleaf.
  Qed.

  Opaque node.

  Theorem remove_spec1:
    forall (m: t A)(i: key), find i (remove i m) = None.
  Proof.
    induction m; simpl.
    - intros; rewrite rleaf. apply gleaf.
    - destruct i; simpl remove; rewrite gnode; simpl; auto.
  Qed.

  Theorem remove_spec2:
    forall (m: t A)(i j: key),
    i <> j -> find j (remove i m) = find j m.
  Proof.
    induction m; simpl; intros.
    - now rewrite rleaf.
    - destruct i; simpl; rewrite gnode; destruct j; simpl; trivial;
      try apply IHm1; try apply IHm2; congruence.
  Qed.

  Local Notation InL := (InA eq_key_elt).

  Lemma xbindings_spec: forall m j acc k e,
    InL (k,e) (xbindings m j acc) <->
    InL (k,e) acc \/ exists x, k=(j@x) /\ find x m = Some e.
  Proof.
    induction m as [|l IHl o r IHr]; simpl.
    - intros. split; intro H.
      + now left.
      + destruct H as [H|[x [_ H]]]. assumption.
        now rewrite gleaf in H.
    - intros j acc k e. case o as [e'|];
      rewrite IHl, ?InA_cons, IHr; clear IHl IHr; split.
      + intros [[H|[H|H]]|H]; auto.
        * change (E.eq k (rev j) /\ e = e') in H. destruct H as (->,<-).
          right. now exists 1.
        * destruct H as (x,(->,H)). right. now exists x~1.
        * destruct H as (x,(->,H)). right. now exists x~0.
      + intros [H|H]; auto.
        destruct H as (x,(->,H)).
        destruct x; simpl in *.
        * left. right. right. now exists x.
        * right. now exists x.
        * left. left. injection H as ->. reflexivity.
      + intros [[H|H]|H]; auto.
        * destruct H as (x,(->,H)). right. now exists x~1.
        * destruct H as (x,(->,H)). right. now exists x~0.
      + intros [H|H]; auto.
        destruct H as (x,(->,H)).
        destruct x; simpl in *.
        * left. right. now exists x.
        * right. now exists x.
        * discriminate.
  Qed.

  Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
  Proof. induction j; intros; simpl; auto. Qed.

  Lemma xbindings_sort m j acc :
    sort lt_key acc ->
    (forall x p, In x m -> InL p acc -> E.lt (j@x) (fst p)) ->
    sort lt_key (xbindings m j acc).
  Proof.
    revert j acc.
    induction m as [|l IHl o r IHr]; simpl; trivial.
    intros j acc Hacc Hsacc. destruct o as [e|].
    - apply IHl;[constructor;[apply IHr; [apply Hacc|]|]|].
      + intros. now apply Hsacc.
      + case_eq (xbindings r j~1 acc); [constructor|].
        intros (z,e') q H. constructor.
        assert (H': InL (z,e') (xbindings r j~1 acc)).
        { rewrite H. now constructor. }
        clear H q. rewrite xbindings_spec in H'.
        destruct H' as [H'|H'].
        * apply (Hsacc 1 (z,e')); trivial. now exists e.
        * destruct H' as (x,(->,H)).
          red. simpl. now apply lt_rev_append.
      + intros x (y,e') Hx Hy. inversion_clear Hy.
        rewrite H. simpl. now apply lt_rev_append.
        rewrite xbindings_spec in H.
        destruct H as [H|H].
        * now apply Hsacc.
        * destruct H as (z,(->,H)). simpl.
          now apply lt_rev_append.
    - apply IHl; [apply IHr; [apply Hacc|]|].
      + intros. now apply Hsacc.
      + intros x (y,e') Hx H. rewrite xbindings_spec in H.
        destruct H as [H|H].
        * now apply Hsacc.
        * destruct H as (z,(->,H)). simpl.
          now apply lt_rev_append.
  Qed.

  Lemma bindings_spec1 m k e :
    InA eq_key_elt (k,e) (bindings m) <-> MapsTo k e m.
  Proof.
   unfold bindings, MapsTo. rewrite xbindings_spec.
   split; [ intros [H|(y & H & H')] | intros IN ].
   - inversion H.
   - simpl in *. now subst.
   - right. now exists k.
  Qed.

  Lemma bindings_spec2 m : sort lt_key (bindings m).
  Proof.
    unfold bindings.
    apply xbindings_sort. constructor. inversion 2.
  Qed.

  Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
  Proof.
    apply ME.Sort_NoDupA.
    apply bindings_spec2.
  Qed.

  (** Some complements about [bindings] that will be used
      in other correctness proofs below. *)

  Lemma xbindings_nil m p l :
    xbindings m p l = nil <-> is_empty m = true /\ l = nil.
  Proof.
  revert p l.
  induction m; simpl; intros; try easy.
  destruct o; now rewrite <- ?andb_lazy_alt, ?andb_true_iff, IHm1, ?IHm2.
  Qed.

  Lemma bindings_nil m : bindings m = nil <-> is_empty m = true.
  Proof.
  unfold bindings. now rewrite xbindings_nil.
  Qed.

  Definition fstmap (f:key->key) '(k, e) : key*A := (f k, e).

  Lemma xbindings_alt m j l :
   xbindings m j l = List.map (fstmap (rev_append j)) (bindings m) ++ l.
  Proof.
  revert j l.
  induction m; simpl; intros; auto.
  destruct o; unfold bindings; simpl;
   rewrite !IHm1, !IHm2, map_app, map_map, app_ass, app_nil_r; simpl;
   f_equal; try (apply map_ext; now intros (?,?)); f_equal.
  - f_equal. rewrite map_map. apply map_ext. now intros (?,?).
  - rewrite map_map. apply map_ext. now intros (?,?).
  Qed.

  Lemma bindings_node r l o :
   bindings (Node l o r) =
   (List.map (fstmap xO) (bindings l)) ++
   (match o with Some e => (1,e)::nil | None => nil end) ++
   (List.map (fstmap xI) (bindings r)).
  Proof.
  unfold bindings at 1. simpl.
  rewrite !xbindings_alt, !app_nil_r.
  destruct o; simpl; try f_equal.
  rewrite xbindings_alt; simpl. f_equal.
  Qed.

  (** [singleton] *)

  Theorem singleton_spec i x : bindings (singleton i x) = (i,x)::nil.
  Proof.
   unfold singleton.
   induction i; simpl; auto.
   - now rewrite bindings_node; simpl; rewrite IHi.
   - now rewrite bindings_node; simpl; rewrite IHi.
  Qed.

  (** [cardinal] *)

  Lemma xbindings_length m j acc :
    length (xbindings m j acc) = (cardinal m + length acc)%nat.
  Proof.
   revert j acc.
   induction m; simpl; trivial; intros.
   destruct o; simpl; rewrite IHm1; simpl; rewrite IHm2;
    now rewrite ?Nat.add_succ_r, Nat.add_assoc.
  Qed.

  Lemma cardinal_spec m : cardinal m = length (bindings m).
  Proof.
   unfold bindings. rewrite xbindings_length. simpl.
   symmetry. apply Nat.add_0_r.
  Qed.

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

  Variable B : Type.

  Section Mapi.

    Variable f : key -> option A -> option B.

    Fixpoint xmapi (m : t A) (i : key) : t B :=
       match m with
        | Leaf => Leaf
        | Node l o r => Node (xmapi l (i~0))
                             (f (rev i) o)
                             (xmapi r (i~1))
       end.

  End Mapi.

  Definition mapi (f : key -> A -> B) m :=
    xmapi (fun k => option_map (f k)) m 1.

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

  End A.

  Lemma xmapi_spec A B (f: key -> option A -> option B) (i : key) (m : t A) :
    (forall x, f x None = None) ->
    bindings (xmapi f m i) =
    mapfilter (fun '(k,e) => option_map (pair k) (f (i@k) (Some e)))
              (bindings m).
  Proof.
  revert i.
  induction m; simpl; intros. easy.
  rewrite !bindings_node, !mapfilter_app. f_equal.
  - rewrite IHm1; auto. rewrite map_mapfilter, mapfilter_map; f_equiv.
    intros a a' <-. destruct a. simpl. now destruct f.
  - f_equal.
    + destruct o; simpl.
      * unfold rev. now destruct f.
      * now rewrite H.
    + rewrite IHm2; auto. rewrite map_mapfilter, mapfilter_map; f_equiv.
      intros a a' <-. destruct a. simpl. now destruct f.
  Qed.

  Lemma mapi_spec A B (f:key -> A -> B) (m : t A) :
    bindings (mapi f m) =
     List.map (fun '(k,e) => (k, f k e)) (bindings m).
  Proof.
  unfold mapi. rewrite xmapi_spec; simpl; auto.
  rewrite map_as_mapfilter. f_equiv. now intros (k,e) ? <-.
  Qed.

  Lemma map_spec A B (f:A -> B)(m : t A) :
    bindings (map f m) =
     List.map (fun '(k,e) => (k, f e)) (bindings m).
  Proof.
  unfold map. now rewrite mapi_spec.
  Qed.

  Lemma xgmapi:
    forall (A B: Type) (f: key -> option A -> option B) (i j : key) (m: t A),
      (forall k, f k None = None) ->
      find i (xmapi f m j) = f (j@i) (find i m).
  Proof.
  induction i; intros; destruct m; simpl; rewrite ?IHi; auto.
  Qed.

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

  Fixpoint xmerge (m1 : t A)(m2 : t B)(i:positive) : t C :=
    match m1 with
    | Leaf => xmapi (fun k => f k None) m2 i
    | Node l1 o1 r1 =>
        match m2 with
        | Leaf => xmapi (fun k o => f k o None) m1 i
        | Node l2 o2 r2 =>
          Node (xmerge l1 l2 (i~0))
               (f (rev i) o1 o2)
               (xmerge r1 r2 (i~1))
        end
    end.

  Lemma xgmerge: forall (i j: key)(m1:t A)(m2: t B),
      (forall i, f i None None = None) ->
      find i (xmerge m1 m2 j) = f (j@i) (find i m1) (find i m2).
  Proof.
    induction i; intros; destruct m1; destruct m2; simpl; auto;
    rewrite ?xgmapi, ?IHi; simpl; auto.
  Qed.

  End merge.

  Definition merge {A B C}(f:key->option A->option B->option C) m1 m2 :=
   xmerge
     (fun k o1 o2 => match o1,o2 with
       | None,None => None
       | _, _ => f k o1 o2
      end)
     m1 m2 xH.

  Lemma merge_spec1 {A B C}(f:key->option A->option B->option C) :
    forall m m' x,
    In x m \/ In x m' ->
    exists y, E.eq y x /\
     find x (merge f m m') = f y (find x m) (find x m').
  Proof.
  intros. exists x. split. reflexivity.
  unfold merge.
  rewrite xgmerge; simpl; auto.
  rewrite <- 2 mem_spec, 2 mem_find in H.
  destruct (find x m); simpl; auto.
  destruct (find x m'); simpl; auto. intuition discriminate.
  Qed.

  Lemma merge_spec2 {A B C}(f:key->option A->option B->option C) :
    forall m m' x, In x (merge f m m') -> In x m \/ In x m'.
  Proof.
  intros.
  rewrite <-mem_spec, mem_find in H.
  unfold merge in H.
  rewrite xgmerge in H; simpl; auto.
  rewrite <- 2 mem_spec, 2 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 : key -> A -> B -> B.

    (** the additional argument, [i], records the current path, in
       reverse order (this should be more efficient: we reverse this argument
       only at present nodes only, rather than at each node of the tree).
       we also use this convention in all functions below
     *)

    Fixpoint xfold (m : t A) (v : B) (i : key) :=
      match m with
        | Leaf => v
        | Node l (Some x) r =>
          xfold r (f (rev i) x (xfold l v i~0)) i~1
        | Node l None r =>
          xfold r (xfold l v i~0) i~1
      end.
    Definition fold m i := xfold m i 1.

  End Fold.

  Lemma fold_spec :
    forall {A}(m:t A){B}(i : B) (f : key -> A -> B -> B),
    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
  Proof.
    unfold fold, bindings. intros A m B i f. revert m i.
    set (f' := fun a p => f (fst p) (snd p) a).
    assert (H: forall m i j acc,
      fold_left f' acc (xfold f m i j) =
      fold_left f' (xbindings m j acc) i).
    { induction m as [|l IHl o r IHr]; intros; trivial.
      destruct o; simpl; now rewrite IHr, <- IHl. }
    intros. exact (H m i 1 nil).
  Qed.

  Definition equal_opt (A:Type)(cmp : A -> A -> bool) o1 o2 : bool :=
    match o1, o2 with
    | None, None => true
    | Some v1, Some v2 => cmp v1 v2
    | _, _ => false
    end.

  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 =>
        equal_opt cmp o1 o2 &&& equal cmp l1 l2 &&& equal cmp r1 r2
    end.

  Definition Equal A (m m':t A) := forall y, find y m = find y m'.
  Definition Eqdom A (m m':t A) := forall k, In k m <-> In k m'.
  Definition Equiv A (R:A->A->Prop) m m' :=
    Eqdom m m' /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> R 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 as (E,_); simpl. red in E.
    apply is_empty_spec; intros k.
    destruct (find k m') eqn:F; trivial.
    assert (H : In k m') by now exists a.
    rewrite <- E in H.
    destruct H as (x,H). red in H. now rewrite gleaf in H.
  - (* m = Node *)
    destruct m'.
    + (* m' = Leaf *)
      destruct 1 as (E,_); simpl. red in E.
      destruct o.
      * assert (H : In xH (@Leaf A)).
        { rewrite <- E. now exists a. }
        destruct H as (e,H). now red in H.
      * apply andb_true_intro; split; apply is_empty_spec; intros k.
        destruct (find k m1) eqn:F; trivial.
        assert (H : In (xO k) (@Leaf A)).
        { rewrite <- E. exists a; auto. }
        destruct H as (x,H). red in H. now rewrite gleaf in H.
        destruct (find k m2) eqn:F; trivial.
        assert (H : In (xI k) (@Leaf A)).
        { rewrite <- E. exists a; auto. }
        destruct H as (x,H). red in H. now rewrite gleaf in H.
    + (* 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.
  rewrite is_empty_spec in H.
  intros (e,H'). red in H'. now rewrite H in H'.
  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.
  rewrite is_empty_spec in H1.
  now rewrite H1 in H.
  rewrite is_empty_spec in H0.
  now rewrite H0 in 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. unfold Eqdom in *.
  split; intros. red.
  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. unfold Eqdom in *.
  split; intros. red.
  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.

  Lemma equal_spec : forall (A:Type)(cmp:A->A->bool)(m m':t A),
    equal cmp m m' = true <-> Equivb cmp m m'.
  Proof.
    split. apply equal_2. apply equal_1.
  Qed.

  (** Note: For once, the [compare] below is not a mere adaptation
      of the one of [MSetPositive]. Doing so would lead to a [compare]
      function which is indeed a comparison (ie refl sym trans), but
      different from [list_compare ... (bindings ...) (bindings ...)],
      hence not satisfying the required [Interface.S] specification. *)

  Section Compare.
  Variable A : Type.
  Variable cmp : A -> A -> comparison.

  Definition is_empty2 A (o:option A) (r:t A) :=
   match o with None => is_empty r | _ => false end.

  Fixpoint ecompare (m1 m2: t A) : (comparison * flag) :=
   match m1, m2 with
   | Leaf, _ => if is_empty m2 then (Eq,EOL) else (Lt,EOL)
   | _, Leaf => if is_empty m1 then (Eq,EOL) else (Gt,EOL)
   | Node l1 o1 r1, Node l2 o2 r2 =>
     match ecompare l1 l2 with
     | (Eq,_) =>
       match o1, o2 with
       | None, None => ecompare r1 r2
       | Some d1, Some d2 => elex (cmp d1 d2) (ecompare r1 r2)
       | None, Some _ => if is_empty r1 then (Lt,EOL) else (Gt,Early)
       | Some _, None => if is_empty r2 then (Gt,EOL) else (Lt,Early)
       end
     | (c,Early) => (c,Early)
     | (Lt,EOL) => if is_empty2 o1 r1 then (Lt,EOL) else (Gt,Early)
     | (Gt,EOL) => if is_empty2 o2 r2 then (Gt,EOL) else (Lt,Early)
     end
   end.

  Definition compare (m1 m2: t A) := fst (ecompare m1 m2).

  Local Notation Lcmp := (list_compare (pair_compare E.compare cmp)).
  Local Notation eLcmp := (list_ecompare (pair_compare E.compare cmp)).

  Lemma eLcmp_fstmap l1 l2 f :
   (forall k k', E.compare (f k) (f k') = E.compare k k') ->
   eLcmp (List.map (fstmap f) l1) (List.map (fstmap f) l2) = eLcmp l1 l2.
  Proof.
  revert l2.
  induction l1 as [|(x1,d1) l1 IH]; destruct l2 as [|(x2,d2) l2];
   intros E; simpl; auto.
  rewrite E. case E.compare_spec; try easy. unfold E.eq. intros <-.
  destruct (cmp d1 d2); auto.
  Qed.

  Lemma ecompare_spec m1 m2 :
   ecompare m1 m2 = eLcmp (bindings m1) (bindings m2).
  Proof.
  revert m2.
  induction m1 as [|l1 IHl1 o1 r1 IHr1]; intros m2.
  - simpl. generalize (bindings_nil m2).
    destruct bindings, is_empty; simpl; intuition easy.
  - generalize (bindings_nil (Node l1 o1 r1)).
    destruct m2 as [|l2 o2 r2].
    + cbn - [is_empty bindings].
      destruct (bindings (Node l1 o1 r1)), is_empty; intuition easy.
    + simpl.
      intros _.
      rewrite !bindings_node.
      rewrite IHl1, ?IHr1; clear IHl1 IHr1.
      rewrite list_ecompare_app.
      * rewrite eLcmp_fstmap by auto.
        destruct (eLcmp (bindings l1) (bindings l2)) as ([ ],b).
        { destruct o1 as [d1| ], o2 as [d2| ]; simpl.
          - destruct (cmp d1 d2) eqn:Eo; auto.
            rewrite eLcmp_fstmap; auto.
          - generalize (bindings_nil r2).
            destruct is_empty, (bindings r2); simpl; intuition; try easy.
            now destruct p.
          - generalize (bindings_nil r1).
            destruct is_empty, (bindings r1); simpl; intuition; try easy.
            now destruct p.
          - rewrite eLcmp_fstmap; auto. }
        { destruct b; auto.
          destruct o1; simpl; auto.
          generalize (bindings_nil r1).
          destruct bindings, is_empty; simpl; intuition easy. }
        { destruct b; auto.
          destruct o2; simpl; auto.
          generalize (bindings_nil r2).
          destruct bindings, is_empty; simpl; intuition easy. }
      * intros (x,d) (y,d').
        rewrite !in_app_iff, !in_map_iff.
        intros ((k,e) & [= <- <-] & _) [P|((k',e') & [= <- <-] & _)];
          simpl; auto.
        destruct o1; try easy. simpl in P.
        now destruct P as [[= <- <-]|[ ]].
      * intros (x,d) (y,d').
        rewrite !in_app_iff, !in_map_iff.
        intros ((k,e) & [= <- <-] & _) [P|((k',e') & [= <- <-] & _)];
          simpl; auto.
        destruct o2; try easy. simpl in P.
        now destruct P as [[= <- <-]|[ ]].
  Qed.

  Lemma compare_spec m1 m2 :
   compare m1 m2 = Lcmp (bindings m1) (bindings m2).
  Proof.
  unfold compare. rewrite <- list_ecompare_fst. f_equal.
  apply ecompare_spec.
  Qed.

  End Compare.

  Definition option_filter A (f:key->A->bool) k (o:option A) :=
    match o with
    | Some a => if f k a then o else None
    | None => o
    end.

  Definition filter A (f:key->A->bool) m := xmapi (option_filter f) m 1.
  Definition partition A (f:key->A->bool) m :=
    (filter f m, filter (fun k e => negb (f k e)) m).

  Fixpoint xforall A (f:key->A->bool) m j :=
    match m with
    | Leaf => true
    | Node l None r => xforall f l (j~0) &&& xforall f r (j~1)
    | Node l (Some e) r =>
      f (rev j) e &&& xforall f l (j~0) &&& xforall f r (j~1)
    end.

  Definition for_all A (f:key->A->bool) m := xforall f m 1.

  Fixpoint xexists A (f:key->A->bool) m j :=
    match m with
    | Leaf => false
    | Node l None r => xexists f l (j~0) ||| xexists f r (j~1)
    | Node l (Some e) r =>
      f (rev j) e ||| xexists f l (j~0) ||| xexists f r (j~1)
    end.

  Definition exists_ A (f:key->A->bool) m := xexists f m 1.

  Lemma filter_spec A (f:key->A->bool) m :
   bindings (filter f m) = List.filter (fun '(k,e) => f k e) (bindings m).
  Proof.
  unfold filter. rewrite xmapi_spec; simpl; auto.
  rewrite filter_as_mapfilter. f_equiv. intros (k,e) ? <-.
  now destruct f.
  Qed.

  Lemma partition_spec A (f:key->A->bool) m :
   prodmap (@bindings _) (partition f m) =
    List.partition (fun '(k,e) => f k e) (bindings m).
  Proof.
  unfold partition, prodmap. rewrite partition_filter. f_equiv.
  apply filter_spec.
  rewrite filter_spec. f_equiv. now intros (k,e) ? <-.
  Qed.

  Lemma xforall_spec A (f:key->A->bool) m i :
   xforall f m i = List.forallb (fun '(k,e) => f (i@k) e) (bindings m).
  Proof.
  revert i.
  induction m; simpl; intros; auto.
  rewrite bindings_node, !forallb_app, IHm1, IHm2.
  destruct o; simpl.
  - unfold rev. destruct f; simpl.
    + rewrite <- andb_lazy_alt.
      f_equal; rewrite forallb_map; f_equiv; now intros (k,e) ? <-.
    + now rewrite andb_false_r.
  - rewrite <- andb_lazy_alt.
    f_equal; rewrite forallb_map; f_equiv; now intros (k,e) ? <-.
  Qed.

  Lemma for_all_spec A (f:key->A->bool) m :
   for_all f m = List.forallb (fun '(k,e) => f k e) (bindings m).
  Proof.
  apply xforall_spec.
  Qed.

  Lemma xexists_spec A (f:key->A->bool) m i :
   xexists f m i = List.existsb (fun '(k,e) => f (i@k) e) (bindings m).
  Proof.
  revert i.
  induction m; simpl; intros; auto.
  rewrite bindings_node, !existsb_app, IHm1, IHm2.
  destruct o; simpl.
  - unfold rev. destruct f; simpl.
    + now rewrite orb_true_r.
    + rewrite <- orb_lazy_alt.
      f_equal; rewrite existsb_map; f_equiv; now intros (k,e) ? <-.
  - rewrite <- orb_lazy_alt.
    f_equal; rewrite existsb_map; f_equiv; now intros (k,e) ? <-.
  Qed.

  Lemma exists_spec A (f:key->A->bool) m :
   exists_ f m = List.existsb (fun '(k,e) => f k e) (bindings m).
  Proof.
  apply xexists_spec.
  Qed.

End PositiveMap.

(** Here come some additional 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 {A} i j x (m: t A) :
    find i (add j x m) = if E.eq_dec i j then Some x else find i m.
  Proof.
    destruct (E.eq_dec i j) as [->|];
    [ apply add_spec1 | apply add_spec2; auto ].
  Qed.

   (* Not derivable from the Map interface *)
  Theorem gsident {A} i (m:t A) v :
    find i m = Some v -> add i v m = m.
  Proof.
    revert m.
    induction i; destruct m; simpl in *; try congruence.
    - intro H; now rewrite (IHi m2 H).
    - intro H; now rewrite (IHi m1 H).
  Qed.

  Lemma xmapi_ext {A B}(f g: key -> option A -> option B) :
    (forall k (o : option A), f k o = g k o) ->
    forall m i, xmapi f m i = xmapi g m i.
  Proof.
    induction m; intros; simpl; auto. now f_equal.
  Qed.

  Theorem xmerge_commut{A B C}
    (f: key -> option A -> option B -> option C)
    (g: key -> option B -> option A -> option C) :
    (forall k o1 o2, f k o1 o2 = g k o2 o1) ->
    forall m1 m2 i, xmerge f m1 m2 i = xmerge g m2 m1 i.
  Proof.
    intros E.
    induction m1; destruct m2; intros i; simpl; trivial; f_equal;
    try apply IHm1_1; try apply IHm1_2; try apply xmapi_ext;
    intros; apply E.
  Qed.

  Theorem merge_commut{A B C}
    (f: key -> option A -> option B -> option C)
    (g: key -> option B -> option A -> option C) :
    (forall k o1 o2, f k o1 o2 = g k o2 o1) ->
    forall m1 m2, merge f m1 m2 = merge g m2 m1.
  Proof.
    intros E m1 m2.
    unfold merge. apply xmerge_commut.
    intros k [x1|] [x2|]; trivial.
  Qed.

  Lemma Equal_node_iff A (l r l' r' : t A) o o' :
   Equal (Node l o r) (Node l' o' r') <->
    Equal l l' /\ o = o' /\ Equal r r'.
  Proof.
  split.
  - intros E. repeat split.
    + intros k. apply (E (k~0)).
    + apply (E 1).
    + intros k. apply (E (k~1)).
  - intros (El & <- & Er) [ | | ]; simpl; auto.
  Qed.

  (** For normal maps (i.e. ones where empty parts are exactly Leaf),
      we can prove that Equal is the same than Logic.eq *)

  Fixpoint Normal {A} (m : t A) :=
   match m with
   | Leaf => True
   | Node l o r => Normal l /\ Normal r /\ is_empty m = false
   end.

  Lemma Normal_Equal_eq A (m m' : t A) :
    Normal m -> Normal m' -> Equal m m' -> m = m'.
  Proof.
  revert m'.
  induction m as [|l IHl o r IHr]; destruct m' as [|l' o' r'];
   cbn - [is_empty]; auto.
  - intros _ (Nl' & Nr' & EY) E.
    rewrite <- not_true_iff_false in EY. destruct EY.
    apply is_empty_spec. intros k. now rewrite <- (E k), gleaf.
  - intros (Nl & Nr & EY) _ E.
    rewrite <- not_true_iff_false in EY. destruct EY.
    apply is_empty_spec. intros k. now rewrite (E k), gleaf.
  - intros (Nl & Nr & EY) (Nl' & Nr' & EY') E.
    rewrite Equal_node_iff in E. f_equal; intuition.
  Qed.

End PositiveMapAdditionalFacts.