Require Import FMapInterface.
Require Import List.
Require Import SetoidList.
Require Import Omega.
Require Program.Tactics.
Require Program.Wf.

(** * Fixpoint for non-cyclic chains of lookups in a map. *)

(* First define some results for SetoidList style lists. *)
Section SetoidListExt.
Set Implicit Arguments.

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

Lemma inclA_nil : forall l:list A, inclA eqA l nil -> l = nil.
Proof.
  induction l.
    reflexivity.

    intro inc.
    absurd (InA eqA a nil).
      intro notin.
      inversion notin.

      apply inc.
      apply InA_cons_hd.
      reflexivity.
Qed.

Lemma inclA_cons (l l':list A) (a:A) : inclA eqA (a::l) l' -> inclA eqA l l'.
Proof.
  intros inc a' a'in.
  apply inc.
  simpl.
  right.
  assumption.
Qed.

Lemma inclA_cons_1 (l l':list A) (a:A) : ~ InA eqA a l -> inclA eqA l (a::l') -> inclA eqA l l'.
Proof.
  intros anotinl inc a' a'in.
  pose (a'in' := inc a' a'in).
  clearbody a'in'.
  inversion a'in' as [x y aa'|x y a'inl'].
    subst x y.
    apply (InA_eqA (l:=l) eqA_equiv aa') in a'in.
    contradiction.

    assumption.
Qed.

Lemma inclA_remove (l l':list A) (a:A) : inclA eqA l l' -> inclA eqA (removeA eqA_dec a l) l'.
Proof.
  intros inc a' a'in.
  apply inc.
  induction l.
    simpl in *.
    assumption.

    simpl (removeA eqA_dec a (a0 :: l)) in *.
    destruct (eqA_dec a a0) as [aa0|].
      apply InA_cons_tl.
      apply IHl; auto.
      apply inclA_cons with (a:=a0).
      assumption.

      inversion a'in as [x y aeqa'|x y a'in']; subst x y.
        apply InA_cons_hd; assumption.

        apply InA_cons_tl.
        apply IHl.
          apply inclA_cons with (a:=a0).
          assumption.

          assumption.
Qed.

Lemma inclA_discard (l l':list A) (a:A) : inclA eqA l (a::l') -> inclA eqA (removeA eqA_dec a l) l'.
Proof.
  intros inc a' a'in.
  induction l.
    inversion a'in.

    simpl in *.
    destruct (eqA_dec a a0).
      apply IHl.
        apply inclA_cons with (a:=a0).
        assumption.

        assumption.

      inversion a'in as [x y a'a0|x y]; subst x y.
        pose (a'ina0l := inc a' (InA_cons_hd (eqA:=eqA) (x:=a') (y:=a0) l a'a0)).
        inversion a'ina0l as [x y eq0|x y]; subst x y.
          contradict n.
          transitivity a'; auto.
          symmetry; assumption.

          assumption.

        apply IHl.
          apply inclA_cons with (a:=a0).
          assumption.

          assumption.
Qed.

Lemma notinA_remove (l:list A) (a a':A) : ~ InA eqA a l -> ~ InA eqA a (removeA eqA_dec a' l).
Proof.
  intros.
  induction l.
    simpl.
    auto.

    simpl.
    destruct (eqA_dec a' a0).
      apply IHl.
      intro inl.
      destruct H.
      apply InA_cons_tl.
      assumption.

      intro nottrue.
      inversion nottrue as [x y aeqk|x y kinrl]; subst x y.
        destruct H.
        left.
        assumption.

        apply IHl.
        intro inl.
        destruct H; right; assumption.
        assumption.
Qed.

End SetoidListExt.

(* Now define the recursion module based on some finite map. *)

Module ChainRecurse (M : S).

Module KeyFacts := OrderedType.OrderedTypeFacts M.E.
(* Get rid of some of the excess arguments. *)
Lemma InA_eq : forall l x y, M.E.eq x y -> InA M.E.eq x l -> InA M.E.eq y l.
Proof.
  apply InA_eqA.
  apply KeyFacts.eq_equiv.
Qed.
Implicit Arguments InA_eq [l x y].

Section Recursion.

(* First we need the type of objects in the map. *)
Variable elt:Type.

(* Define the termination measure and lemmata. *)
Definition keys (m:M.t elt) : list M.key :=
  map (fst (A:=M.key) (B:=elt)) (M.elements m).

Definition eltsleft (m:M.t elt) (l:list M.key) : nat :=
  List.length (keys m) - List.length l.

Lemma length_remove_1 (l:list M.key) (k:M.key) :
  ~ InA M.E.eq k l -> length l = length (removeA KeyFacts.eq_dec k l).
Proof.
  induction l.
    reflexivity.

    intros notin.
    simpl.
    destruct (KeyFacts.eq_dec k a).
      destruct notin.
      left.
      assumption.

      simpl.
      f_equal.
      apply IHl.
      intro.
      destruct notin.
      right.
      assumption.
Qed.

Lemma length_remove (l:list M.key) (k:M.key) :
  NoDupA M.E.eq l -> InA M.E.eq k l ->
  length l = S (length (removeA KeyFacts.eq_dec k l)).
Proof.
  induction l.
    intros _ kin.
    inversion kin.

    intros nodup kin.
    inversion kin as [x y kaeq|x y kinl]; subst x y.
      simpl.
      f_equal.
      destruct (KeyFacts.eq_dec k a).
        apply length_remove_1.
        inversion nodup.
        subst.
        intro knotinl.
        apply (InA_eq (l:=l) kaeq) in knotinl.
        contradiction.

        destruct n.
        assumption.

      inversion nodup.
      subst.
      simpl.
      destruct (KeyFacts.eq_dec k a).
        apply (InA_eq (l:=l) e) in kinl.
        contradiction.

        f_equal.
        simpl.
        apply IHl; assumption.
Qed.

Lemma nodup_remove (l:list M.key) (k:M.key) : NoDupA M.E.eq l -> NoDupA M.E.eq (removeA KeyFacts.eq_dec k l).
Proof.
  intros.
  induction l.
    simpl.
    assumption.

    simpl.
    destruct (KeyFacts.eq_dec k a).
      apply IHl.
      inversion H.
      subst.
      assumption.

      inversion H.
      subst.
      apply NoDupA_cons.
        apply notinA_remove.
        assumption.

        apply IHl.
        assumption.
Qed.

Lemma incl_length (l:list M.key) : forall l':list M.key, NoDupA M.E.eq l' -> inclA M.E.eq l' l -> length l' <= length l.
Proof.
  induction l; intros l' nodup inc.
    apply inclA_nil in inc. 2: apply KeyFacts.eq_equiv.
    subst l'.
    simpl.
    apply Le.le_O_n.

    destruct (InA_dec KeyFacts.eq_dec a l').
      rewrite (length_remove nodup i) in *.
      simpl.
      apply Le.le_n_S.
      apply IHl.
        apply nodup_remove.
        assumption.

        apply (inclA_discard KeyFacts.eq_dec KeyFacts.eq_equiv).
        assumption.

    simpl.
    apply Le.le_trans with (m:=length l); [|apply Le.le_n_Sn].
    apply IHl.
      assumption.

      apply inclA_cons_1 with (a:=a); auto.
      apply KeyFacts.eq_equiv.
Qed.

Lemma incl_length1 (l:list M.key) : forall l':list M.key, forall k:M.key, InA M.E.eq k l -> ~ InA M.E.eq k l' -> NoDupA M.E.eq l' -> inclA M.E.eq l' l -> length l' < length l.
Proof.
  induction l;
  intros l' k kinl knotinl' nodup incl.
    inversion kinl.

    inversion kinl; subst.
      simpl.
      apply Lt.le_lt_n_Sm.
      apply inclA_cons_1 in incl; eauto using KeyFacts.eq_equiv.
        apply incl_length; assumption.

        intro badeq.
        apply M.E.eq_sym in H0.
        apply (InA_eq (l:=l') H0) in badeq.
        contradiction.

      simpl.
      apply Lt.le_lt_trans with (m:=S (length (removeA KeyFacts.eq_dec a l'))).
        destruct (InA_dec KeyFacts.eq_dec a l').
          rewrite <- length_remove.
            apply Le.le_refl.

            assumption.

            assumption.

          rewrite <- length_remove_1.
            apply Le.le_n_Sn.
            assumption.

        apply Lt.lt_n_S.
        apply IHl with (k:=k).
          assumption.

          apply notinA_remove.
          assumption.

          apply nodup_remove.
          assumption.

          apply inclA_discard with (a:=a); eauto using KeyFacts.eq_equiv.
Qed.

Lemma minus_lt : forall m n:nat, n < m -> m - S n < m - n.
Proof.
  clear.
  intros.
  omega.
Qed.

(* The fixed point itself. *)

(* Now we need the map, the dependent type of the result and the step function. *)
Variable m : M.t elt.
Variable T : M.key -> Type.
Variable err_cycle : forall k:M.key, T k.
Variable err_notfound : forall k:M.key, T k.
Variable f:(forall k:M.key, T k) -> forall k:M.key, {e:elt | M.find k m = Some e} -> T k.

(* There's something odd going on with Program here.  I think it's a little
   broken when the recursive call returns a function, so use the explicit
   version to work around it. *)

Program Fixpoint fix_aux (l:list M.key | inclA M.E.eq l (keys m) /\ NoDupA M.E.eq l) {measure (eltsleft m l)}
 : forall k:M.key, T k := fun k =>
  match InA_dec KeyFacts.eq_dec k l with
    | left _ => err_cycle k
    | right _ =>
      let l' := k::l in
        match M.find k m with
          | None => err_notfound k
          | Some v => f (@fix_aux l' _) v
        end
  end.
Next Obligation.
split.
  (* The incl invariant *)
  intros x inkl.
  inversion inkl as [y z xeq|y z xin]; subst y z.
    apply sym_eq in Heq_anonymous.
    apply M.find_2 in Heq_anonymous.
    apply M.elements_1 in Heq_anonymous.
    unfold keys.
    destruct (proj1 (InA_alt (M.eq_key_elt (elt:=elt)) (k,v) (M.elements m)) Heq_anonymous) as [[k'' v''] [[keq'' veq''] in'']].
    simpl in keq'', veq''.
    subst v''.
    apply (M.E.eq_trans (z:=k'') xeq) in keq''.
    eapply InA_eq.
      apply M.E.eq_sym.
      apply keq''.
    apply In_InA.
      apply KeyFacts.eq_equiv.
    apply (proj2 (in_map_iff (fst (A:=M.key) (B:=elt)) (M.elements m) k'')).
    exists (k'',v).
    split.
      reflexivity.

      assumption.

    apply i.
    assumption.

  (* The nodup invariant *)
  apply NoDupA_cons.
    clear - wildcard'.
    induction l.
      auto.

      assumption.

    apply n.
Qed.
Next Obligation.
  (* Termination via reducing measure. *)
  unfold eltsleft.
  simpl.
  apply minus_lt.
  apply incl_length1 with (k:=k).
    apply sym_eq in Heq_anonymous.
    apply M.find_2 in Heq_anonymous.
    apply M.elements_1 in Heq_anonymous.
    destruct (proj1 (InA_alt (M.eq_key_elt (elt:=elt)) (k,v) (M.elements m)) Heq_anonymous) as [[k'' v''] [eq xvin]].
    destruct eq as [keq veq].
    simpl in *.
    subst v''.
    unfold keys.
    eapply InA_eq.
      apply M.E.eq_sym.
      apply keq.
    eapply In_InA.
      apply KeyFacts.eq_equiv.
    apply (proj2 (in_map_iff (fst (A:=M.key) (B:=elt)) (M.elements m) k'')).
    exists (k'',v).
    split.
      reflexivity.

      assumption.

    assumption.

    assumption.

    assumption.
Qed.

Program Definition cfix (k:M.key) : T k := fix_aux nil k.
Next Obligation.
  split.
    intros k' k'in.
    inversion k'in.

    apply NoDupA_nil.
Qed.

End Recursion.

End ChainRecurse.


(** * 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.
    License: LGPL-2.1-only, see file LICENSE. *)

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

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

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

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

  #[export] Instance eqk_equiv {A} : Equivalence (@eq_key A) := _.
  #[export] Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _.
  #[export] 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.


(** BEGIN HIDE **)
(*** Boilerplate code, to be able to use bigop style iterated
     sums and products on natural numbers. ***)

Hint Resolve Rle_refl.
Hint Resolve Rlt_0_1.
Hint Resolve Rle_0_1.
Hint Resolve Rlt_0_2.
Hint Resolve R1_neq_R0.

Lemma RplusA : associative Rplus.
Proof. now intros x y z; rewrite Rplus_assoc. Qed.

Lemma Rplus0r : left_id 0 Rplus.
Proof. exact Rplus_0_l. Qed.

Lemma Rplusr0 : right_id 0 Rplus.
Proof. exact Rplus_0_r. Qed.

Lemma RplusC : commutative Rplus.
Proof. exact Rplus_comm. Qed.

Canonical Rplus_monoid := Monoid.Law RplusA Rplus0r Rplusr0.
Canonical Rplus_comoid := Monoid.ComLaw RplusC.

Lemma RmultA : associative Rmult.
Proof. now intros x y z; rewrite Rmult_assoc. Qed.

Lemma Rmult1r : left_id 1 Rmult.

Proof. exact Rmult_1_l. Qed.

Lemma Rmultr1 : right_id 1 Rmult.
Proof. exact Rmult_1_r. Qed.

Lemma RmultC : commutative Rmult.

Proof. exact Rmult_comm. Qed.

Lemma Rmult0r : left_zero 0 Rmult.
Proof. exact Rmult_0_l. Qed.

Lemma Rmultr0 : right_zero 0 Rmult.
Proof. exact Rmult_0_r. Qed.

Lemma RmultDl : left_distributive Rmult Rplus.
Proof. exact Rmult_plus_distr_r. Qed.

Lemma RmultDr : right_distributive Rmult Rplus.
Proof. exact Rmult_plus_distr_l. Qed.

Canonical Rmult_monoid := Monoid.Law RmultA Rmult1r Rmultr1.
Canonical Rmult_comoid := Monoid.ComLaw RmultC.
Canonical Rmult_muloid := Monoid.MulLaw Rmult0r Rmultr0.
Canonical Rplus_addoid := Monoid.AddLaw RmultDl RmultDr.

(* Some convention LaTeX style notations for the common
  iterated operations on real numbers. *)
Local Notation "+%R" := Rplus (at level 0, only parsing).
Notation "\sum_ ( i <- r | P ) F" :=
  (\big[+%R/0%R]_(i <- r | P%B) F%R) : R_scope.
Notation "\sum_ ( i <- r ) F" :=
  (\big[+%R/0%R]_(i <- r) F%R) : R_scope.
Notation "\sum_ ( m <= i < n | P ) F" :=
  (\big[+%R/0%R]_(m <= i < n | P%B) F%R) : R_scope.
Notation "\sum_ ( m <= i < n ) F" :=
  (\big[+%R/0%R]_(m <= i < n) F%R) : R_scope.
Notation "\sum_ ( i | P ) F" :=
  (\big[+%R/0%R]_(i | P%B) F%R) : R_scope.
Notation "\sum_ i F" :=
  (\big[+%R/0%R]_i F%R) : R_scope.
Notation "\sum_ ( i : t | P ) F" :=
  (\big[+%R/0%R]_(i : t | P%B) F%R) (only parsing) : R_scope.
Notation "\sum_ ( i : t ) F" :=
  (\big[+%R/0%R]_(i : t) F%R) (only parsing) : R_scope.
Notation "\sum_ ( i < n | P ) F" :=
  (\big[+%R/0%R]_(i < n | P%B) F%R) : R_scope.
Notation "\sum_ ( i < n ) F" :=
  (\big[+%R/0%R]_(i < n) F%R) : R_scope.
Notation "\sum_ ( i 'in' A | P ) F" :=
  (\big[+%R/0%R]_(i in A | P%B) F%R) : R_scope.
Notation "\sum_ ( i 'in' A ) F" :=
  (\big[+%R/0%R]_(i in A) F%R) : R_scope.

Local Notation "*%R" := Rmult (at level 0, only parsing).
Notation "\prod_ ( i <- r | P ) F" :=
  (\big[*%R/1%R]_(i <- r | P%B) F%R) : R_scope.
Notation "\prod_ ( i <- r ) F" :=
  (\big[*%R/1%R]_(i <- r) F%R) : R_scope.
Notation "\prod_ ( m <= i < n | P ) F" :=
  (\big[*%R/1%R]_(m <= i < n | P%B) F%R) : R_scope.
Notation "\prod_ ( m <= i < n ) F" :=
  (\big[*%R/1%R]_(m <= i < n) F%R) : R_scope.
Notation "\prod_ ( i | P ) F" :=
  (\big[*%R/1%R]_(i | P%B) F%R) : R_scope.
Notation "\prod_ i F" :=
  (\big[*%R/1%R]_i F%R) : R_scope.
Notation "\prod_ ( i : t | P ) F" :=
  (\big[*%R/1%R]_(i : t | P%B) F%R) (only parsing) : R_scope.
Notation "\prod_ ( i : t ) F" :=
  (\big[*%R/1%R]_(i : t) F%R) (only parsing) : R_scope.
Notation "\prod_ ( i < n | P ) F" :=
  (\big[*%R/1%R]_(i < n | P%B) F%R) : R_scope.
Notation "\prod_ ( i < n ) F" :=
  (\big[*%R/1%R]_(i < n) F%R) : R_scope.
Notation "\prod_ ( i 'in' A | P ) F" :=
  (\big[*%R/1%R]_(i in A | P%B) F%R) : R_scope.
Notation "\prod_ ( i 'in' A ) F" :=
  (\big[*%R/1%R]_(i in A) F%R) : R_scope.

(* A couple of few missing things in the libraries we loaded... *)

Lemma INRpow n m : INR (n ^ m) = INR n ^ m.
Proof.
elim: m => [|m ihm]; first by rewrite expn0 pow_O.
by rewrite expnS mult_INR ihm.
Qed.

Lemma Rdiv_ge_1 r1 r2 : 0 < r1 -> (r1 <= r2 <-> 1 <= r2 / r1).
Proof.
intros H.
pattern r1 at 1.
rewrite <- (Rmult_1_l r1).
split ; apply Rle_div_r ; apply H.
Qed.

(*** A version of  INR that allows for easier proofs of 2 < 8, making
    (INR n) and ('n' : R) convertible for every numeral 'n'. ***)

(* Three base cases are needed in order to avoid spurious
    multiplications by one at the tail. *)

Fixpoint pos2R (p : positive) : R :=
  match p with
    |xH => 1
    |xO xH => 2
    |xI xH => 3
    |xO p => 2 * (pos2R p)
    |xI p => 1 + 2 * (pos2R p)
  end.

Arguments pos2R : simpl never.
Arguments IZR : simpl never.

Lemma pos2RE p : pos2R p = IZR (Zpos p).
Proof.
elim: p=> [p ihp | p ihp |] //.
- case: p ihp => [p | p |] ihp.
  + rewrite -[LHS]/(1 + 2 * pos2R p~1) ihp -[RHS]/(INR (Pos.to_nat p~1~1)).
    by rewrite Pos2Nat.inj_xI S_INR mult_INR Rplus_comm.
  + rewrite -[LHS]/(1 + 2 * pos2R p~0) ihp -[RHS]/(INR (Pos.to_nat p~0~1)).
    by rewrite Pos2Nat.inj_xI S_INR mult_INR Rplus_comm.
  + by rewrite -[RHS]/(INR (Pos.to_nat 3)) Pos2Nat.inj_xI S_INR Rplus_comm.
- case: p ihp => [p | p |] ihp.
  + rewrite -[LHS]/(2 * pos2R p~1) ihp -[RHS]/(INR (Pos.to_nat p~1~0)).
    by rewrite Pos2Nat.inj_xO mult_INR.
  + rewrite -[LHS]/(2 * pos2R p~0) ihp -[RHS]/(INR (Pos.to_nat p~0~0)).
    by rewrite Pos2Nat.inj_xO mult_INR.
  + by rewrite -[RHS]/(INR (Pos.to_nat 2)) Pos2Nat.inj_xO.
Qed.

Definition Z2R (z : Z) :=
  match z with
    |Z0 => R0
    |Zpos p => pos2R p
    |Zneg p => - pos2R p
  end.

Lemma Z2RE z : Z2R z = IZR z.
Proof. by case: z => // p /=; rewrite pos2RE. Qed.

Definition nat2R (n : nat) := Z2R (Z_of_nat n).

Lemma nat2RE n : nat2R n = INR n.
Proof. by rewrite INR_IZR_INZ -Z2RE. Qed.

Lemma S_nat2R n : nat2R n.+1 = INR n + 1.
Proof. rewrite nat2RE; exact: S_INR. Qed.

Lemma lt_0_nat2R n : (0 < n)%nat -> 0 < nat2R n.
Proof.
move/ltP=> lt0n; rewrite nat2RE. exact: lt_0_INR.
Qed.

Lemma le_0_nat2R n : (0 <= n)%nat -> 0 <= nat2R n.
Proof.
move/leP=> lt0n; rewrite nat2RE -[0]/(INR 0); exact: le_INR.
Qed.

Lemma le_nat2R n m : (n <= m)%nat -> nat2R n <= nat2R m.
Proof. move/leP=>h; rewrite !nat2RE; exact: le_INR. Qed.

Lemma lt_nat2R n m : (n < m)%nat -> nat2R n < nat2R m.
Proof. move/ltP=>h; rewrite !nat2RE; exact: lt_INR. Qed.

Lemma nat2R_le n m : nat2R n <= nat2R m -> (n <= m)%nat.
Proof. rewrite !nat2RE => lenm; apply/leP; exact: INR_le. Qed.

Lemma nat2R_lt n m : nat2R n < nat2R m -> (n < m)%nat.
Proof. rewrite !nat2RE => lenm; apply/leP; exact: INR_lt. Qed.

Lemma mult_nat2R n m : nat2R (n * m)%nat = nat2R n * nat2R m.
Proof. by rewrite !nat2RE mult_INR. Qed.

Lemma plus_nat2R n m : nat2R (n + m)%nat = nat2R n + nat2R m.
Proof. by rewrite !nat2RE plus_INR. Qed.

Lemma nat2Rpow n m : nat2R (n ^ m) = nat2R n ^ m.
Proof. by rewrite !nat2RE INRpow. Qed.

Lemma nat2R_inj : injective nat2R.
Proof. by move=> i j; rewrite !nat2RE; apply: INR_eq. Qed.

Lemma not_0_nat2R n : n != 0%nat -> nat2R n <> 0.
Proof. move/eqP; rewrite nat2RE. exact: not_0_INR. Qed.

Lemma Rinv_nat2R_gt0 n : (n > 0)%nat -> 0 < / nat2R n.
Proof.
by move=> lt0n; apply: Rinv_0_lt_compat; apply: lt_0_nat2R.
Qed.

Lemma Rinv_nat2R_ge0 n : (n > 0)%nat -> 0 <= / nat2R n.
Proof.
by move=> lt0n; apply: Rlt_le; apply: Rinv_nat2R_gt0.
Qed.

(*** Definition of log, the logarithm in basis 2, and elementary properties
   thereof. We prove here only what is needed in the proof, but basically
   we should be able to prove everything that is available on ln, mutatis
   mutandis. ***)

Definition log (x : R) := ln x / ln 2.

Arguments log : simpl never.

Lemma Rlt_0_ln2 : 0 < ln 2.
Proof. now rewrite <- ln_1; apply ln_increasing; prove_sup. Qed.

Hint Resolve Rlt_0_ln2.

(* For the purpose of Hint Resolve... *)
Lemma Rgt_ln2_0 : ln 2 > 0.
Proof. exact Rlt_0_ln2. Qed.

Hint Resolve Rgt_ln2_0.

Lemma ln2_neq_0 : ln 2 <> 0.
Proof. apply Rgt_not_eq; exact Rlt_0_ln2. Qed.

Hint Resolve ln2_neq_0.

Lemma ln_gt_0 x : x > 1 -> ln x > 0.
Proof. intros lt0x; rewrite -ln_1; exact: ln_increasing. Qed.

Lemma Rmult_log_ln2 x : log x * ln 2 = ln x.
Proof.
now unfold log, Rdiv; rewrite Rmult_assoc Rinv_l ?Rmult_1_r.
Qed.

Lemma log_pow (n : nat) : log (2 ^ n) = nat2R n.
Proof.
unfold log. rewrite ln_pow;last by prove_sup.
by rewrite /Rdiv Rmult_assoc Rinv_r // Rmult_1_r nat2RE.
Qed.

Lemma log_le  (x y : R) : 0 < x -> x <= y -> log x <= log y.
Proof.
intros lt0x lexy. apply Rle_div_l; trivial. rewrite Rmult_log_ln2.
now apply ln_le.
Qed.

Lemma log_div (x y : R) : 0 < x -> 0 < y -> log (x / y) = log x - log y.
Proof.
intros lt0x lt0y. unfold log, Rdiv.
now rewrite -Rmult_minus_distr_r ln_div.
Qed.

Lemma log_increasing (x y : R) : 0 < x -> x < y -> log x < log y.
Proof.
intros lt0x lt0y.  apply Rlt_div_l; trivial. rewrite Rmult_log_ln2.
now apply ln_increasing.
Qed.

Lemma log_increasingW (x y : R) : 0 < x -> x <= y -> log x <= log y.
Proof.
move=> lt_0_x /Rle_lt_or_eq_dec [|->] //.
by move/(log_increasing _ _ lt_0_x)/Rlt_le.
Qed.

Lemma log_1 : log 1 = 0.
Proof. now unfold log; rewrite ln_1; unfold Rdiv; rewrite Rmult_0_l. Qed.

Lemma log_2 : log 2 = 1.
Proof. by unfold log; apply Rinv_r. Qed.

Lemma log_gt_0 x : x > 1 -> log x > 0.
Proof. intros lt0x; rewrite -log_1; exact: log_increasing. Qed.

Lemma log_ge_0 x : 1 <= x -> 0 <= log x.
Proof. by rewrite -log_1; apply: log_increasingW. Qed.

Lemma log_gt_1 x : x > 2 -> log x > 1.
Proof.
rewrite -[X in log x > X]log_2; apply: log_increasing.
by apply: (lt_0_INR 2%nat); apply/ltP.
Qed.

Lemma log_ge_1 x : 2 <= x -> 1 <= log x.
Proof.
rewrite -[X in X <= log x]log_2; apply: log_increasingW.
by apply: (lt_0_INR 2%nat); apply/ltP.
Qed.

Lemma log_lt_inv  (x y : R) : 0 < x -> 0 < y -> log x < log y -> x < y.
Proof.
move=> lt0x lt0y.
have /Rmult_lt_reg_r h: 0 < / ln 2 by apply: Rinv_0_lt_compat.
by move/h; move/ln_lt_inv; apply.
Qed.

Lemma log_inv (x y : R) : 0 < x -> 0 < y -> log x = log y -> x = y.
Proof.
move=> lt_0_x lt_0_y elog.
have /Rmult_eq_reg_r h: / ln 2 <> 0 by apply: Rinv_neq_0_compat.
move/h: elog; exact: ln_inv.
Qed.

Lemma log_le_inv  (x y : R) : 0 < x -> 0 < y -> log x <= log y -> x <= y.
Proof.
move=> lt0x lt0y; case/Rle_lt_or_eq_dec; last by move/(log_inv _ _ lt0x lt0y)->.
by move/(log_lt_inv _ _ lt0x lt0y); apply: Rlt_le.
Qed.

Lemma log_mult (x y : R) : 0 < x -> 0 < y -> log (x * y) = log x + log y.
Proof. by move=> lt0x lt0y; rewrite /log -Rmult_plus_distr_r -ln_mult. Qed.

Lemma log_Rinv (x : R) : 0 < x -> log (/ x) = - log x.
Proof.
by move=> lt0x; rewrite /log ln_Rinv // -Ropp_mult_distr_l_reverse.
Qed.

(*** Some auxiliary lemmas about iterated products and sume of reals.
     we cannot use the MC theory of ordered structures because R cannot
     be equipped as such with this structure (we miss the choice axiom.
     We just prove what is needed below... to be hidden or to be used as
     exercises in order to use the bigop library. ***)

Arguments INR : simpl never.

Lemma prodR_gt0 (I : eqType) r (P : pred I) (E : I -> R) :
  (forall i, i \in r -> P i -> 0 < E i) -> 0 < \prod_(i <- r | P i) E i.
Proof.
elim: r => [|x r ihr] lt0E; first by rewrite big_nil; exact: Rlt_0_1.
have {ihr} ihr : 0 < \prod_(i <- r | P i) E i.
  by apply: ihr=> i ri; apply: lt0E; rewrite in_cons ri orbT.
rewrite big_cons; case: ifP=> // Px; apply: Rmult_lt_0_compat => //.
by apply: lt0E; rewrite // in_cons eqxx.
Qed.

Lemma leR_sum (I : eqType) (r : seq I) (P : pred I) (F G : I -> R) :
    (forall i, i \in r -> P i -> F i <= G i) ->
  \sum_(i <- r | P i) F i <= \sum_(i <- r | P i) G i.
Proof.
elim: r => [|x r ihr] hle; first by rewrite !big_nil.
have {ihr} ihr : \sum_(i <- r | P i) F i <= \sum_(i <- r | P i) G i.
  by apply: ihr => i ri; apply: hle; rewrite in_cons ri orbT.
rewrite !big_cons; case: ifP=> Px //; apply: Rplus_le_compat => //.
by apply: hle; rewrite // in_cons eqxx.
Qed.

Lemma sumR_ge0 (I : eqType) (r : seq I) (P : pred I) (G : I -> R) :
    (forall i, i \in r -> P i -> 0 <= G i) ->
    0 <= \sum_(i <- r | P i) G i.
Proof. by move/leR_sum; rewrite big1_eq. Qed.

Lemma sumRln (I : eqType) (r : seq I) P (F : I -> R) :
  (forall i, i \in r -> F i > 0) ->
  \sum_(i <- r | P i) ln (F i) = ln (\prod_(i <- r | P i) F i).
Proof.
elim: r=> [|x r ihr] hpos; first by rewrite !big_nil ln_1.
have {ihr} ihr : \sum_(i <- r | P i) ln (F i) = ln (\prod_(i <- r | P i) F i).
  by rewrite ihr // => i ri; apply: hpos; rewrite in_cons ri orbT.
rewrite !big_cons; case: ifP=> Px //.
rewrite ln_mult ?ihr //; first by apply: hpos; rewrite in_cons eqxx.
by apply: prodR_gt0=> i ri _; apply: hpos; rewrite in_cons ri orbT.
Qed.

Lemma sumRlog (I : eqType) (r : seq I) P (F : I -> R) :
  (forall i, i \in r -> F i > 0) ->
  \sum_(i <- r | P i) log (F i) = log (\prod_(i <- r | P i) F i).
Proof. by move=> hp; rewrite [RHS]/log -sumRln // [RHS]big_distrl. Qed.

(*** Second part of the proof, i.e. lemma 2:
     we majorize sums of logs of consecutive primes
     between n.+1 and 2n ***)

Lemma le_sum_log_ps n :
  \sum_(n.+1 <= p < (n.*2).+1 | prime p) log (nat2R p) <= 2 * nat2R n.
Proof.
case: (posnP n)=> [-> | lt0n].
  by rewrite double0 big_nil Rmult_0_r.
have /sumRlog -> i : i \in index_iota n.+1 (n.*2).+1 -> nat2R i > 0.
  rewrite mem_iota; case/andP=> ltin _; apply: lt_0_nat2R; exact: ltn_trans ltin.
have -> : 2 * nat2R n = log (nat2R (2 ^ (n.*2))).
  by rewrite nat2Rpow log_pow -mul2n mult_nat2R.
rewrite -(big_morph _ mult_nat2R (refl_equal (nat2R 1%N))) => /=.
apply: log_increasingW.
  by apply: lt_0_nat2R; apply: prodn_cond_gt0=> i /prime_gt0.
apply: le_nat2R; apply: leq_trans (corollary1 n) _.
exact: lebinpow2.
Qed.

(*** Third part of the proof, i.e. lemma 3:
     we majorize sums of logs of consecutive inverses primes
     between n.+1 and 2n, with a factor of log n. ***)

Lemma le_sum_inv n : (1 < n)%nat ->
  \sum_(n.+1 <= p < (n.*2).+1 | prime p) / (nat2R p) <= 2 / log (nat2R n).
Proof.
move=> lt1n. set dom := index_iota n.+1 (n.*2).+1.
have domP i : i \in dom -> ((n.+1 <= i) && (i <= n.*2))%nat.
  by rewrite /dom mem_iota subnKC // ltnS.
have nat2Rn_gt0 : nat2R n > 0.
  by apply: lt_0_nat2R; apply: ltn_trans lt1n.
have nat2Rn_neq0 : nat2R n <> 0 by apply: Rgt_not_eq.
have logn_gt0 : log (nat2R n) > 0.
  by apply: log_gt_0; apply: (lt_nat2R 1).
have logn_neq0 : log (nat2R n) <> 0 by apply: Rgt_not_eq.
have /leR_sum t1 : forall i,  i \in dom -> prime i ->
                  / (nat2R i) <= log (nat2R i) * / ((nat2R n) * (log (nat2R n))).
  move=> i /domP /andP [ltni ltiS2n] pi.
  have nat2Ri_neq0 : nat2R i > 0 by apply: lt_0_nat2R; apply: prime_gt0.
  rewrite [X in _ <= _ * X]Rinv_mult_distr // [/ nat2R n * _]Rmult_comm.
  rewrite -Rmult_assoc -[X in X <= _]Rmult_1_l; apply: Rmult_le_compat => //.
  - by apply: Rlt_le; apply: Rinv_0_lt_compat.
  - apply -> Rdiv_ge_1 => //; apply: log_increasingW => //; apply: Rlt_le.
    by apply: lt_nat2R.
  - apply: Rle_Rinv => //; apply: Rlt_le; exact: lt_nat2R.
apply: Rle_trans t1 _; rewrite -big_distrl /=; apply <- Rle_div_l; last first.
  by apply: Rmult_gt_0_compat.
set RHS := (X in _ <= X); suff -> : RHS = 2 * nat2R n by apply: le_sum_log_ps.
rewrite {}/RHS [nat2R n * _]Rmult_comm Rmult_assoc; congr (2 * _).
by rewrite -Rmult_assoc Rinv_l // Rmult_1_l.
Qed.

(* END HIDE *)


Require Import Coq.Logic.Classical_Pred_Type.
Require Import Relations. (* reflexive, transitive *)
Require Import RelationsExtra.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module MeetSemiLattice.

Definition axiom A (le : relation A) (meet : A -> A -> A) :=
  forall x y : A, le x (meet x y) /\ le y (meet x y).

Record mixin_of (A : Type) := Mixin {
  inhab : A;
  le : relation A;
  meet : A -> A -> A;
  _ : preorder A le;
  _ : axiom le meet;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.
  Record type : Type := Pack { sort : Type; class : class_of sort }.
End ClassDef.

Module Exports.
  Coercion sort : type >-> Sortclass.
  Notation meetSemiLatticeType := type.
  Notation MeetSemiLatticeMixin := Mixin.
  Notation MeetSemiLatticeType T m := (@Pack T m).
End Exports.

End MeetSemiLattice.
Export MeetSemiLattice.Exports.

Definition inhab T := MeetSemiLattice.inhab (MeetSemiLattice.class T).
Definition le T := MeetSemiLattice.le (MeetSemiLattice.class T).
Definition meet T := MeetSemiLattice.meet (MeetSemiLattice.class T).
Arguments inhab : clear implicits.
Arguments le : clear implicits.
Arguments meet : clear implicits.

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

Section Laws.

Variable A : meetSemiLatticeType.

Lemma meetSemiLattice_preorder :
  preorder A (le A).
Proof. destruct A as [? M]. destruct M. eauto. Qed.

Lemma meetSemiLatticeP :
  forall x y, le A x (meet A x y) /\ le A y (meet A x y).
Proof. destruct A as [? M]. destruct M. eauto. Qed.

End Laws.

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

Section ProductMeetSemiLattice.

Variable A : meetSemiLatticeType.
Variable B : meetSemiLatticeType.

Definition product_meet (p1 : A * B) (p2 : A * B) :=
  let (a1, b1) := p1 in
  let (a2, b2) := p2 in
  (meet A a1 a2, meet B b1 b2).

Lemma product_meetP :
  forall x y,
    product (le A) (le B) x (product_meet x y) /\
    product (le A) (le B) y (product_meet x y).
Proof.
  intros [x1 y1] [x2 y2]. unfold product. simpl.
  repeat split; apply meetSemiLatticeP.
Qed.

Definition product_meetSemiLatticeMixin :=
  MeetSemiLatticeMixin
    (inhab A, inhab B)
    (product_preorder (meetSemiLattice_preorder A) (meetSemiLattice_preorder B))
    product_meetP.

Definition product_meetSemiLatticeType :=
  MeetSemiLatticeType (A * B) product_meetSemiLatticeMixin.

End ProductMeetSemiLattice.


(******************************************************************************)
(** * Lemmas about lists and permutations *)
(******************************************************************************)

Require Import HahnBase HahnSets.
Require Import Arith Lia Setoid Morphisms Sorted.
Require Import IndefiniteDescription.
Require Export List Permutation.

Set Implicit Arguments.

(** This file contains a number of basic definitions and lemmas about lists
    that are missing from the standard library, and a few properties of
    classical logic. *)

(** Very basic lemmas *)
(******************************************************************************)

Definition appA := app_ass.
Definition length_nil A : length (@nil A) = 0 := eq_refl.
Definition length_cons A (a: A) l : length (a :: l) = S (length l) := eq_refl.
Definition length_app := app_length.
Definition length_rev := rev_length.
Definition length_map := map_length.
Definition length_combine := combine_length.
Definition length_prod := prod_length.
Definition length_firstn := firstn_length.
Definition length_seq := seq_length.
Definition length_repeat := repeat_length.

Hint Rewrite length_nil length_cons length_app length_rev length_map : calc_length.
Hint Rewrite length_combine length_prod length_firstn length_seq  : calc_length.
Hint Rewrite length_repeat : calc_length.

Lemma in_cons_iff A (a b : A) l : In b (a :: l) <-> a = b \/ In b l.
Proof. done. Qed.

Lemma in_app_l A (a : A) l l' : In a l -> In a (l ++ l').
Proof. eauto using in_or_app. Qed.

Lemma in_app_r A (a : A) l l' : In a l' -> In a (l ++ l').
Proof. eauto using in_or_app. Qed.

Global Hint Resolve in_app_l in_app_r in_cons in_eq : hahn.

Lemma In_split2 :
  forall A (x: A) l (IN: In x l),
  exists l1 l2, l = l1 ++ x :: l2 /\ ~ In x l1.
Proof.
  induction l; ins; desf; [by eexists nil; ins; eauto|].
  destruct (classic (a = x)); desf; [by eexists nil; ins; eauto|].
  apply IHl in IN; desf; eexists (_ :: _); repeat eexists; ins; intro; desf.
Qed.

Lemma app_nth A n l l' (d : A) :
  nth n (l ++ l') d =
  if le_lt_dec (length l) n then nth (n - length l) l' d else nth n l d.
Proof.
  desf; eauto using app_nth1, app_nth2.
Qed.

Definition nth_app := app_nth.

Lemma app_comm_cons' A (a : A) l l' :
  l ++ a :: l' = (l ++ a :: nil) ++ l'.
Proof.
  by rewrite <- app_assoc.
Qed.

Lemma destruct_end A (l : list A) :
  l = nil \/ exists l' a, l = l' ++ a :: nil.
Proof.
  induction l; ins; desf; eauto.
  - right; exists nil; ins; eauto.
  - right; eexists (_ :: _); ins; eauto.
Qed.

Lemma rev_induction A (P : list A -> Prop) :
  P nil -> (forall a l, P l -> P (l ++ a :: nil)) -> forall l, P l.
Proof.
  ins; rewrite <- rev_involutive.
  induction (rev l); ins; eauto.
Qed.

(* Destructing equalities between lists *)
(******************************************************************************)

Lemma snoc_eq_snoc A (a a' : A) l l' :
  l ++ a :: nil = l' ++ a' :: nil <-> l = l' /\ a = a'.
Proof.
  by split; ins; desf; apply app_inj_tail.
Qed.

Lemma app_eq_nil A (l1 l2 : list A) :
  l1 ++ l2 = nil <-> l1 = nil /\ l2 = nil.
Proof.
  destruct l1; split; ins; desf.
Qed.

Lemma app_eq_cons A (l1 l2 : list A) a l :
  l1 ++ l2 = a :: l <->
  (l1 = nil /\ l2 = a :: l) \/ (exists l1', l1 = a :: l1' /\ l1' ++ l2 = l).
Proof.
  split; ins; desf.
  destruct l1; ins; desf; eauto.
Qed.

Lemma app_eq_singleton A (l1 l2 : list A) a :
  l1 ++ l2 = a :: nil <->
  (l1 = nil /\ l2 = a :: nil) \/ (l1 = a :: nil /\ l2 = nil).
Proof.
  rewrite app_eq_cons; split; ins; desf; eauto.
  rewrite app_eq_nil in *; desf; eauto.
Qed.

Lemma app_eq_snoc A (l1 l2 : list A) a l :
  l1 ++ l2 = l ++ a :: nil <->
  (l1 = l ++ a :: nil /\ l2 = nil) \/ (exists l2', l2 = l2' ++ a :: nil /\ l1 ++ l2' = l).
Proof.
  split; ins; desf; rewrite ?app_nil_r, ?app_assoc; ins; eauto.
  destruct (destruct_end l2); desf; rewrite ?app_nil_r in *; desf; eauto.
  rewrite app_assoc, snoc_eq_snoc in *; desf; eauto.
Qed.

Lemma app_eq_prefix A (l : list A) l' :
  l ++ l' = l <-> l' = nil.
Proof.
  split; ins; desf; auto using app_nil_r.
  induction l; ins; desf; eauto.
Qed.

Lemma app_eq_suffix A (l : list A) l' :
  l ++ l' = l' <-> l = nil.
Proof.
  split; ins; desf; revert H.
  induction l' using rev_induction; rewrite ?app_nil_r; ins.
  rewrite app_assoc, snoc_eq_snoc in *; desf; eauto.
Qed.

Lemma app_cons_eq_nil A (l1 l2 : list A) a :
  l1 ++ a :: l2 = nil <-> False.
Proof.
  destruct l1; ins; desf.
Qed.

Lemma app_cons_eq_cons A (l1 l2 : list A) a a' l :
  l1 ++ a :: l2 = a' :: l <->
  (l1 = nil /\ a = a' /\ l2 = l) \/ (exists l1', l1 = a' :: l1' /\ l1' ++ a :: l2 = l).
Proof.
  rewrite app_eq_cons; split; ins; desf; eauto.
Qed.

Lemma app_cons_eq_singleton A (l1 l2 : list A) a a' :
  l1 ++ a :: l2 = a' :: nil <-> l1 = nil /\ a = a' /\ l2 = nil.
Proof.
  rewrite app_eq_singleton; split; ins; desf; eauto.
Qed.

Lemma app_cons_eq_snoc A (l1 l2 : list A) a a' l :
  l1 ++ a :: l2 = l ++ a' :: nil <->
  (l1 = l /\ a = a' /\ l2 = nil) \/ (exists l2', l2 = l2' ++ a' :: nil /\ l1 ++ a :: l2' = l).
Proof.
  split; ins; desf; [|by rewrite <- app_assoc].
  rewrite app_eq_snoc in H; ins; desf.
  symmetry in H; rewrite app_cons_eq_cons in H; desf; eauto using app_nil_end.
Qed.

Lemma snoc_eq_nil A (l : list A) a :
  l ++ a :: nil = nil <-> False.
Proof.
  apply app_cons_eq_nil.
Qed.

Lemma snoc_eq_cons A (l : list A) a a' l' :
  l ++ a :: nil = a' :: l' <->
  (l = nil /\ a = a' /\ l' = nil) \/ (exists l1', l = a' :: l1' /\ l1' ++ a :: nil = l').
Proof.
  rewrite app_cons_eq_cons; split; ins; desf; eauto.
Qed.

Lemma snoc_eq_singleton A (l : list A) a a' :
  l ++ a :: nil = a' :: nil <-> l = nil /\ a = a'.
Proof.
  rewrite app_cons_eq_singleton; split; ins; desf; eauto.
Qed.

Lemma snoc_eq_app A (l1 l2 : list A) a l :
  l ++ a :: nil = l1 ++ l2 <->
  (l ++ a :: nil = l1 /\ l2 = nil) \/ (exists l2', l2' ++ a :: nil = l2 /\ l = l1 ++ l2').
Proof.
  split; ins; desf; rewrite ?app_nil_r, ?app_assoc; ins; eauto.
  destruct (destruct_end l2); desf; rewrite ?app_nil_r in *; desf; eauto.
  rewrite app_assoc, snoc_eq_snoc in *; desf; eauto.
Qed.

Lemma length_eq_add A (l : list A) m n :
  length l = m + n <->
  exists l' l'', l = l' ++ l'' /\ length l' = m /\ length l'' = n.
Proof.
  split; ins; desf; eauto using length_app.
  revert m H; induction l; ins.
  destruct m; ins; desf; exists nil, nil; ins.
  destruct m; [eexists nil, _; ins|].
  forward apply (IHl m) as X; ins; desf.
  eexists (_ :: _), _; ins.
Qed.

(** List map *)
(******************************************************************************)

Lemma map_eq_nil A B (f : A -> B) l :
  map f l = nil <-> l = nil.
Proof.
  destruct l; ins; desf; eauto.
Qed.

Lemma map_eq_cons A B (f : A -> B) l y ys :
  map f l = y :: ys <->
  exists x l', l = x :: l' /\ y = f x /\ map f l' = ys.
Proof.
  split; ins; desf.
  destruct l; ins; desf; eauto.
Qed.

Lemma map_eq_singleton A B (f : A -> B) l y :
  map f l = y :: nil <->
  exists x, l = x :: nil /\ y = f x.
Proof.
  split; ins; desf.
  destruct l as [|?[|??]]; ins; desf; eauto.
Qed.

Lemma map_eq_app A B (f : A -> B) l l1' l2' :
  map f l = l1' ++ l2' <->
  exists l1 l2, l = l1 ++ l2 /\ map f l1 = l1' /\ map f l2 = l2'.
Proof.
  split; ins; desf; auto using map_app.
  revert dependent l1'; induction l; destruct l1'; ins; desf.
  - exists nil, nil; ins.
  - eexists nil, (_ :: _); ins.
  - apply IHl in H; desf; eexists (_ :: _), _; ins.
Qed.

Lemma map_eq_snoc A B (f : A -> B) l y ys :
  map f l = ys ++ y :: nil <->
  exists x l', l = l' ++ x :: nil /\ y = f x /\ map f l' = ys.
Proof.
  rewrite map_eq_app; split; ins; desf; eauto.
  rewrite map_eq_singleton in *; desf; eauto.
Qed.

Lemma map_eq_app_inv A B (f : A -> B) l l1 l2 :
  map f l = l1 ++ l2 ->
  exists l1' l2', l = l1' ++ l2' /\ map f l1' = l1 /\ map f l2' = l2.
Proof.
  apply map_eq_app.
Qed.

Lemma list_app_eq_app A (l l' l0 l0' : list A) :
  l ++ l' = l0 ++ l0' ->
  (exists lr, l ++ lr = l0 /\ l' = lr ++ l0') \/
  (exists lr, l = l0 ++ lr /\ lr ++ l' = l0').
Proof.
  revert l0; induction l; ins; eauto.
  destruct l0; ins; desf; eauto.
  apply IHl in H; desf; eauto.
Qed.

(** List filtering *)
(******************************************************************************)

Lemma in_filter_iff A l f (x : A) : In x (filter f l) <-> In x l /\ f x.
Proof.
  induction l; ins; try tauto.
  des_if; ins; rewrite IHl; split; ins; desf; eauto.
Qed.

Lemma filter_app A f (l l' : list A) :
  filter f (l ++ l') = filter f l ++ filter f l'.
Proof.
  induction l; ins; desf; ins; congruence.
Qed.

Lemma Permutation_filter A (l l' : list A) (P: Permutation l l') f :
  Permutation (filter f l) (filter f l').
Proof.
  induction P; ins; desf; vauto.
Qed.

Add Parametric Morphism A : (@filter A) with
  signature eq ==> (@Permutation A) ==> (@Permutation A)
      as filter_mor.
Proof.
  by ins; apply Permutation_filter.
Qed.

Lemma length_filter A f (l : list A) :
  length (filter f l) <= length l.
Proof.
  induction l; ins; desf; ins; lia.
Qed.

(** List filtering with a [Prop]-predicate *)
(******************************************************************************)

Fixpoint filterP A (f: A -> Prop) l :=
  match l with
    | nil => nil
    | x :: l => if excluded_middle_informative (f x) then
                  x :: filterP f l
                else filterP f l
  end.

Lemma in_filterP_iff A (x : A) f l :
  In x (filterP f l) <-> In x l /\ f x.
Proof.
  induction l; ins; desf; ins; try (rewrite IHn; clear IHn);
  intuition; desf; eauto.
Qed.

Lemma filterP_app A f (l l' : list A) :
  filterP f (l ++ l') = filterP f l ++ filterP f l'.
Proof.
  induction l; ins; desf; ins; congruence.
Qed.

Lemma filterP_map A (d : A -> Prop) B (f : B -> A) l :
  filterP d (map f l) = map f (filterP (f ↓₁ d) l).
Proof.
  induction l; ins; desf; ins; f_equal; ins.
Qed.

Lemma filterP_set_equiv A (f f' : A -> Prop) (EQ: f ≡₁ f') (l : list A) :
  filterP f l = filterP f' l.
Proof.
  induction l; ins; desf; f_equal; firstorder.
Qed.

Lemma filterP_ext A (f f' : A -> Prop) l
      (EQ: forall x (IN: In x l), f x <-> f' x) :
  filterP f l = filterP f' l.
Proof.
  induction l; ins.
  specialize_full IHl; ins; eauto.
  specialize_full EQ; eauto.
  rewrite IHl; desf; tauto.
Qed.

Lemma Permutation_filterP A (l l' : list A) (P: Permutation l l') f :
  Permutation (filterP f l) (filterP f l').
Proof.
  induction P; ins; desf; vauto.
Qed.

Lemma Permutation_filterP2 A f f' (EQ: f ≡₁ f') l l' (P: Permutation (A:=A) l l') :
  Permutation (filterP f l) (filterP f' l').
Proof.
  replace (filterP f' l') with (filterP f l');
    auto using Permutation_filterP, filterP_set_equiv.
Qed.

Instance filterP_Proper A : Proper (_ ==> _ ==> _) _ := Permutation_filterP2 (A:=A).

Lemma filterP_eq_nil A f (l: list A):
  filterP f l = nil <-> forall x (IN: In x l) (COND: f x), False.
Proof.
  split; ins.
  * enough (In x nil) by done.
    rewrite <- H; apply in_filterP_iff; eauto.
  * induction l; ins; desf; eauto; exfalso; eauto.
Qed.

Lemma filterP_eq_cons A f (l l': list A) x:
  filterP f l = x :: l' ->
  f x /\
  exists p p',
    l = p ++ x :: p' /\
    (forall x (IN: In x p) (COND: f x), False) /\
    l' = filterP f p'.
Proof.
  induction l; ins; desf.
    by splits; ins; eexists nil; eexists; splits; ins; desf; eauto.
  eapply IHl in H; desc; splits; ins; desf.
  eexists (_ :: _); eexists; splits; ins; desf; eauto.
Qed.

Lemma filterP_eq_app A f (l l' l'': list A) :
  filterP f l = l' ++ l'' ->
  exists p p',
    l = p ++ p' /\
    l' = filterP f p /\
    l'' = filterP f p'.
Proof.
  revert l'; induction l; ins; desf.
  { destruct l'; ins; desf; exists nil, nil; ins. }
  destruct l'; ins; desf.
    eexists nil, (_ :: _); splits; ins; desf.
  all: apply IHl in H; desf; eexists (_ :: _), _; splits; ins; desf.
Qed.

Lemma filterP_eq_middle A f (l l' l'': list A) x :
  filterP f l = l' ++ x :: l'' ->
  f x /\
  exists p p',
    l = p ++ x :: p' /\
    l' = filterP f p /\
    l'' = filterP f p'.
Proof.
  ins; apply filterP_eq_app in H; desf.
  apply eq_sym, filterP_eq_cons in H1; desf.
  split; ins.
  eexists (_ ++ _), _; rewrite appA, filterP_app; splits; ins.
  apply filterP_eq_nil in H2; rewrite H2.
  apply app_nil_end.
Qed.

Lemma length_filterP A f (l : list A) :
  length (filterP f l) <= length l.
Proof.
  induction l; ins; desf; ins; lia.
Qed.

(** List flattening *)
(******************************************************************************)

Fixpoint flatten A (l: list (list A)) :=
  match l with
    | nil => nil
    | x :: l' => x ++ flatten l'
  end.

Lemma in_flatten_iff A (x: A) ll :
  In x (flatten ll) <-> exists l, In l ll /\ In x l.
Proof.
  induction ll; ins.
    by split; ins; desf.
  rewrite in_app_iff, IHll; clear; split; ins; desf; eauto.
Qed.

Lemma flatten_app A (l l' : list (list A)) :
  flatten (l ++ l') = flatten l ++ flatten l'.
Proof.
  by induction l; ins; desf; ins; rewrite appA, IHl.
Qed.

Lemma length_flatten A (l : list (list A)) :
  length (flatten l) = list_sum (map (length (A:=A)) l).
Proof.
  induction l; ins; desf; rewrite length_app; lia.
Qed.

(** List reverse *)
(******************************************************************************)

Lemma in_rev_iff A x (l : list A) :
  In x (rev l) <-> In x l.
Proof.
  symmetry; apply in_rev.
Qed.

Lemma rev_cons A (a : A) (l: list A) : rev (a :: l) = rev l ++ a :: nil.
Proof.
  done.
Qed.

Lemma rev_app A (l1 l2 : list A) :
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  apply rev_app_distr.
Qed.

Lemma rev_snoc A (a : A) (l: list A) : rev (l ++ a :: nil) = a :: rev l.
Proof.
  apply rev_app.
Qed.

Lemma rev_rev A (l : list A) : rev (rev l) = l.
Proof.
  induction l; ins; rewrite rev_app, IHl; ins.
Qed.

Lemma rev_filter A f (l : list A) :
  rev (filter f l) = filter f (rev l).
Proof.
  induction l; ins; desf; ins; rewrite filter_app, IHl; ins; desf; ins.
  auto using app_nil_end.
Qed.

Lemma rev_filterP A f (l : list A) :
  rev (filterP f l) = filterP f (rev l).
Proof.
  induction l; ins; desf; ins; rewrite filterP_app, IHl; ins; desf; ins.
  auto using app_nil_end.
Qed.

Lemma rev_map A B (f : A -> B) (l : list A) :
  rev (map f l) = map f (rev l).
Proof.
  induction l; ins; rewrite map_app, IHl; ins.
Qed.

Lemma rev_eq A (l l' : list A) : rev l = rev l' <-> l = l'.
Proof.
  split; ins; desf.
  apply (f_equal (@rev A)) in H; rewrite !rev_rev in H; ins.
Qed.

Lemma rev_eq_nil A (l : list A) : rev l = nil <-> l = nil.
Proof.
  by rewrite <- rev_eq, rev_rev.
Qed.

Lemma rev_eq_cons A (a : A) (l l' : list A) :
  rev l = a :: l' <-> l = rev l' ++ a :: nil.
Proof.
  by rewrite <- rev_eq, rev_rev.
Qed.

Lemma rev_eq_app A (l l1 l2 : list A) :
  rev l = l1 ++ l2 <-> l = rev l2 ++ rev l1.
Proof.
  by rewrite <- rev_eq, rev_rev, rev_app.
Qed.

Lemma rev_eq_snoc A (a : A) (l l' : list A) :
  rev l = l' ++ a :: nil <-> l = a :: rev l'.
Proof.
  apply rev_eq_app.
Qed.

(** List disjointness *)
(******************************************************************************)

Definition disjoint A (l1 l2 : list A) :=
  forall a (IN1: In a l1) (IN2: In a l2), False.

Lemma disjoint_nil_l A (l : list A) : disjoint nil l.
Proof. done. Qed.

Lemma disjoint_nil_r A (l : list A) : disjoint l nil.
Proof. done. Qed.

Lemma disjoint_one_l A (a : A) (l : list A) : disjoint (a :: nil) l <-> ~ In a l.
Proof. unfold disjoint; intuition; ins; desf; eauto. Qed.

Lemma disjoint_one_r A (a : A) (l : list A) : disjoint l (a :: nil) <-> ~ In a l.
Proof. unfold disjoint; intuition; ins; desf; eauto. Qed.

Lemma disjoint_rev_l A (l1 l2 : list A) :
  disjoint (rev l1) l2 <-> disjoint l1 l2.
Proof.
  unfold disjoint; intuition; eapply H; eauto; try rewrite <- in_rev in *; eauto.
Qed.

Lemma disjoint_rev_r A (l1 l2 : list A) :
  disjoint l1 (rev l2) <-> disjoint l1 l2.
Proof.
  unfold disjoint; intuition; eapply H; eauto; try rewrite <- in_rev in *; eauto.
Qed.

(** Remove duplicate list elements (classical) *)
(******************************************************************************)

Fixpoint undup A (l: list A) :=
  match l with nil => nil
    | x :: l =>
      ifP (In x l) then undup l else x :: undup l
  end.

(** Lemmas about [NoDup] and [undup] *)
(******************************************************************************)

Lemma nodup_one A (x: A) : NoDup (x :: nil).
Proof. vauto. Qed.

Global Hint Resolve NoDup_nil nodup_one : core hahn.

Lemma nodup_map:
  forall (A B: Type) (f: A -> B) (l: list A),
  NoDup l ->
  (forall x y, In x l -> In y l -> x <> y -> f x <> f y) ->
  NoDup (map f l).
Proof.
  induction 1; ins; vauto.
  constructor; eauto.
  intro; rewrite in_map_iff in *; desf.
  edestruct H1; try eapply H2; eauto.
  intro; desf.
Qed.

Lemma nodup_cons A (x: A) l:
  NoDup (x :: l) <-> ~ In x l /\ NoDup l.
Proof. split; inversion 1; vauto. Qed.

Lemma nodup_app:
  forall (A: Type) (l1 l2: list A),
  NoDup (l1 ++ l2) <->
  NoDup l1 /\ NoDup l2 /\ disjoint l1 l2.
Proof.
  induction l1; ins.
    by split; ins; desf; vauto.
  rewrite !nodup_cons, IHl1, in_app_iff; unfold disjoint.
  ins; intuition (subst; eauto).
Qed.

Lemma nodup_append_commut A (a b : list A) :
  NoDup (a ++ b) -> NoDup (b ++ a).
Proof.
  ins; rewrite nodup_app in *; unfold disjoint in *.
  desf; splits; ins; eauto.
Qed.

Lemma nodup_append A (l1 l2: list A) :
  NoDup l1 -> NoDup l2 -> disjoint l1 l2 ->
  NoDup (l1 ++ l2).
Proof.
  generalize nodup_app; firstorder.
Qed.

Lemma nodup_append_right A (l1 l2: list A) :
  NoDup (l1 ++ l2) -> NoDup l2.
Proof.
  generalize nodup_app; firstorder.
Qed.

Lemma nodup_append_left A (l1 l2: list A) :
  NoDup (l1 ++ l2) -> NoDup l1.
Proof.
  generalize nodup_app; firstorder.
Qed.

Lemma nodup_rev A (l : list A) : NoDup (rev l) <-> NoDup l.
Proof.
  induction l; ins.
  rewrite nodup_app, !nodup_cons, IHl, disjoint_rev_l, disjoint_one_r; intuition.
Qed.

Lemma nodup_filter A (l: list A) (ND: NoDup l) f : NoDup (filter f l).
Proof.
  induction l; ins; inv ND; desf; eauto using NoDup.
  econstructor; eauto; rewrite in_filter_iff; tauto.
Qed.

Lemma nodup_filterP A (l: list A) (ND: NoDup l) f : NoDup (filterP f l).
Proof.
  induction l; ins; inv ND; desf; eauto using NoDup.
  econstructor; eauto; rewrite in_filterP_iff; tauto.
Qed.

Global Hint Resolve nodup_filter nodup_filterP : core hahn.

Lemma Permutation_nodup A ( l l' : list A) :
  Permutation l l' -> NoDup l -> NoDup l'.
Proof.
  induction 1; eauto; rewrite !nodup_cons in *; ins; desf; intuition.
  eby symmetry in H; eapply H0; eapply Permutation_in.
Qed.

Lemma nodup_eq_one A (x : A) l :
   NoDup l -> In x l -> (forall y (IN: In y l), y = x) -> l = x :: nil.
Proof.
  destruct l; ins; f_equal; eauto.
  inv H; desf; clear H H5; induction l; ins; desf; case H4; eauto using eq_sym.
  rewrite IHl in H0; ins; desf; eauto.
Qed.

Lemma nodup_consD A (x : A) l : NoDup (x :: l) -> NoDup l.
Proof. inversion 1; desf. Qed.

Lemma nodup_mapD A B (f : A-> B) l : NoDup (map f l) -> NoDup l.
Proof.
  induction l; ins; rewrite !nodup_cons, in_map_iff in *; desf; eauto 8.
Qed.

Lemma In_NoDup_Permutation A (a : A) l (IN: In a l) (ND : NoDup l) :
  exists l', Permutation l (a :: l') /\ ~ In a l'.
Proof.
  induction l; ins; desf; inv ND; eauto.
  destruct IHl as (l' & ? & ?); eauto.
  destruct (classic (a0 = a)); desf.
  eexists (a0 :: l'); split; try red; ins; desf.
  eapply Permutation_trans, perm_swap; eauto.
Qed.

Lemma in_undup_iff A (x : A) (l : list A) : In x (undup l) <-> In x l.
Proof. induction l; split; ins; desf; ins; desf; eauto. Qed.

Lemma nodup_undup A (l : list A) : NoDup (undup l).
Proof. induction l; ins; desf; constructor; rewrite ?in_undup_iff in *; eauto. Qed.

Global Hint Resolve nodup_undup : core hahn.

Lemma undup_nodup A (l : list A) : NoDup l -> undup l = l.
Proof. induction 1; ins; desf; congruence. Qed.

Lemma undup_nonnil A (l : list A) : l <> nil -> undup l <> nil.
Proof.
  induction l; ins; desf.
  by eapply in_undup_iff in i; intro X; rewrite X in *.
Qed.

Lemma undup_filter A f (l : list A) : undup (filter f l) = filter f (undup l).
Proof.
  induction l; ins; desf; ins; desf;
    rewrite in_filter_iff in *; clarify_not; desf; congruence.
Qed.

Lemma undup_filterP A f (l : list A) : undup (filterP f l) = filterP f (undup l).
Proof.
  induction l; ins; desf; ins; desf;
    rewrite in_filterP_iff in *; clarify_not; desf; congruence.
Qed.

Lemma Permutation_undup A (l l' : list A) :
  Permutation l l' -> Permutation (undup l) (undup l').
Proof.
  ins; eapply NoDup_Permutation; ins; rewrite !in_undup_iff.
  split; eauto using Permutation_in, Permutation_sym.
Qed.

Lemma in_split_perm A (x : A) l (IN: In x l) :
  exists l', Permutation l (x :: l').
Proof.
  induction l; ins; intuition; desf; eauto.
  exists (a :: l'); rewrite H0; vauto.
Qed.

Lemma NoDup_eq_simpl A l1 (a : A) l1' l2 l2'
      (ND : NoDup (l1 ++ a :: l1'))
      (L : l1 ++ a :: l1' = l2 ++ a :: l2') :
      l1 = l2 /\ l1' = l2'.
Proof.
  revert l2 L; induction l1; ins; destruct l2; ins; desf.
    by exfalso; inv ND; eauto using in_or_app, in_eq, in_cons.
    by exfalso; inv ND; eauto using in_or_app, in_eq, in_cons.
  inv ND; eapply IHl1 in H0; desf.
Qed.

Lemma set_finiteE A (s : A -> Prop) :
  set_finite s <-> exists findom, NoDup findom /\ s ≡₁ (fun x => In x findom).
Proof.
  repeat autounfold with unfolderDb; intuition; desf; eauto.
  exists (undup (filterP s findom)); splits; ins.
  all: rewrite in_undup_iff, in_filterP_iff in *; desf; eauto.
Qed.

(** Lemmas about list concatenation *)
(******************************************************************************)

Lemma in_concat_iff A (a: A) ll :
  In a (concat ll) <-> exists l, In a l /\ In l ll.
Proof.
  induction ll; ins; [by split; ins; desf|].
  rewrite in_app_iff, IHll; split; ins; desf; eauto.
Qed.

Lemma in_concat A (a: A) l ll :
  In a l ->
  In l ll ->
  In a (concat ll).
Proof.
  rewrite in_concat_iff; eauto.
Qed.

Add Parametric Morphism X : (@concat X) with
  signature (@Permutation (list X)) ==> (@Permutation X)
      as concat_more.
Proof.
  induction 1; rewrite ?concat_cons,  ?app_assoc;
  eauto using Permutation, Permutation_app, Permutation_app_comm.
Qed.

Lemma NoDup_concat_simpl A (a : A) l1 l2 ll
      (ND: NoDup (concat ll))
      (K: In l1 ll) (K' : In a l1)
      (L: In l2 ll) (L' : In a l2) :
      l1 = l2.
Proof.
  apply in_split_perm in K; desc; rewrite K, concat_cons, nodup_app in *; ins; desf.
  edestruct ND1; eauto using in_concat.
Qed.

Lemma NoDup_concatD A (l: list A) ll :
  NoDup (concat ll) -> In l ll -> NoDup l.
Proof.
  ins; apply in_split_perm in H0; desf.
  rewrite H0, concat_cons, nodup_app in H; desf.
Qed.

Lemma in_concat_fst A a (l : list A) B (l' : list B) ll :
   In (l, l') ll ->
   In a l ->
   In a (concat (map fst ll)).
Proof.
  ins; rewrite <- flat_map_concat_map, in_flat_map; eauto.
Qed.

Lemma in_concat_snd A (l : list A) B a (l' : list B) ll :
   In (l, l') ll ->
   In a l' ->
   In a (concat (map snd ll)).
Proof.
  ins; rewrite <- flat_map_concat_map, in_flat_map; eauto.
Qed.

(** [map_filter] *)
(******************************************************************************)

Section map_filter.

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

  Fixpoint map_filter l :=
    match l with
      | nil => nil
      | x :: l => match f x with
                    | None => map_filter l
                    | Some b => b :: map_filter l
                  end
    end.

  Lemma in_map_filter x l :
    In x (map_filter l) <-> exists a, f a = Some x /\ In a l.
  Proof using.
    induction l; ins; desf; ins; try (rewrite IHn; clear IHn);
    intuition; desf; eauto.
  Qed.

  Lemma map_filter_app (l l' : list A) :
    map_filter (l ++ l') = map_filter l ++ map_filter l'.
  Proof using.
    induction l; ins; desf; ins; congruence.
  Qed.

  Lemma nodup_map_filter l :
    NoDup l ->
    (forall x y z, In x l -> In y l -> f x = Some z -> f y = Some z -> x = y) ->
    NoDup (map_filter l).
  Proof using.
    induction l; ins; desf; rewrite ?nodup_cons, ?in_map_filter in *;
      desf; splits; eauto.
    by intro; desf; eauto; rewrite (H0 a a0 b) in H; eauto.
  Qed.

End map_filter.

(** Lemmas about Forall *)
(******************************************************************************)

Lemma Forall_cons A (P : A -> Prop) a l :
  Forall P (a :: l) <-> P a /\ Forall P l.
Proof.
  split; intro H; desf; vauto; inversion H; desf.
Qed.

Lemma Forall_app A (P : A -> Prop) l1 l2 :
  Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2.
Proof.
  induction l1; ins; [by intuition; vauto|].
  by rewrite !Forall_cons, IHl1, and_assoc.
Qed.

Lemma Forall_filter A (P: A -> Prop) f l :
  Forall P l -> Forall P (filter f l).
Proof.
  rewrite !Forall_forall; ins.
  rewrite in_filter_iff in H0; desf; eauto.
Qed.

Lemma Forall_filterP A (P: A -> Prop) f l :
  Forall P l -> Forall P (filterP f l).
Proof.
  rewrite !Forall_forall; ins.
  rewrite in_filterP_iff in H0; desf; eauto.
Qed.

Lemma Forall_in A (P : A -> Prop) l x :
  Forall P l -> In x l -> P x.
Proof.
  ins; eapply Forall_forall; eauto.
Qed.

Lemma Forall_app_cons A (P : A -> Prop) l e l' :
  Forall P (l ++ e :: l') -> Forall P (l ++ l').
Proof.
  rewrite !Forall_app, Forall_cons; ins; desf.
Qed.

Definition ForallE := Forall_forall.

(** [dprod] *)
(******************************************************************************)

Fixpoint dprod A B al (f : A -> list B) :=
  match al with
    | nil => nil
    | a :: al => map (fun b => (a, b)) (f a) ++ dprod al f
  end.

Lemma in_dprod_iff A B x al (f : A -> list B) :
  In x (dprod al f) <-> In (fst x) al /\ In (snd x) (f (fst x)).
Proof.
  induction al; ins; rewrite ?in_app_iff, ?in_map_iff, ?IHal; try clear IHal;
  split; ins; desf; ins; eauto; destruct x; ins; eauto.
Qed.

(** [seq] *)
(******************************************************************************)

Lemma seq0 a : seq a 0 = nil.
Proof. ins. Qed.

Lemma seqS_hd a n : seq a (S n) = a :: seq (S a) n.
Proof. ins. Qed.

Lemma seqS a n : seq a (S n) = seq a n ++ (a + n) :: nil.
Proof.
  revert a; induction n; ins.
    f_equal; lia.
  rewrite IHn; do 3 f_equal; lia.
Qed.

Lemma in_seq_iff a n l : In a (seq n l) <-> n <= a < n + l.
Proof.
  revert n; induction l; ins; rewrite ?IHl; lia.
Qed.

Lemma in_seq0_iff x a : In x (seq 0 a) <-> x < a.
Proof.
  rewrite in_seq_iff; lia.
Qed.

Lemma nodup_seq n l : NoDup (seq n l).
Proof.
  revert n; induction l; ins; constructor; ins; eauto.
  rewrite in_seq_iff; lia.
Qed.

Lemma seq_split :
  forall x a y,
    x <= y ->
    seq a y = seq a x ++ seq (x + a) (y - x).
Proof.
  induction x; ins; rewrite ?Nat.sub_0_r; ins.
  destruct y; ins; try lia.
  f_equal; rewrite IHx; repeat (f_equal; try lia).
Qed.

Lemma seq_split_gen :
  forall l n a,
  n <= a < n + l ->
  seq n l = seq n (a - n) ++ a :: seq (S a) (l + n - a - 1).
Proof.
  induction l; ins; desf; ins; try lia.
    repeat f_equal; lia.
  destruct (eqP n (S n0)); subst.
    replace (n0 - n0) with 0 by lia; ins; repeat f_equal; lia.
  rewrite IHl with (a := S n0); try lia.
  desf; ins; try replace (n0 - n2) with (S (n0 - S n2)) by lia;
  ins; repeat (f_equal; try lia).
Qed.

Lemma seq_split_perm :
  forall l a,
  a < l ->
  exists l', Permutation (seq 0 l) (a :: l') /\ ~ In a l'.
Proof.
  ins; eapply In_NoDup_Permutation;
    eauto using nodup_seq; apply in_seq_iff; lia.
Qed.

Lemma seq_split0 :
  forall l a,
  a < l ->
  seq 0 l = seq 0 a ++ a :: seq (S a) (l - a - 1).
Proof.
  ins; rewrite seq_split_gen with (a := a); repeat f_equal; lia.
Qed.

Lemma seq_add len1 len2 start :
  seq start (len1 + len2) = seq start len1 ++ seq (start + len1) len2.
Proof.
  rewrite seq_split with (x := len1); try lia.
  f_equal; f_equal; lia.
Qed.

Lemma seq_eq_nil start len :
  seq start len = nil <-> len = 0.
Proof.
  destruct len; ins.
Qed.

Lemma seq_eq_cons start len x l :
  seq start len = x :: l
  <-> match len with
        0 => False
      | S len' => start = x /\ seq (S x) len' = l
      end.
Proof.
  desf; split; ins; desf.
Qed.

Lemma seq_eq_app start len l l' :
  seq start len = l ++ l'
  <-> length l <= len /\
      seq start (length l) = l /\
      seq (start + length l) (len - length l) = l'.
Proof.
  revert start len; induction l; ins.
    repeat split; ins; desf; f_equal; lia.
    destruct len; ins.
      split; ins; desf; lia.
    specialize (IHl (S start) len); intuition; desf; intuition; auto using f_equal.
    rewrite Nat.add_succ_comm in *; ins.
    rewrite Nat.add_succ_comm in *; auto using f_equal, le_S_n.
Qed.

Lemma map_nth_seq A (f : nat -> A) a d l
  (EQ: forall i (LTi : i < length l), f (a + i) = nth i l d) :
  map f (seq a (length l)) = l.
Proof.
  revert a EQ; induction l; ins; f_equal.
    rewrite <- (EQ 0); try rewrite Nat.add_0_r; ins; lia.
  eapply IHl; ins; rewrite <- Nat.add_succ_r.
  eapply (EQ (S i)); lia.
Qed.

Lemma map_seq_shift A (f g : nat -> A) a b n
  (EQ: forall i (LTi : i < n), f (a + i) = g (b + i)) :
  map f (seq a n) = map g (seq b n).
Proof.
  induction n; try done.
  rewrite !seqS, !map_app; ins; f_equal.
  apply IHn; ins; apply EQ; lia.
  f_equal; apply EQ; ins.
Qed.

Global Opaque seq.

Lemma filterP_map_seq_eq A (f : A -> Prop) fl a n m
      (Fn : forall i, f (fl i) -> i < a + n)
      (Fm : forall i, f (fl i) -> i < a + m) :
  filterP f (map fl (seq a n)) = filterP f (map fl (seq a m)).
Proof.
  destruct (lt_eq_lt_dec n m) as [[LT|]|LT]; desf.
  { rewrite seq_split with (x := n) (y := m); try lia.
    rewrite map_app, filterP_app.
    symmetry; rewrite app_eq_prefix, filterP_eq_nil; ins.
    rewrite in_map_iff in *; desf.
    rewrite in_seq_iff in *.
    apply Fn in COND; lia.
  }
  { rewrite seq_split with (x := m) (y := n); try lia.
    rewrite map_app, filterP_app.
    rewrite app_eq_prefix, filterP_eq_nil; ins.
    rewrite in_map_iff in *; desf.
    rewrite in_seq_iff in *.
    apply Fm in COND; lia.
  }
Qed.

Lemma nth_filterP A (f : A -> Prop) (l : list A) i d
      (LT : i < length (filterP f l)) :
  exists n, n < length l
            /\ nth i (filterP f l) d = nth n l d
            /\ i = length (filterP f (map (fun i => nth i l d)
                                          (List.seq 0 n))).
Proof.
  revert i LT; induction l using rev_induction; ins; desf; ins; try lia.
  rewrite filterP_app, length_app in *.
  destruct (lt_dec i (length (filterP f l))).
  { specialize_full IHl; eauto; desf.
    exists n; rewrite !app_nth1; splits; ins; try lia.
    do 2 f_equal; apply map_ext_in; ins; rewrite in_seq0_iff in *;
      rewrite app_nth1; ins; lia.
  }
  ins; desf; ins; try lia.
  assert (i = length (filterP f l)) by lia; desf.
  exists (length l); splits; try lia.
  rewrite !app_nth2, !Nat.sub_diag; ins; try lia.
  do 2 f_equal.
  symmetry; eapply map_nth_seq with (d := d); ins.
  apply app_nth1; ins.
Qed.

Lemma nth_filterP' A (f : A -> Prop) (l : list A) n d
      (LT : n < length l) (F: f (nth n l d)):
  nth (length (filterP f (map (fun i => nth i l d)
                              (List.seq 0 n))))
      (filterP f l) d = nth n l d.
Proof.
  revert n F LT; induction l using rev_induction; ins; desf; ins; try lia.
  rewrite filterP_app, length_app in *.
  destruct (lt_dec n (length l)).
  { rewrite !app_nth1 in *; ins.
    specialize_full IHl; eauto; desf.
    rewrite <- IHl.
    do 3 f_equal; apply map_ext_in; ins; rewrite in_seq0_iff in *;
      rewrite app_nth1; ins; lia.
    erewrite <- map_nth_seq
      with (a := 0) (l := l)
           (f := fun i => nth i (l ++ a :: nil) d) at 1; auto using app_nth1.
    rewrite (seq_split0 l0), map_app, filterP_app, length_app; ins; desf; ins;
      try lia.
  }
  ins; desf; ins.
  all: assert (n = length l) by lia; desf.
  all: rewrite app_nth2, Nat.sub_diag in F; ins; desf; try lia.
  rewrite map_nth_seq with (d := d).
    rewrite !app_nth2, ?Nat.sub_diag; ins.
  ins; rewrite app_nth1; ins.
Qed.

(** [mk_list] *)
(******************************************************************************)

Fixpoint mk_list n A (f: nat -> A) :=
  match n with
      0 => nil
    | S n => mk_list n f ++ f n :: nil
  end.

Lemma mk_listE n A (f: nat -> A) :
  mk_list n f = map f (seq 0 n).
Proof.
  induction n; ins; rewrite IHn.
  rewrite seq_split with (x:=n) (y:=S n); try lia.
  by rewrite map_app, plus_0_r, <- minus_Sn_m, minus_diag.
Qed.

Lemma in_mk_list_iff A (x: A) n f :
  In x (mk_list n f) <-> exists m, m < n /\ x = f m.
Proof.
  induction n; ins; try (rewrite in_app_iff, IHn; clear IHn); desc;
    split; ins; desf; try lia; try (by repeat eexists; lia).
  destruct (eqP m n); desf; eauto.
  left; repeat eexists; ins; lia.
Qed.

Lemma mk_list_length A n (f : nat -> A) :
  length (mk_list n f) = n.
Proof.
  induction n; ins; rewrite app_length; ins; lia.
Qed.

Lemma mk_list_nth A i n f (d : A) :
  nth i (mk_list n f) d = if le_lt_dec n i then d else f i.
Proof.
  induction n; ins; desf; rewrite app_nth; desf;
  rewrite mk_list_length in *; desf; try lia.
    apply nth_overflow; ins; lia.
  by assert (i = n) by lia; desf; rewrite minus_diag.
Qed.

Definition length_mk_list := mk_list_length.
Definition nth_mk_list := mk_list_nth.

Hint Rewrite length_mk_list : calc_length.

(** [max_of_list] *)
(******************************************************************************)

Fixpoint max_of_list l :=
  match l with
      nil => 0
    | n :: l => max n (max_of_list l)
  end.

Lemma max_of_list_app l l' :
  max_of_list (l ++ l') = max (max_of_list l) (max_of_list l').
Proof.
  by induction l; ins; rewrite IHl, Max.max_assoc.
Qed.

(** Miscellaneous *)
(******************************************************************************)

Lemma perm_from_subset :
  forall A (l : list A) l',
    NoDup l' ->
    (forall x, In x l' -> In x l) ->
    exists l'', Permutation l (l' ++ l'').
Proof.
  induction l; ins; vauto.
    by destruct l'; ins; vauto; exfalso; eauto.
  destruct (classic (In a l')).

    eapply In_split in H1; desf; rewrite ?nodup_app, ?nodup_cons in *; desf.
    destruct (IHl (l1 ++ l2)); ins.
      by rewrite ?nodup_app, ?nodup_cons in *; desf; repeat split; ins; red;
         eauto using in_cons.
      by specialize (H0 x); rewrite in_app_iff in *; ins; desf;
         destruct (classic (a = x)); subst; try tauto; exfalso; eauto using in_eq.
    eexists; rewrite app_ass in *; ins.
    by eapply Permutation_trans, Permutation_middle; eauto.

  destruct (IHl l'); eauto; ins.
    by destruct (H0 x); auto; ins; subst.
  by eexists (a :: _); eapply Permutation_trans, Permutation_middle; eauto.
Qed.

Lemma list_prod_app A (l l' : list A) B (m : list B) :
  list_prod (l ++ l') m = list_prod l m ++ list_prod l' m.
Proof.
  by induction l; ins; rewrite IHl, app_assoc.
Qed.

Lemma list_prod_nil_r A (l : list A) B :
  list_prod l (@nil B) = nil.
Proof.
  induction l; ins.
Qed.

Lemma list_prod_cons_r A (l : list A) B a (m : list B) :
  Permutation (list_prod l (a :: m)) (map (fun x => (x,a)) l ++ list_prod l m).
Proof.
  induction l; ins.
  eapply Permutation_cons; ins.
  eapply Permutation_trans; [by apply Permutation_app; eauto|].
  rewrite !app_assoc; eauto using Permutation_app, Permutation_app_comm.
Qed.

Lemma list_prod_app_r A (l : list A) B (m m' : list B) :
  Permutation (list_prod l (m ++ m')) (list_prod l m ++ list_prod l m').
Proof.
  induction m; ins; ins.
    by rewrite list_prod_nil_r.
  rewrite list_prod_cons_r.
  eapply Permutation_trans; [by eapply Permutation_app, IHm|].
  rewrite app_assoc; apply Permutation_app; ins.
  symmetry; apply list_prod_cons_r.
Qed.

Lemma Permutation_listprod_r A (l : list A) B (m m' : list B) :
  Permutation m m' ->
  Permutation (list_prod l m) (list_prod l m').
Proof.
  ins; revert l; induction H; ins; eauto using Permutation.
    by rewrite ?list_prod_cons_r; eauto using Permutation_app.
  rewrite list_prod_cons_r.
  eapply Permutation_trans; [by apply Permutation_app, list_prod_cons_r|].
  symmetry.
  rewrite list_prod_cons_r.
  eapply Permutation_trans; [by apply Permutation_app, list_prod_cons_r|].
  rewrite !app_assoc; eauto using Permutation_app, Permutation_app_comm.
Qed.

Ltac in_simp :=
  try match goal with |- ~ _ => intro end;
  repeat first [
    rewrite in_rev_iff in * |
    rewrite in_undup_iff in * |
    rewrite in_flatten_iff in *; desc; clarify |
    rewrite in_map_iff in *; desc; clarify |
    rewrite in_seq0_iff in *; desc; clarify |
    rewrite in_mk_list_iff in *; desc; clarify |
    rewrite in_seq_iff in *; desc; clarify |
    rewrite in_filter_iff in *; desc; clarify |
    rewrite in_filterP_iff in *; desc; clarify ].

Ltac in_des :=
  try match goal with |- ~ _ => intro end;
  repeat first [
    rewrite in_rev_iff in * |
    rewrite in_undup_iff in * |
    rewrite in_flatten_iff in *; desc; clarify |
    rewrite in_map_iff in *; desc; clarify |
    rewrite in_seq0_iff in *; desc; clarify |
    rewrite in_mk_list_iff in *; desc; clarify |
    rewrite in_seq_iff in *; desc; clarify |
    rewrite in_filter_iff in *; desc; clarify |
    rewrite in_filterP_iff in *; desc; clarify |
    rewrite in_app_iff in *; des].


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

Coq < Section Distribution_A.

Coq < Goal forall p q r:Prop, (p /\ (q \/ r)) <-> ((p /\ q) \/ (p /\ r)).
1 subgoal

  ============================
   forall p q r : Prop, p /\ (q \/ r) <-> p /\ q \/ p /\ r

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  r : Prop
  ============================
   p /\ (q \/ r) <-> p /\ q \/ p /\ r

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
tauto.

Unnamed_thm is defined

Coq <

*)

Section Distribution_A.
Goal forall p q r:Prop, (p /\ (q \/ r)) <-> ((p /\ q) \/ (p /\ r)).
intros.
tauto.
Qed.