Require Export OrderedType.
Require Import SetoidList.
Require OrderedTypeEx.
Require MapInterface.
Require Import FunInd.

Generalizable All Variables.

(** This file corresponds to [FMapList.v] in the standard library
   and implements finite maps as ordered lists of bindings. The
   corresponding [FMap] and [FMapSpecs] instances are defined in
   the file [MapListInstance.v].
   *)

Module MapList.
(** The type of maps from elements of type [key] to elements
   of type [elt] is a list of pairs [key * elt].
   It will be without duplicates, and ordered with respect
   to the comparison inferred by the typeclasses mechanism. *)
Definition dict (key : Type) `{OrderedType key} (elt : Type) :=
  list (key * elt).

Section MapDefinitions.
  Variable key : Type.
  Hypothesis (comparedec : OrderedType key).

  Variable elt : Type.
  Let t := dict key.

  Import KeyOrderedType.
  Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.

  Definition empty : t elt := nil.
  Definition is_empty (l : t elt) : bool := if l then true else false.

  Function mem (k : key) (s : t elt) {struct s} : bool :=
    match s with
      | nil => false
      | (k',_) :: l =>
        match k =?= k' with
          | Lt => false
          | Eq => true
          | Gt => mem k l
        end
    end.

  Function find (k:key) (s: t elt) {struct s} : option elt :=
    match s with
      | nil => None
      | (k',x)::s' =>
        match k =?= k' with
          | Lt => None
          | Eq => Some x
          | Gt => find k s'
        end
    end.

  Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
    match s with
      | nil => (k,x) :: nil
      | (k',y) :: l =>
        match k =?= k' with
          | Lt => (k,x)::s
          | Eq => (k,x)::l
          | Gt => (k',y) :: add k x l
        end
    end.

  Function remove (k : key) (s : t elt) {struct s} : t elt :=
    match s with
      | nil => nil
      | (k',x) :: l =>
        match k =?= k' with
          | Lt => s
          | Eq => l
          | Gt => (k',x) :: remove k l
        end
    end.

  Function insert (k : key) (d : elt) (f : elt -> elt) (s : t elt)
    {struct s} : t elt :=
    match s with
      | nil => (k, d)::nil
      | (k', y) :: l =>
        match k =?= k' with
          | Lt => (k, d)::s
          | Eq => (k, f y)::l
          | Gt => (k', y) :: insert k d f l
        end
    end.

  Function adjust (k : key) (f : elt -> elt) (s : t elt) {struct s} : t elt :=
    match s with
      | nil => nil
      | (k', y) :: l =>
        match k =?= k' with
          | Lt => s
          | Eq => (k, f y)::l
          | Gt => (k', y) :: adjust k f l
        end
    end.

  Definition elements (m: t elt) := m.
  Definition cardinal (m: t elt) := length m.

  Definition choose (m : t elt) : option (key * elt) :=
    match m with
      | nil => None
      | (x,e)::_ => Some (x, e)
    end.

  Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A :=
    match m with
      | nil => acc
      | (k,e)::m' => fold A f m' (f k e acc)
    end.

  Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool :=
    match m, m' with
      | nil, nil => true
      | (x,e)::l, (x',e')::l' =>
        match x =?= x' with
          | Eq => if cmp e e' then equal cmp l l' else false
          | _ => false
        end
      | _, _ => false
    end.

  Variable elt':Type.

  Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' :=
    match m with
      | nil => nil
      | (k,e)::m' => (k,f e) :: map f m'
    end.

  Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' :=
    match m with
      | nil => nil
      | (k,e)::m' => (k,f k e) :: mapi f m'
    end.

  Variable elt'' : Type.
  Variable f : option elt -> option elt' -> option elt''.

  Definition option_cons {A:Type}(k:key)(o:option A)(l:list (key*A)) :=
    match o with
      | Some e => (k,e)::l
      | None => l
    end.

  Fixpoint map2_l (m : t elt) : t elt'' :=
    match m with
      | nil => nil
      | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
    end.

  Fixpoint map2_r (m' : t elt') : t elt'' :=
    match m' with
      | nil => nil
      | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
    end.

  Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
    match m with
      | nil => map2_r
      | (k,e) :: l =>
        fix map2_aux (m' : t elt') : t elt'' :=
        match m' with
          | nil => map2_l m
          | (k',e') :: l' =>
            match k =?= k' with
              | Lt => option_cons k (f (Some e) None) (map2 l m')
              | Eq => option_cons k (f (Some e) (Some e')) (map2 l l')
              | Gt => option_cons k' (f None (Some e')) (map2_aux l')
            end
        end
    end.
End MapDefinitions.

Arguments Empty {key comparedec elt}.
Arguments empty {key comparedec elt}.
Arguments is_empty {key comparedec elt}.
Arguments mem {key comparedec elt}.
Arguments find {key comparedec elt}.
Arguments add {key comparedec elt}.
Arguments remove {key comparedec elt}.
Arguments insert {key comparedec elt}.
Arguments adjust {key comparedec elt}.
Arguments equal {key comparedec elt}.
Arguments fold {key comparedec elt A}.
Arguments elements {key comparedec elt}.
Arguments choose {key comparedec elt}.
Arguments map {key comparedec elt elt'}.
Arguments mapi {key comparedec elt elt'}.
Arguments map2 {key comparedec elt elt' elt''}.

(** Maps seen as an OrderedType : list comparison based
   solely on the first component. *)
Import OrderedTypeEx.
(* Definition map_eq `{OrderedType A} (B : Type) : relation (dict A B) := *)
(*   @list_eq (A*B) (asym_prod_eq B _eq). *)
(* Definition map_Equivalence `{OrderedType A} (B : Type) :  *)
(*   Equivalence (map_eq B) := @list_Equivalence (A*B) _ _. *)
(* Existing Instance map_Equivalence. *)

(* Goal forall n : dict nat Prop, n === n. *)
(* Abort. *)

(* Definition map_lt `{OrderedType A} (B : Type) : relation (dict A B) := *)
(*   @list_lt (A*B) (asym_prod_lt B _lt) (asym_prod_eq B _eq). *)
(* Definition map_StrictOrder `{OrderedType A} (B : Type) :  *)
(*   StrictOrder (map_lt B) (map_eq B) :=  *)
(*   @list_StrictOrder (A*B) (asym_prod_OrderedType _ B). *)
(* Existing Instance map_StrictOrder. *)

(* Goal forall n : dict nat Prop, n <<< n. *)
(* Abort. *)

(* Definition map_compare `{OrderedType A} (B : Type) :  *)
(*   dict A B -> dict A B -> comparison :=  *)
(*   @list_compare (A*B) (asym_prod_OrderedType _ B). *)
Definition map_OrderedType `{OrderedType A} (B : Type) :
  OrderedType (dict A B) :=
  @list_OrderedType (A*B) (asym_prod_OrderedType _ B).
Existing Instance map_OrderedType.

Set Implicit Arguments.
Unset Strict Implicit.

Module Import K := KeyOrderedType.
Section MapSpecs.
  Variable key : Type.
  Context `{key_OT : OrderedType key}.
  Variable elt : Type.

  Notation eqk := (eqk (elt:=elt)).
  Notation eqke := (eqke (elt:=elt)).
  Notation ltk := (ltk (elt:=elt)).
  Notation MapsTo := (MapsTo (elt:=elt)).
  Notation In := (In (elt:=elt)).
  Notation Sort := (sort ltk).
  Notation Inf := (lelistA (ltk)).

  Lemma empty_1 : Empty (elt:=elt) empty.
  Proof.
    intros a e.
    intro abs.
    inversion abs.
  Qed.
  Hint Resolve empty_1.

  Lemma empty_sorted : Sort empty.
  Proof.
    unfold empty; auto.
  Qed.

  Lemma is_empty_1 :forall m, Empty (elt:=elt) m -> is_empty m = true.
  Proof.
    intros m.
    case m;auto.
    intros (k,e) l inlist.
    absurd (InA eqke (k, e) ((k, e) :: l)).
    apply inlist. constructor; split; reflexivity.
  Qed.

  Lemma is_empty_2 : forall m, is_empty m = true -> Empty (elt:=elt) m.
  Proof.
    intros m.
    case m;auto.
    intros p l abs.
    inversion abs.
  Qed.

  Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
  Proof.
    intros m Hm x; generalize Hm; clear Hm.
    functional induction (mem x m);intros sorted belong1;trivial.

    inversion belong1. inversion H.

    absurd (In x ((k', _x) :: l));try assumption.
    apply Sort_Inf_NotIn with _x; auto.
    destruct (compare_dec x k'); try discriminate; eauto.

    apply IHb.
    elim (sort_inv sorted);auto.
    elim (In_inv belong1);auto.
    intro abs.
    destruct (compare_dec x k'); try discriminate; order.
  Qed.

  Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m.
  Proof.
    intros m Hm x; generalize Hm; clear Hm; unfold K.In, K.MapsTo.
    functional induction (mem x m); intros sorted hyp;
      try ((inversion hyp);fail);
        destruct (compare_dec x k'); try discriminate.
    exists _x; auto; constructor; split; auto.
    induction IHb; auto.
    exists x0; auto.
    inversion_clear sorted; auto.
  Qed.

  Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
  Proof.
    intros m x. unfold K.MapsTo.
    functional induction (find x m);simpl;intros e' eqfind;
      inversion eqfind; auto; destruct (compare_dec x k'); try discriminate.
    constructor; split; auto.
  Qed.

  Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e.
  Proof.
    intros m Hm x e; generalize Hm; clear Hm; unfold K.MapsTo.
    functional induction (find x m);simpl; subst; try clear H_eq_1.

    inversion 2.

    inversion_clear 2; destruct (compare_dec x k'); try discriminate.
    clear e1;compute in H0; destruct H0;order.
    clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.

    destruct (compare_dec x k'); try discriminate.
    clear e1;inversion_clear 2.
    compute in H1; destruct H1; intuition congruence.
    generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H1)); compute; order.

    destruct (compare_dec x k'); try discriminate.
    clear e1; do 2 inversion_clear 1; auto.
    compute in H3; destruct H3; order.
  Qed.

  Lemma add_1 : forall m (x y : key) e, x === y -> MapsTo y e (add x e m).
  Proof.
    intros m x y e; generalize y; clear y.
    unfold K.MapsTo.
    functional induction (add x e m); simpl.
    constructor; split; auto.
    constructor; split; auto.
    constructor; split; auto.
    destruct (compare_dec x k'); try discriminate; intuition.
  Qed.

  Lemma add_2 : forall m (x y : key) e e',
    x =/= y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof.
    intros m x  y e e'.
    generalize y e; clear y e; unfold K.MapsTo.
    functional induction (add x e' m); simpl; auto;
      destruct (compare_dec x k'); try discriminate; clear e0.

    intros y' e'' eqky'; inversion_clear 1; destruct H1; simpl in *.
    order.
    auto.
    auto.
    intros y' e'' eqky'; inversion_clear 1; intuition.
  Qed.

  Lemma add_3 : forall m (x y : key) e e',
    x =/= y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof.
    intros m x y e e'. generalize y e; clear y e; unfold K.MapsTo.
    functional induction (add x e' m); simpl; intros.
    apply (In_inv_3 H0); compute; auto.
    apply (In_inv_3 H0); compute; auto.
    constructor 2; apply (In_inv_3 H0); compute; auto.
    inversion_clear H0; auto.
  Qed.

  Lemma add_Inf : forall m(x x':key)(e e':elt),
    Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x'',e'').
    inversion_clear H.
    compute in H0,H1.
    simpl; destruct (compare_dec x x''); intuition.
  Qed.
  Hint Resolve add_Inf.

  Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x',e').
    simpl; destruct (compare_dec x x'); intuition; inversion_clear Hm; auto.
    constructor; auto.
    apply Inf_eq with (x',e'); auto.
  Qed.

  Lemma remove_1 : forall m (Hm:Sort m) x y, x === y -> ~ In y (remove x m).
  Proof.
    intros m Hm x y; generalize Hm; clear Hm.
    functional induction (remove x m); simpl; intros; subst;
      try (destruct (compare_dec x k'); try discriminate).

    red; inversion 1; inversion H1.

    apply Sort_Inf_NotIn with x0; auto.
    clear e0; constructor; compute; order.

    clear e0;inversion_clear Hm.
    apply Sort_Inf_NotIn with x0; auto.
    apply Inf_eq with (k',x0);auto; unfold K.eqk; transitivity x; auto.

    clear e0;inversion_clear Hm.
    assert (notin:~ In y (remove x l)) by auto.
    intros (x1,abs).
    inversion_clear abs.
    unfold K.eqk in H3; destruct H3; order.
    simpl in LT; order.
    apply notin; exists x1; auto.
  Qed.

  Lemma remove_2 : forall m (Hm:Sort m) x y e,
    x =/= y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof.
    intros m Hm x y e; generalize Hm; clear Hm; unfold K.MapsTo.
    functional induction (remove x m);subst;auto;
      match goal with
        | [H: compare ?x ?y = _ |- _ ] =>
          destruct (compare_dec x y); try discriminate; clear H
        | _ => idtac
      end.

    inversion_clear 3; auto.
    compute in H2; destruct H2; order.

    inversion_clear 1; inversion_clear 2; auto.
  Qed.

  Lemma remove_3 : forall m (Hm:Sort m) x y e,
    MapsTo y e (remove x m) -> MapsTo y e m.
  Proof.
    intros m Hm x y e; generalize Hm; clear Hm; unfold K.MapsTo.
    functional induction (remove x m);subst;auto.
    inversion_clear 1; inversion_clear 1; auto.
  Qed.

  Lemma remove_Inf : forall m(Hm : Sort m)(x x':key)(e':elt),
    Inf (x',e') m -> Inf (x',e') (remove x m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x'',e'').
    inversion_clear H.
    compute in H0.
    simpl; destruct (compare_dec x x''); intuition.
    inversion_clear Hm.
    apply Inf_lt with (x'',e''); auto.
  Qed.
  Hint Resolve remove_Inf.

  Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x',e').
    simpl; destruct (compare_dec x x'); intuition; inversion_clear Hm; auto.
  Qed.

  (** Extra insertion w/ combine functions *)
  Lemma insert_1 : forall m (Hm:Sort m) (x y : key) e d f,
    x === y -> MapsTo y e m -> MapsTo y (f e) (insert x d f m).
  Proof.
    intros m Hm x y e; generalize y; clear y.
    unfold K.MapsTo.
    functional induction (add x e m); simpl;
      try (intros; destruct (compare_dec x k'); try discriminate; clear e1).
    intros; inversion H0.
    inversion H0; subst.
    destruct H3; simpl in *; order.
    inversion Hm; subst.
    assert (HH  : k' <<< y0) by (exact (Sort_In_cons_1 Hm (InA_eqke_eqk H3))).
    order.
    inversion H0; subst.
    destruct H3; simpl in *; subst; constructor; split; auto.
    assert (HH  : k' <<< y0) by (exact (Sort_In_cons_1 Hm (InA_eqke_eqk H3))).
    order.
    inversion H0; subst.
    destruct H3; simpl in *; order.
    inversion Hm; auto.
  Qed.

  Lemma insert_2 : forall m (Hm:Sort m) (x y : key) d f,
    x === y -> ~ In y m -> MapsTo y d (insert x d f m).
  Proof.
    intros m Hm x y d f; generalize y; clear y.
    unfold K.MapsTo.
    functional induction (insert x d f m); simpl;
      try (intros; destruct (compare_dec x k'); try discriminate; clear e0).
    constructor; split; auto.
    constructor; split; auto.
    intros; contradiction H0; exists y; constructor; split; auto; simpl; order.
    inversion Hm; subst; constructor 2; apply IHd0; auto.
    intros [e He]; apply H0; exists e; right; auto.
  Qed.

  Lemma insert_3 : forall m (x y : key) e d f,
    x =/= y -> MapsTo y e m -> MapsTo y e (insert x d f m).
  Proof.
    intros m x y e d f.
    generalize y e; clear y e; unfold K.MapsTo.
    functional induction (insert x d f m); simpl; auto;
      destruct (compare_dec x k'); try discriminate; clear e0.

    intros y' e'' eqky'; inversion_clear 1; destruct H1; simpl in *.
    order.
    auto.
    auto.
    intros y' e'' eqky'; inversion_clear 1; intuition.
  Qed.

  Lemma insert_4 : forall m (x y : key) e d f,
    x =/= y -> MapsTo y e (insert x d f m) -> MapsTo y e m.
  Proof.
    intros m x y e d f. generalize y e; clear y e; unfold K.MapsTo.
    functional induction (insert x d f m); simpl; intros.
    apply (In_inv_3 H0); compute; auto.
    apply (In_inv_3 H0); compute; auto.
    constructor 2; apply (In_inv_3 H0); compute; auto.
    inversion_clear H0; auto.
  Qed.

  Lemma insert_Inf : forall m(x x':key) d f (e e':elt),
    Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (insert x d f m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x'',e'').
    inversion_clear H.
    compute in H0,H1.
    simpl; destruct (compare_dec x x''); intuition.
  Qed.
  Hint Resolve insert_Inf.

  Lemma insert_sorted : forall m (Hm:Sort m) x d f, Sort (insert x d f m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x',e').
    simpl; destruct (compare_dec x x'); intuition; inversion_clear Hm; auto.
    constructor; auto.
    apply Inf_eq with (x',e'); auto.
    constructor; auto.
    apply insert_Inf with d; auto.
  Qed.

  Lemma adjust_1 : forall m (Hm:Sort m) (x y : key) e f,
    x === y -> MapsTo y e m -> MapsTo y (f e) (adjust x f m).
  Proof.
    intros m Hm x y e; generalize y; clear y.
    unfold K.MapsTo.
    functional induction (add x e m); simpl;
      try (intros; destruct (compare_dec x k'); try discriminate; clear e1).
    intros; inversion H0.
    inversion H0; subst.
    destruct H3; simpl in *; order.
    inversion Hm; subst.
    assert (HH  : k' <<< y0) by (exact (Sort_In_cons_1 Hm (InA_eqke_eqk H3))).
    order.
    inversion H0; subst.
    destruct H3; simpl in *; subst; constructor; split; auto.
    assert (HH  : k' <<< y0) by (exact (Sort_In_cons_1 Hm (InA_eqke_eqk H3))).
    order.
    inversion H0; subst.
    destruct H3; simpl in *; order.
    inversion Hm; auto.
  Qed.

  Lemma adjust_2 : forall m (x y : key) e f,
    x =/= y -> MapsTo y e m -> MapsTo y e (adjust x f m).
  Proof.
    intros m x y e f.
    generalize y e; clear y e; unfold K.MapsTo.
    functional induction (adjust x f m); simpl; auto;
      destruct (compare_dec x k'); try discriminate; clear e0.

    intros y' e'' eqky'; inversion_clear 1; destruct H1; simpl in *.
    order.
    auto.
    auto.
    intros y' e'' eqky'; inversion_clear 1; intuition.
  Qed.

  Lemma adjust_3 : forall m (x y : key) e f,
    x =/= y -> MapsTo y e (adjust x f m) -> MapsTo y e m.
  Proof.
    intros m x y e f. generalize y e; clear y e; unfold K.MapsTo.
    functional induction (adjust x f m); simpl; intros; auto.
    constructor 2; apply (In_inv_3 H0); compute; auto.
    inversion_clear H0; auto.
  Qed.

  Lemma adjust_Inf : forall m(x x':key) f (e e':elt),
    Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (adjust x f m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x'',e'').
    inversion_clear H.
    compute in H0,H1.
    simpl; destruct (compare_dec x x''); intuition.
  Qed.
  Hint Resolve adjust_Inf.

  Lemma adjust_sorted : forall m (Hm:Sort m) x f, Sort (adjust x f m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x',e').
    simpl; destruct (compare_dec x x'); intuition; inversion_clear Hm; auto.
    constructor; auto.
    apply Inf_eq with (x',e'); auto.
    constructor; auto.
    apply adjust_Inf with e'; auto.
  Qed.

  Lemma elements_1 : forall m x e,
    MapsTo x e m -> InA eqke (x,e) (elements m).
  Proof.
    auto.
  Qed.

  Lemma elements_2 : forall m x e,
    InA eqke (x,e) (elements m) -> MapsTo x e m.
  Proof.
    auto.
  Qed.

  Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m).
  Proof.
    auto.
  Qed.

  Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m).
  Proof.
    intros.
    apply Sort_NoDupA.
    apply elements_3; auto.
  Qed.

  Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof.
    intros; functional induction (fold f m i); auto.
  Qed.

  Definition Equivb cmp m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).

  Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
    Equivb cmp m m' -> equal cmp m m' = true.
  Proof.
    intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
    functional induction (equal cmp m m'); simpl; subst; auto; unfold Equivb;
      intuition; subst.

    destruct (compare_dec x x') as [Hcomp|Hcomp|Hcomp];
      try discriminate; clear e2.
    apply IHb; auto.
    inversion_clear Hm; auto.
    inversion_clear Hm'; auto.
    unfold Equivb; intuition.
    destruct (H0 k).
    assert (In k ((x,e) ::l)).
    destruct H as (e'', hyp); exists e''; constructor 2; auto.
    destruct (In_inv (H2 H4)); auto.
    inversion_clear Hm.
    elim (Sort_Inf_NotIn H6 H7).
    destruct H as (e'', hyp); exists e''; auto.
    apply MapsTo_eq with k; auto; order.
    destruct (H0 k).
    assert (In k ((x',e') ::l')).
    destruct H as (e'', hyp); exists e''; constructor 2; auto.
    destruct (In_inv (H3 H4)); auto.
    inversion_clear Hm'.
    elim (Sort_Inf_NotIn H6 H7).
    destruct H as (e'', hyp); exists e''; auto.
    apply MapsTo_eq with k; auto; order.
    apply H1 with k; constructor 2; auto.

    destruct (compare_dec x x') as [Hcomp|Hcomp|Hcomp];
      try discriminate; clear e2.
    destruct (H0 x).
    assert (In x ((x',e')::l')).
    apply H; auto.
    exists e; constructor 1; split; auto.
    destruct (In_inv H3).
    rewrite <- e3, <- (H1 x e e'); auto; constructor 1; split; auto.
    inversion_clear Hm'.
    assert (Inf (x,e) l').
    apply Inf_eq with (x',e'); auto.
    elim (Sort_Inf_NotIn H5 H7 H4).

    destruct (compare_dec x x') as [Hcomp|Hcomp|Hcomp];
      try contradiction; clear y.
    destruct (H0 x).
    assert (In x ((x',e')::l')).
    apply H; auto.
    exists e; constructor 1; split; auto.
    destruct (In_inv H3).
    order.
    inversion_clear Hm'.
    assert (Inf (x,e) l').
    apply Inf_lt with (x',e'); auto.
    elim (Sort_Inf_NotIn H5 H7 H4).

    destruct (H0 x').
    assert (In x' ((x,e)::l)).
    apply H2; auto.
    exists e'; constructor 1; split; auto.
    destruct (In_inv H3).
    order.
    inversion_clear Hm.
    assert (Inf (x',e') l).
    apply Inf_lt with (x,e); auto.
    elim (Sort_Inf_NotIn H5 H7 H4).

    destruct m;
      destruct m';try contradiction.

    clear H1;destruct p as (k,e).
    destruct (H0 k).
    destruct H1.
    exists e; constructor; split; auto.
    inversion H1.

    destruct p as (x,e).
    destruct (H0 x).
    destruct H.
    exists e; constructor; split; auto.
    inversion H.

    destruct p;destruct p0;contradiction.
  Qed.

  Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp,
    equal cmp m m' = true -> Equivb cmp m m'.
  Proof.
    intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
    functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
      intuition; try discriminate; subst;
        try match goal with H: compare ?x ?y = _ |- _ =>
              destruct (compare_dec x y); try discriminate; clear H
            end.

    inversion H0.

    inversion_clear Hm;inversion_clear Hm'.
    destruct (IHb H2 H4 H).
    destruct (In_inv H0).
    exists e'; constructor; split; trivial; transitivity x; auto.
    destruct (H6 k).
    destruct (H9 H8) as (e'',hyp).
    exists e''; constructor 2; auto.

    inversion_clear Hm;inversion_clear Hm'.
    destruct (IHb H2 H4 H).
    destruct (In_inv H0).
    exists e; constructor; split; trivial; transitivity x'; auto.
    destruct (H6 k).
    destruct (H10 H8) as (e'',hyp).
    exists e''; constructor 2; auto.

    inversion_clear Hm;inversion_clear Hm'.
    destruct (IHb H3 H5 H).
    inversion_clear H0.
    destruct H9; simpl in *; subst.
    inversion_clear H1.
    destruct H9; simpl in *; subst; auto.
    elim (Sort_Inf_NotIn H5 H6).
    exists e'0; apply MapsTo_eq with k; auto; order.
    inversion_clear H1.
    destruct H0; simpl in *; subst; auto.
    elim (Sort_Inf_NotIn H3 H4).
    exists e0; apply MapsTo_eq with k; auto; order.
    apply H8 with k; auto.
  Qed.

  (** This lemma isn't part of the spec of [Equivb],
     but is used in [FMapAVL] *)
  Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
    eqk x y -> cmp (snd x) (snd y) = true ->
    (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
  Proof.
    intros.
    inversion H; subst.
    inversion H0; subst.
    destruct x; destruct y; compute in H1, H2.
    split; intros.
    apply equal_2; auto.
    simpl.
    destruct (compare_dec k k0); try solve [order].
    rewrite H2; simpl.
    apply equal_1; auto.
    apply equal_2; auto.
    generalize (equal_1 H H0 H3).
    simpl.
    destruct (compare_dec k k0); try solve [order].
    rewrite H2; simpl; auto.
  Qed.

End MapSpecs.

Section MapSpecs2.
  Variable key : Type.
  Context `{key_OT : OrderedType key}.
  Variables elt elt' : Type.

  Let t elt := dict key elt.

  (** Specification of [map] *)
  Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
    MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof.
    intros m x e f.
    (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
    induction m.
    inversion 1.

    destruct a as (x',e').
    simpl.
    inversion_clear 1.
    constructor 1.
    unfold eqke in *; simpl in *; intuition; subst; auto.
    constructor 2.
    unfold MapsTo in *; auto.
  Qed.

  Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
    In x (map f m) -> In x m.
  Proof.
    intros m x f.
    (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
    induction m; simpl.
    intros (e,abs).
    inversion abs.

    destruct a as (x',e).
    intros hyp.
    inversion hyp. clear hyp.
    inversion H; subst; rename x0 into e'.
    exists e; constructor.
    unfold eqke in *; simpl in *; intuition.
    destruct IHm as (e'',hyp).
    exists e'; auto.
    exists e''.
    constructor 2; auto.
  Qed.

  Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
    lelistA (ltk (elt:=elt)) (x,e) m ->
    lelistA (ltk (elt:=elt')) (x,e') (map f m).
  Proof.
    induction m; simpl; auto.
    intros.
    destruct a as (x0,e0).
    inversion_clear H; auto.
  Qed.

  Hint Resolve map_lelistA.

  Lemma map_sorted : forall (m: t elt)
    (Hm : sort (ltk (elt:=elt)) m)(f:elt -> elt'),
    sort (ltk (elt:=elt')) (map f m).
  Proof.
    induction m; simpl; auto.
    intros.
    destruct a as (x',e').
    inversion_clear Hm.
    constructor; auto.
    exact (map_lelistA _ _ H0).
  Qed.

  (** Specification of [mapi] *)

  Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
    MapsTo x e m ->
    exists y, y === x /\ MapsTo x (f y e) (mapi f m).
  Proof.
    intros m x e f.
    (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
    induction m.
    inversion 1.

    destruct a as (x',e').
    simpl.
    inversion_clear 1.
    exists x'.
    destruct H0; simpl in *.
    split; auto.
    constructor 1.
    unfold eqke in *; simpl in *; intuition; subst; auto.
    destruct IHm as (y, hyp); auto.
    exists y; intuition; constructor 2; auto.
  Qed.

  Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
    In x (mapi f m) -> In x m.
  Proof.
    intros m x f.
    (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
    induction m; simpl.
    intros (e,abs).
    inversion abs.

    destruct a as (x',e).
    intros hyp.
    inversion hyp. clear hyp.
    inversion H; subst; rename x0 into e'.
    exists e; constructor.
    unfold eqke in *; simpl in *; intuition.
    destruct IHm as (e'',hyp).
    exists e'; auto.
    exists e''.
    constructor 2; auto.
  Qed.

  Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
    lelistA (ltk (elt:=elt)) (x,e) m ->
    lelistA (ltk (elt:=elt')) (x,f x e) (mapi f m).
  Proof.
    induction m; simpl; auto.
    intros.
    destruct a as (x',e').
    inversion_clear H; auto.
  Qed.

  Hint Resolve mapi_lelistA.

  Lemma mapi_sorted : forall m (Hm : sort (ltk (elt:=elt)) m)
    (f: key ->elt -> elt'),
    sort (ltk (elt:=elt')) (mapi f m).
  Proof.
    induction m; simpl; auto.
    intros.
    destruct a as (x',e').
    inversion_clear Hm; auto.
  Qed.

End MapSpecs2.
Section MapSpecs3.
  Variable key : Type.
  Context `{key_OT : OrderedType key}.
  Variables elt elt' elt'' : Type.
  Variable f : option elt -> option elt' -> option elt''.

  Let t elt := dict key elt.

(** [map2] *)
  Notation oee' := (option elt * option elt')%type.
  Fixpoint combine (m : t elt) : t elt' -> t oee' :=
    match m with
      | nil => map (fun e' => (None,Some e'))
      | (k,e) :: l =>
        fix combine_aux (m':t elt') : list (key * oee') :=
        match m' with
          | nil => map (fun e => (Some e,None)) m
          | (k',e') :: l' =>
            match k =?= k' with
              | Lt => (k,(Some e, None))::combine l m'
              | Eq => (k,(Some e, Some e'))::combine l l'
              | Gt => (k',(None,Some e'))::combine_aux l'
            end
        end
    end.

  Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) :=
    List.fold_right (fun p => f (fst p) (snd p)) i l.

  Definition map2_alt m m' :=
    let m0 : t oee' := combine m m' in
      let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
        fold_right_pair (@option_cons key elt'') m1 nil.

  Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 f m m'.
  Proof.
    unfold map2_alt.
    induction m.
    simpl; auto; intros.
    (* map2_r *)
    induction m'; try destruct a; simpl; auto.
    rewrite IHm'; auto.
    (* fin map2_r *)
    induction m'; destruct a.
    simpl.
    (* map2_l *)
    clear IHm.
    match goal with |- option_cons _ _ _ ?X = option_cons _ _ _ ?Y =>
      cut (X = Y); [intro H; rewrite H; auto |]
    end.
    induction m; try destruct a; simpl; auto.
    rewrite IHm; auto.
    (* fin map2_l *)
    destruct a0.
    simpl.
    destruct (compare_dec k k0); simpl;
      match goal with |- option_cons _ _ _ ?X = option_cons _ _ _ ?Y =>
        cut (X = Y); [intro H2; rewrite H2; auto |]
      end.
    apply IHm.
    apply IHm.
    apply IHm'.
  Qed.

  Lemma combine_lelistA :
    forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
      lelistA (ltk (elt:=elt)) (x,e) m ->
      lelistA (ltk (elt:=elt')) (x,e') m' ->
      lelistA (ltk (elt:=oee')) (x,e'') (combine m m').
  Proof.
    induction m.
    intros.
    simpl.
    exact (map_lelistA _ _ H0).
    induction m'.
    intros.
    destruct a.
    replace (combine ((k, e0) :: m) nil) with
      (map (fun e => (Some e,None (A:=elt'))) ((k,e0)::m)); auto.
    exact (map_lelistA _ _ H).
    intros.
    simpl.
    destruct a as (k,e0); destruct a0 as (k',e0').
    destruct (compare_dec k k').
    inversion_clear H; auto.
    inversion_clear H; auto.
    inversion_clear H0; auto.
  Qed.
  Hint Resolve combine_lelistA.

  Lemma combine_sorted :
    forall m (Hm : sort (ltk (elt:=elt)) m) m'
      (Hm' : sort (ltk (elt:=elt')) m'),
      sort (ltk (elt:=oee')) (combine m m').
  Proof.
    induction m.
    intros; clear Hm.
    simpl.
    apply map_sorted; auto.
    induction m'.
    intros; clear Hm'.
    destruct a.
    replace (combine ((k, e) :: m) nil) with
      (map (fun e => (Some e,None (A:=elt'))) ((k,e)::m)); auto.
    apply map_sorted; auto.
    intros.
    simpl.
    destruct a as (k,e); destruct a0 as (k',e').
    destruct (compare_dec k k').
    inversion_clear Hm.
    constructor; auto.
    assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
    exact (combine_lelistA _ H1 H2).
    inversion_clear Hm; inversion_clear Hm'.
    constructor; auto.
    assert (lelistA (ltk (elt:=elt')) (k, e') m')
      by (apply Inf_eq with (k',e'); auto).
    exact (combine_lelistA _ H1 H4).
    inversion_clear Hm; inversion_clear Hm'.
    constructor; auto.
    change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
      (combine ((k,e)::m) m')).
    assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto.
    exact (combine_lelistA _  H4 H3).
  Qed.

  Lemma map2_sorted :
    forall m (Hm : sort (ltk (elt:=elt)) m)
      m' (Hm' : sort (ltk (elt:=elt')) m'),
      sort (ltk (elt:=elt'')) (map2 f m m').
  Proof.
    intros.
    rewrite <- map2_alt_equiv.
    unfold map2_alt.
    assert (H0:=combine_sorted Hm Hm').
    set (l0:=combine m m') in *; clearbody l0.
    set (f':= fun p : oee' => f (fst p) (snd p)).
    assert (H1:=map_sorted (elt' := option elt'') H0 f').
    set (l1:=map f' l0) in *; clearbody l1.
    clear f' f H0 l0 Hm Hm' m m'.
    induction l1.
    simpl; auto.
    inversion_clear H1.
    destruct a; destruct o; auto.
    simpl.
    constructor; auto.
    clear IHl1.
    induction l1.
    simpl; auto.
    destruct a; destruct o; simpl; auto.
    inversion_clear H0; auto.
    inversion_clear H0.
    red in H1; simpl in H1.
    inversion_clear H.
    apply IHl1; auto.
    apply Inf_lt with (k0, None (A:=elt'')); auto.
  Qed.

  Definition at_least_one (o:option elt)(o':option elt') :=
    match o, o' with
      | None, None => None
      | _, _  => Some (o,o')
    end.

  Lemma combine_1 :
    forall m (Hm : sort (ltk (elt:=elt)) m)
      m' (Hm' : sort (ltk (elt:=elt')) m') (x:key),
      find x (combine m m') = at_least_one (find x m) (find x m').
  Proof.
    induction m.
    intros.
    simpl.
    induction m'.
    intros; simpl; auto.
    simpl; destruct a.
    simpl; destruct (compare_dec x k); simpl; auto.
    inversion_clear Hm'; auto.
    induction m'.
    (* m' = nil *)
    intros; destruct a; simpl.
    destruct (compare_dec x k); simpl; auto.
    inversion_clear Hm; clear Hm' IHm.
    induction m; simpl; auto.
    inversion_clear H1.
    destruct a.
    simpl; destruct (compare_dec x k0); simpl; auto.
    apply IHm. inversion H0; auto.
    inversion H0; auto; subst. apply Inf_lt with (k0, e0); auto.
    (* m' <> nil *)
    intros.
    destruct a as (k,e); destruct a0 as (k',e'); simpl.
    inversion Hm; inversion Hm'; subst.
    destruct (compare_dec k k'); simpl; destruct (compare_dec x k); simpl; auto.
    destruct (compare_dec x k'); auto; solve [false_order].
    destruct (compare_dec x k'); auto; solve [false_order].
    destruct (compare_dec x k'); simpl; auto.
    rewrite IHm; auto; simpl; rewrite (elim_compare_lt H3); auto.
    rewrite IHm; auto; simpl; rewrite (elim_compare_eq H3); auto.
    rewrite IHm; auto; simpl; rewrite (elim_compare_gt H3); auto.

    destruct (compare_dec x k'); auto; solve [false_order].
    destruct (compare_dec x k'); auto; solve [false_order].
    destruct (compare_dec x k'); auto; solve [false_order].

    destruct (compare_dec x k'); simpl; auto.
    rewrite IHm'; simpl; auto; rewrite (elim_compare_lt H0); auto.
    destruct (compare_dec x k'); auto; try solve [false_order].
    rewrite IHm'; simpl; auto; rewrite (elim_compare_eq H0); auto.
    destruct (compare_dec x k'); auto; try solve [false_order].
    rewrite IHm'; simpl; auto; rewrite (elim_compare_gt H0); auto.
  Qed.

  Definition at_least_one_then_f (o:option elt)(o':option elt') :=
    match o, o' with
      | None, None => None
      | _, _  => f o o'
    end.

  Lemma map2_0 :
    forall m (Hm : sort (ltk (elt:=elt)) m)
      m' (Hm' : sort (ltk (elt:=elt')) m') (x:key),
      find x (map2 f m m') = at_least_one_then_f (find x m) (find x m').
  Proof.
    intros.
    rewrite <- map2_alt_equiv.
    unfold map2_alt.
    assert (H:=combine_1 Hm Hm' x).
    assert (H2:=combine_sorted Hm Hm').
    set (f':= fun p : oee' => f (fst p) (snd p)).
    set (m0 := combine m m') in *; clearbody m0.
    set (o:=find x m) in *; clearbody o.
    set (o':=find x m') in *; clearbody o'.
    clear Hm Hm' m m'.
    generalize H; clear H.
    match goal with |- ?m=?n -> ?p=?q =>
      assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
    induction m0; simpl in *; intuition.
    destruct o; destruct o'; simpl in *; try discriminate; auto.
    destruct a as (k,(oo,oo')); simpl in *.
    inversion_clear H2.
    destruct (compare_dec x k); simpl in *.
    (* x < k *)
    destruct (f' (oo,oo')); simpl.
    rewrite (elim_compare_lt H2).
    destruct o; destruct o'; simpl in *; try discriminate; auto.
    destruct (IHm0 H0) as (H3,_); apply H3; auto.
    rewrite <- H.
    case_eq (find x m0); intros; auto.
    assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
    red; auto.
    destruct (Sort_Inf_NotIn H0 (Inf_lt H5 H1)).
    exists p; apply find_2; auto.
    (* x = k *)
    assert (at_least_one_then_f o o' = f oo oo').
    destruct o; destruct o'; simpl in *; inversion_clear H; auto.
    rewrite H3.
    unfold f'; simpl.
    destruct (f oo oo'); simpl.
    rewrite (elim_compare_eq H2); auto.
    destruct (IHm0 H0) as (_,H4); apply H4; auto.
    case_eq (find x m0); intros; auto.
    assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
    red; auto.
    destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H6) H1)).
    exists p; apply find_2; auto.
    (* k < x *)
    unfold f'; simpl.
    destruct (f oo oo'); simpl.
    rewrite (elim_compare_gt H2); auto.
    destruct (IHm0 H0) as (H3,_); apply H3; auto.
    destruct (IHm0 H0) as (H3,_); apply H3; auto.

    (* None -> None *)
    destruct a as (k,(oo,oo')).
    simpl.
    inversion_clear H2.
    destruct (compare_dec x k).
    (* x < k *)
    unfold f'; simpl.
    destruct (f oo oo'); simpl.
    rewrite (elim_compare_lt H2); auto.
    destruct (IHm0 H0) as (_,H4); apply H4; auto.
    case_eq (find x m0); intros; auto.
    assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
    red; auto.
    destruct (Sort_Inf_NotIn H0 (Inf_lt H5 H1)).
    exists p; apply find_2; auto.
    (* x = k *)
    discriminate.
    (* k < x *)
    unfold f'; simpl.
    destruct (f oo oo'); simpl.
    rewrite (elim_compare_gt H2); auto.
    destruct (IHm0 H0) as (_,H4); apply H4; auto.
    destruct (IHm0 H0) as (_,H4); apply H4; auto.
  Qed.

  (** Specification of [map2] *)

  Lemma map2_1 :
    forall m (Hm : sort (ltk (elt:=elt)) m)
      m' (Hm' : sort (ltk (elt:=elt')) m')(x:key),
      In x m \/ In x m' ->
      find x (map2 f m m') = f (find x m) (find x m').
  Proof.
    intros.
    rewrite map2_0; auto.
    destruct H as [(e,H)|(e,H)].
    rewrite (find_1 Hm H).
    destruct (find x m'); simpl; auto.
    rewrite (find_1 Hm' H).
    destruct (find x m); simpl; auto.
  Qed.

  Lemma map2_2 :
    forall m (Hm : sort (ltk (elt:=elt)) m)
      m' (Hm' : sort (ltk (elt:=elt')) m')(x:key),
      In x (map2 f m m') -> In x m \/ In x m'.
  Proof.
    intros.
    destruct H as (e,H).
    generalize (map2_0 Hm Hm' x).
    rewrite (find_1 (map2_sorted Hm Hm') H).
    generalize (@find_2 _ _ _ m x).
    generalize (@find_2 _ _ _ m' x).
    destruct (find x m);
      destruct (find x m'); simpl; intros.
    left; exists e0; auto.
    left; exists e0; auto.
    right; exists e0; auto.
    discriminate.
  Qed.

End MapSpecs3.

End MapList.

Module M := MapList.

Structure dict (key : Type) `{OrderedType key} (elt : Type) := Build_dict {
  this :> M.dict key elt;
  sorted : sort (M.K.ltk (elt:=elt)) this
}.
Arguments this {key H elt}.
Arguments Build_dict {key H elt this}.
Arguments sorted {key H elt}.

Section MapDefinitions.
  Variable key : Type.
  Hypothesis (comparedec : OrderedType key).
  Variables elt elt' elt'' : Type.

  Let t elt := dict key elt.

  Implicit Type m : t elt.
  Implicit Types x y : key.
  Implicit Type e : elt.

  Definition empty : t elt := Build_dict (M.empty_sorted elt).
  Definition is_empty m : bool := M.is_empty m.(this).
  Definition mem x m : bool := M.mem x m.(this).
  Definition add x e m : t elt := Build_dict (M.add_sorted m.(sorted) x e).
  Definition find x m : option elt := M.find x m.(this).
  Definition remove x m : t elt := Build_dict (M.remove_sorted m.(sorted) x).
  Definition insert x d f m : t elt :=
    Build_dict (M.insert_sorted m.(sorted) x d f).
  Definition adjust x f m : t elt :=
    Build_dict (M.adjust_sorted m.(sorted) x f).
  Definition map f m : t elt' := Build_dict (M.map_sorted m.(sorted) f).
  Definition mapi (f:key->elt->elt') m : t elt' :=
    Build_dict (M.mapi_sorted m.(sorted) f).
  Definition map2 f m (m':t elt') : t elt'' :=
    Build_dict (M.map2_sorted f m.(sorted) m'.(sorted)).
  Definition elements m : list (key*elt) := @M.elements _ _ elt m.(this).
  Definition choose m : option (key*elt) := @M.choose _ _ elt m.(this).
  Definition cardinal m := length m.(this).
  Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A :=
    @M.fold _ _ elt A f m.(this) i.
  Definition equal cmp m m' : bool := @M.equal _ _ elt cmp m.(this) m'.(this).

  Definition MapsTo x e m : Prop := M.K.MapsTo x e m.(this).
  Definition In x m : Prop := M.K.In x m.(this).
  Definition Empty m : Prop := M.Empty m.(this).

  Definition Equal m m' := forall y, find y m = find y m'.
  Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb cmp m m' : Prop := @M.Equivb _ _ elt cmp m.(this) m'.(this).

  Definition eq_key : (key*elt) -> (key*elt) -> Prop := @M.K.eqk _ _ elt.
  Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @M.K.eqke _ _ elt.
  Definition lt_key : (key*elt) -> (key*elt) -> Prop := @M.K.ltk _ _ elt.

  (** Specs *)
  Lemma MapsTo_1 : forall m x y e, x === y -> MapsTo x e m -> MapsTo y e m.
  Proof. intros m; exact (@M.K.MapsTo_eq _ _ elt m.(this)). Qed.

  Lemma mem_1 : forall m x, In x m -> mem x m = true.
  Proof. intros m; exact (@M.mem_1 _ _ elt m.(this) m.(sorted)). Qed.
  Lemma mem_2 : forall m x, mem x m = true -> In x m.
  Proof. intros m; exact (@M.mem_2 _ _ elt m.(this) m.(sorted)). Qed.

  Lemma empty_1 : Empty empty.
  Proof. exact (@M.empty_1 _ _ elt). Qed.

  Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
  Proof. intros m; exact (@M.is_empty_1 _ _ elt m.(this)). Qed.
  Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
  Proof. intros m; exact (@M.is_empty_2 _ _ elt m.(this)). Qed.

  Lemma add_1 : forall m x y e, x === y -> MapsTo y e (add x e m).
  Proof. intros m; exact (@M.add_1 _ _ elt m.(this)). Qed.
  Lemma add_2 : forall m x y e e',
    x =/= y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof. intros m; exact (@M.add_2 _ _ elt m.(this)). Qed.
  Lemma add_3 : forall m x y e e',
    x =/= y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof. intros m; exact (@M.add_3 _ _ elt m.(this)). Qed.

  Lemma remove_1 : forall m x y, x === y -> ~ In y (remove x m).
  Proof. intros m; exact (@M.remove_1 _ _ elt m.(this) m.(sorted)). Qed.
  Lemma remove_2 : forall m x y e,
    x =/= y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof. intros m; exact (@M.remove_2 _ _ elt m.(this) m.(sorted)). Qed.
  Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
  Proof. intros m; exact (@M.remove_3 _ _ elt m.(this) m.(sorted)). Qed.

  Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
  Proof. intros m; exact (@M.find_1 _ _ elt m.(this) m.(sorted)). Qed.
  Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
  Proof. intros m; exact (@M.find_2 _ _ elt m.(this)). Qed.

  Lemma insert_1 : forall m x y e d f,
    x === y -> MapsTo y e m -> MapsTo y (f e) (insert x d f m).
  Proof. intros m; exact (M.insert_1 m.(sorted)). Qed.
  Lemma insert_2 : forall m x y d f,
    x === y -> ~ In y m -> MapsTo y d (insert x d f m).
  Proof. intros m; exact (M.insert_2 m.(sorted)). Qed.
  Lemma insert_3 : forall m x y e d f,
    x =/= y -> MapsTo y e m -> MapsTo y e (insert x d f m).
  Proof. intros m; exact (@M.insert_3 _ _ elt m.(this)). Qed.
  Lemma insert_4 : forall m x y e d f,
    x =/= y -> MapsTo y e (insert x d f m) -> MapsTo y e m.
  Proof. intros m; exact (@M.insert_4 _ _ elt m.(this)). Qed.

  Lemma adjust_1 : forall m x y e f,
    x === y -> MapsTo y e m -> MapsTo y (f e) (adjust x f m).
  Proof. intros m; exact (M.adjust_1 m.(sorted)). Qed.
  Lemma adjust_2 : forall m x y e f,
    x =/= y -> MapsTo y e m -> MapsTo y e (adjust x f m).
  Proof. intros m; exact (@M.adjust_2 _ _ elt m.(this)). Qed.
  Lemma adjust_3 : forall m x y e f,
    x =/= y -> MapsTo y e (adjust x f m) -> MapsTo y e m.
  Proof. intros m; exact (@M.adjust_3 _ _ elt m.(this)). Qed.

  Lemma elements_1 : forall m x e,
    MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof. intros m; exact (@M.elements_1 _ _ elt m.(this)). Qed.
  Lemma elements_2 : forall m x e,
    InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof. intros m; exact (@M.elements_2 _ _ elt m.(this)). Qed.
  Lemma elements_3 : forall m, sort lt_key (elements m).
  Proof. intros m; exact (@M.elements_3 _ _ elt m.(this) m.(sorted)). Qed.
  Lemma elements_3w : forall m, NoDupA eq_key (elements m).
  Proof. intros m; exact (@M.elements_3w _ _ elt m.(this) m.(sorted)). Qed.

  Lemma cardinal_1 : forall m, cardinal m = length (elements m).
  Proof. intros; reflexivity. Qed.

  Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
    fold A f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof. intros m; exact (@M.fold_1 _ _ elt m.(this)). Qed.

  Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
  Proof.
    intros m m';
      exact (@M.equal_1 _ _ elt m.(this) m.(sorted) m'.(this) m'.(sorted)).
  Qed.
  Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
  Proof.
    intros m m';
      exact (@M.equal_2 _ _ elt m.(this) m.(sorted) m'.(this) m'.(sorted)).
  Qed.

End MapDefinitions.
Section MoreDefinitions.
  Variable key : Type.
  Hypothesis (comparedec : OrderedType key).

  Let t elt := dict key elt.
  Implicit Types x y : key.

  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
    MapsTo _ _ _ x e m -> MapsTo _ _ _ x (f e) (map _ _ _ _ f m).
  Proof. intros elt elt' m; exact (@M.map_1 _ _ elt elt' m.(this)). Qed.
  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
    In _ _ _ x (map _ _ _ _ f m) -> In _ _ _ x m.
  Proof. intros elt elt' m; exact (@M.map_2 _ _ elt elt' m.(this)). Qed.

  Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
    (f:key->elt->elt'), MapsTo _ _ _ x e m ->
    exists y, y === x /\ MapsTo _ _ _ x (f y e) (mapi _ _ _ _ f m).
  Proof. intros elt elt' m; exact (@M.mapi_1 _ _ elt elt' m.(this)). Qed.
  Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
    (f:key->elt->elt'), In _ _ _ x (mapi _ _ _ _ f m) -> In _ _ _ x m.
  Proof. intros elt elt' m; exact (@M.mapi_2 _ _ elt elt' m.(this)). Qed.

  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In _ _ _ x m \/ In _ _ _ x m' ->
    find _ _ _ x (map2 _ _ _ _ _ f m m') = f (find _ _ _ x m) (find _ _ _ x m').
  Proof.
    intros elt elt' elt'' m m' x f;
      exact (@M.map2_1 _ _ elt elt' elt''
        f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
  Qed.
  Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In _ _ _ x (map2 _ _ _ _ _ f m m') -> In _ _ _ x m \/ In _ _ _ x m'.
  Proof.
    intros elt elt' elt'' m m' x f;
      exact (@M.map2_2 _ _ elt elt' elt''
        f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
  Qed.
End MoreDefinitions.

Import OrderedTypeEx.
(** A dictionary [key, elt] can be seen as an OrderedType if the type of elements
   is also an OrderedType (only the fact that [key] is an OrderedType is required
   to build the dictionary). In that case, the equality is standard pointwise
   equality on the lists (since they are sorted, it amounts to saying that two
   maps are equal iff equal keys map to equal data). *)

Definition map_eq `{OrderedType A, OrderedType B} : relation (dict A B) :=
  fun x y => @list_eq (A*B) (prod_eq _eq _eq) x.(this) y.(this).
Program Instance map_eq_Equivalence `{OrderedType A, OrderedType B} :
  Equivalence (@map_eq A _ B _).
Next Obligation.
  intro x; destruct x; unfold map_eq; simpl; reflexivity.
Qed.
Next Obligation.
  intros x y; destruct x; destruct y; unfold map_eq; simpl; symmetry; auto.
Qed.
Next Obligation.
  intros x y z; destruct x; destruct y; destruct z;
    unfold map_eq; simpl; transitivity this1; auto.
Qed.

Definition map_lt `{OrderedType A, OrderedType B} : relation (dict A B) :=
  fun x y => @list_lt (A*B)
    (prod_lt _eq _lt _lt) (prod_eq _eq _eq) x.(this) y.(this).
Program Instance map_lt_StrictOrder `{OA:OrderedType A, OB: OrderedType B} :
  StrictOrder (@map_lt A _ B _) (@map_eq A _ B _).
Next Obligation.
  intros x y z; destruct x; destruct y; destruct z; unfold map_lt; simpl.
  destruct (@list_StrictOrder (A*B) (prod_OrderedType _ _)).
  exact (@StrictOrder_Transitive this0 this1 this2).
Qed.
Next Obligation.
  destruct x; destruct y; unfold map_lt, map_eq in *; simpl in *.
  destruct (@list_StrictOrder (A*B) (prod_OrderedType _ _)).
  exact (@StrictOrder_Irreflexive this0 this1 H).
Qed.

(** The inferred equality [map_eq] corresponds to pointwise equality *)
Theorem map_eq_iff `{HA : OrderedType A, HB : OrderedType B} :
  forall m m', map_eq m m' <->
    MapInterface.Equal_kw
    (fun k v m => exists v', v === v' /\ MapsTo A _ B k v' m) m m'.
Proof.
  intros [m wfm] [m' wf'm].
  assert (cutsort : forall l (x a : A * B), sort KeyOrderedType.ltk l ->
    lelistA KeyOrderedType.ltk a l -> InA KeyOrderedType.eqke x l ->
    KeyOrderedType.ltk a x).
  apply SortA_InfA_InA.
  apply KeyOrderedType.eqke_Equiv.
  constructor; repeat intro; unfold KeyOrderedType.ltk in *; order.
  intros x x' [Hx Hx'] y y' [Hy Hy']; red; simpl in *; intros; subst.
  unfold KeyOrderedType.ltk; rewrite Hx, Hy; tauto.

  unfold map_eq, MapInterface.Equal_kw,
    MapsTo, KeyOrderedType.MapsTo; simpl.
  revert m' wf'm; induction m; intros; destruct m'.
  split; intro. intros; reflexivity. constructor.
  split; intro. inversion H.
  destruct p as [k' v']; assert (H' := H k' v'); clear H; simpl in H'.
  destruct (proj2 H') as [? [_ abs]]; [|inversion abs].
  exists v'; split; [reflexivity | left; auto].
  (* -> *)
  split; intro. inversion H.
  destruct a as [k' v']; assert (H' := H k' v'); clear H; simpl in H'.
  destruct (proj1 H') as [? [_ abs]]; [|inversion abs].
  exists v'; split; [reflexivity | left; auto].
  inversion_clear wfm; inversion_clear wf'm.
  split; intro.
  inversion H3; subst; clear H3.
  destruct a as [k v]; intros k' v'.
  inversion H7; subst; clear H7.
  rewrite (IHm H _ H1) in H9; clear IHm H H1.
  split; intros [v'' [Hv'' HIn]].
  inversion HIn; subst; clear HIn.
  inversion_clear H1; simpl in *; subst; exists d; split; auto.
  transitivity v; assumption.
  left; constructor; auto. transitivity k; assumption.
  destruct (proj1 (H9 k' v'')); [exists v''; split; auto|].
  exists x; split; intuition. transitivity v''; assumption.
  inversion HIn; subst; clear HIn.
  inversion_clear H1; simpl in *; subst; exists v; split; auto.
  transitivity d; auto.
  left; constructor; auto. transitivity c; auto.
  destruct (proj2 (H9 k' v'')); [exists v''; split; auto|].
  exists x; split; intuition. transitivity v''; auto.
  (* <- *)
  destruct a as [k v]; destruct p as [a b].
  assert (Hcut : k === a /\ v === b).
  destruct (proj1 (H3 k v)) as [k'' [Heq'' Hin'']]; [exists v; split; auto|].
  inversion Hin''; subst; clear Hin''.
  inversion_clear H5; simpl in *; subst. constructor; auto.
  destruct (proj2 (H3 a b)) as [a' [Heq' Hin']]; [exists b; split; auto|].
  inversion Hin'; subst; clear Hin'.
  inversion_clear H6; simpl in *; subst; constructor; auto.
  assert (R := cutsort _ _ _ H H0 H6).
  assert (R' := cutsort _ _ _ H1 H2 H5).
  compute in R, R'. contradiction (lt_not_gt R R').

  constructor.
  constructor; destruct Hcut; auto.
  rewrite IHm by assumption.
  intros g h; split; intros [h' [Hh' Hinh']].
  destruct (proj1 (H3 g h')) as [h'' [Hh'' Hinh'']]; [exists h'; split; auto|].
  inversion Hinh''; auto; subst.
  2:(exists h''; split; [transitivity h'; assumption | auto]).
  inversion_clear H5; simpl in *; subst.
  assert (R := cutsort _ _ _ H H0 Hinh').
  compute in R; rewrite H4 in R; contradiction (lt_not_eq R (proj1 Hcut)).
  destruct (proj2 (H3 g h')) as [h'' [Hh'' Hinh'']]; [exists h'; split; auto|].
  inversion Hinh''; auto; subst.
  2:(exists h''; split; [transitivity h'; assumption | auto]).
  inversion_clear H5; simpl in *; subst.
  assert (R := cutsort _ _ _ H1 H2 Hinh').
  compute in R; rewrite H4 in R; contradiction (lt_not_eq R).
  symmetry; exact (proj1 Hcut).
Qed.

Definition map_cmp `{OrderedType A, OrderedType B} :=
  fun x y => @list_compare (A*B) (prod_OrderedType _ _) x.(this) y.(this).
Lemma map_cmp_spec `{OrderedType A, OrderedType B} :
  forall (x y : dict A B), compare_spec map_eq map_lt x y (map_cmp x y).
Proof.
  destruct x; destruct y; unfold map_cmp; simpl.
  set (C := @list_OrderedType (A*B) (prod_OrderedType _ _)).
  change (compare_spec map_eq map_lt
    (Build_dict sorted0) (Build_dict sorted1)
    (@compare (M.dict A B) C this0 this1)).
  destruct (compare_dec this0 this1); constructor; auto.
Qed.

Program Instance map_OrderedType `{OrderedType A, OrderedType B}
  : OrderedType (dict A B) := {
    _eq := @map_eq A _ B _;
    _lt := @map_lt A _ B _;
    _cmp := @map_cmp A _ B _;
    OT_Equivalence := map_eq_Equivalence;
    OT_StrictOrder := map_lt_StrictOrder
}.
Next Obligation.
  destruct x; destruct y; unfold map_cmp; simpl.
  set (C := @list_OrderedType (A*B) (prod_OrderedType _ _)).
  change (compare_spec map_eq map_lt
    (Build_dict sorted0) (Build_dict sorted1)
    (@compare (M.dict A B) C this0 this1)).
  destruct (compare_dec this0 this1); constructor; auto.
Qed.

Program Instance map_SpecificOrderedType `{OrderedType A, OrderedType B}
  : SpecificOrderedType _ (MapInterface.Equal_kw
    (fun k v m => exists v', v === v' /\ MapsTo A _ B k v' m)) := {
    SOT_Equivalence := MapInterface.Equal_kw_Equivalence _;
    SOT_lt := @map_lt A H B H0;
    SOT_cmp := @map_cmp A H B H0
  }.
Next Obligation.
  destruct (map_lt_StrictOrder (A:=A)).
  constructor.
  exact StrictOrder_Transitive.
  repeat intro; refine (StrictOrder_Irreflexive x y H1 _).
  change (map_eq x y). rewrite map_eq_iff. exact H2.
Qed.
Next Obligation.
  destruct (map_cmp_spec (B:=B) x y); constructor; auto.
  rewrite <- map_eq_iff; assumption.
Qed.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : extension for Coq.Reals.
  author    : ZhengPu Shi
  date      : 2021.05

  remark    :
  1. possible reason of "field" failure
    a. notation "/", need unfold Rdiv first.
    b. unknown variable name, need be rewrite first.
  2. why need this library?
    (1). lots of properties are lack in standard library.
    (2). more automation, especially inequality.
    (3). We want to solve any problem of equality or inequality in one step.
  3. why auto fail? and how to better naming a term?
    (1). use two lemmas like A -> B and B -> A instead of A <-> B
    (2). x * x and x² are mixed, and x² is defined as x * x, and Coq Standard
      Library prefer x², so we'd better choose x². But, notice that we should
      rewrie x² to x * x before using ring or field, it's a bit annoying.
    (3). 1 and R1 are mixed, and 1 is (IZR (Zpos xH)), and will be reduced to R1
      finally, and Coq Standard Library prefer 1, so we choose 1 as well.
    (4). x - y and x + (-y) is same, but we prefer x - y.
    (5). x / y and x * (-y), we prefer x / y as well.
*)

Require Export BasicConfig.

Require Export ZExt.
Require Export Reals.
Open Scope R_scope.

Require Export Psatz.
Require Export Lra.

(* ######################################################################### *)
(** * Comparison with PI *)

(** 如何证明有关 PI 的不等式？可否先构造PI的一个区间？*)
Goal 2 < PI.
Proof.
  Abort.

(** upper bound & lower bound of PI *)
Definition PI_ub : R := 3.14159266.
Definition PI_lb : R := 3.14159265.
Axiom PI_lt : PI < PI_ub.
Axiom PI_gt : PI_lb < PI.

Goal 2 < PI.
Proof.
  apply Rlt_trans with PI_lb; unfold PI_lb,PI_ub;
  try lra; try apply PI_lt; try apply PI_gt.
Qed.

(* ######################################################################### *)
(** * Conversion between R and other types *)
Definition Z2R (z : Z) : R := IZR z.
Definition R2Z_floor (r : R) : Z := (up r).
Definition R2Z_ceiling (r : R) : Z := (up r - 1)%Z.

(** 该引理的使用常常需要显式提供 z，取值为 r 的地板 *)
Lemma R2Z_floor_correct : forall (r:R) (z:Z),
  IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = R2Z_floor r.
Proof. apply up_tech. Qed.

(** 该引理的使用常常需要显式提供 z，取值为 r 的地板 *)
Lemma R2Z_ceiling_correct : forall (r:R) (z:Z),
  IZR z <= r -> r < IZR (z + 1) -> z = R2Z_ceiling r.
Proof.
  intros. apply up_tech in H; auto.
  unfold R2Z_ceiling. rewrite <- H. auto with zarith.
Qed.

Definition nat2R (n : nat) : R := Z2R (nat2Z n).
Definition R2nat_floor (r : R) : nat := Z2nat (R2Z_floor r).
Definition R2nat_ceiling (r : R) : nat := Z2nat (R2Z_ceiling r).

(* ######################################################################### *)
(** * Properties for Reqb and Req *)

Definition Reqb (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 then true else false.

Infix     "=?"          := Reqb           : R_scope.

(** Reflection of (=) and (=?) *)
Lemma Reqb_true_iff : forall x y, x =? y = true <-> x = y.
Proof.
  intros r1 r2. split; unfold Reqb; intros; destruct Req_EM_T; try easy.
Qed.

Lemma Reqb_false_iff : forall x y, x =? y = false <-> x <> y.
Proof.
  intros r1 r2. split; unfold Reqb; intros; destruct Req_EM_T; try easy.
Qed.

(* ######################################################################### *)
(** * Boolean comparison of R *)

Definition Rleb (r1 r2 : R) : bool :=
  if Rle_lt_dec r1 r2 then true else false.
Infix "<=?" := (Rleb) : R_scope.

Definition Rltb (r1 r2 : R) : bool :=
  if Rlt_le_dec r1 r2 then true else false.
Infix "<?" := (Rltb) : R_scope.

Lemma Reqb_comm : forall r1 r2, (r1 =? r2) = (r2 =? r1).
Proof.
  intros r1 r2. unfold Reqb.
  destruct (Req_EM_T r1 r2), (Req_EM_T r2 r1); auto. subst. easy.
Qed.

Lemma Reqb_true_refl : forall r, r =? r = true.
Proof. intros. unfold Reqb. destruct Req_EM_T; auto. Qed.

Lemma Reqb_trans : forall r1 r2 r3, r1 =? r2 = true ->
  r2 =? r3 = true -> r1 =? r3 = true.
Proof.
  intros. apply Reqb_true_iff in H,H0. apply Reqb_true_iff. rewrite H,H0. easy.
Qed.

(* ######################################################################### *)
(** * Other properties *)

(* ==================================== *)
(** ** Extend properties of R *)

(* 参考以下两个引理，给出变形的形式 :
Rmult_eq_reg_l: forall r r1 r2 : R, r * r1 = r * r2 -> r <> 0 -> r1 = r2
Rmult_eq_reg_r: forall r r1 r2 : R, r1 * r = r2 * r -> r <> 0 -> r1 = r2
*)

(* 若k左乘两个数相等，但这两个数不相等，则k必为 0 *)
Lemma Rmult_eq_imply_eq0_l : forall r r1 r2 : R,
  r * r1 = r * r2 -> r1 <> r2 -> r = 0.
Proof.
  intros.
  (* 转换到 r1 = r2 的证明 *)
  destruct (Req_EM_T r 0); auto. destruct H0.
  apply (Rmult_eq_reg_l r); auto.
Qed.

(* 若k右乘两个数相等，但这两个数不相等，则k必为 0 *)
Lemma Rmult_eq_imply_eq0_r : forall r r1 r2 : R,
  r1 * r = r2 * r -> r1 <> r2 -> r = 0.
Proof.
  intros.
  (* 转换到 r1 = r2 的证明 *)
  destruct (Req_EM_T r 0); auto. destruct H0.
  apply (Rmult_eq_reg_r r); auto.
Qed.

(** 若 k 被等于自身，则要么自身为0，要么自身不为0但k必为1 *)
Lemma Rmult_eq_self_imply_0_or_k1 :
  forall k, (forall x, k * x = x -> x = 0 \/ (x <> 0 /\ k = R1)).
Proof.
  intros.
  destruct (Req_EM_T x 0); auto. right. split; auto.
  (* 库里有 a * x = b * x 类似的结论，所以利用1来构造 *)
  replace x with (R1*x) in H at 2; try ring.
  apply Rmult_eq_reg_r in H; auto.
Qed.

(* ==================================== *)
(** ** Extend Hint database with name R *)

(** autounfold is usually used before the ring tactic *)
Global Hint Unfold
  Rminus        (* a - b = a + - b *)
  Rdiv          (* a / b = a * / b *)
  Rsqr          (* r² = r * r *)
  : R.

Global Hint Rewrite
  pow1                (* 1 ^ n = 1 *)
  pow_O               (* x ^ 0 = 1 *)
  pow_1               (* x ^ 1 = x *)
  Ropp_0              (* - 0 = 0 *)
  Rminus_0_r          (* r - 0 = r *)
  Rplus_0_l           (* 0 + r = r *)
  Rplus_0_r           (* r + 0 = r *)
  Rmult_0_l           (* 0 * r = 0 *)
  Rmult_0_r           (* r * 0 = 0 *)
  Rmult_1_l           (* 1 * r = r *)
  Rmult_1_r           (* r * 1 = r *)
  Ropp_involutive     (* - - r = r *)
  Rsqr_mult           (* (x * y)² = x² * y² *)
  Rsqr_sqrt           (* 0 <= x -> (sqrt x)² = x *)
  sqrt_Rsqr           (* 0 <= x -> sqrt x² = x *)
  Rplus_opp_r         (* r + - r = 0 *)
  Rplus_opp_l         (* - r + r = 0 *)
(*   Ropp_mult_distr_r_reverse     (* r1 * - r2 = - (r1 * r2) *) *)
(*   Ropp_mult_distr_l_reverse     (* - r1 * r2 = - (r1 * r2) *) *)
  : R.

Global Hint Resolve
  sqrt_0              (* sqrt 0 = 0 *)
  Rlt_0_1             (* 0 < 1 *)
  PI_RGT_0            (* PI > 0 *)
  sqrt_pos            (* 0 <= sqrt x *)
  Rle_0_sqr           (* 0 <= r² *)
(*   Rsqr_inj            (* 0 <= x -> 0 <= y -> x² = y² -> x = y *) *)
  sin2_cos2           (* (sin x)² + (cos x)² = 1 *)
  Rplus_le_le_0_compat  (* 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2 *)
  Rplus_lt_le_0_compat  (* 0 < r1 -> 0 <= r2 -> 0 < r1 + r2 *)
  Rplus_le_lt_0_compat  (* 0 <= r1 -> 0 < r2 -> 0 < r1 + r2 *)
  Rplus_lt_0_compat   (* 0 < r1 -> 0 < r2 -> 0 < r1 + r2 *)
  Rmult_lt_0_compat   (* 0 < r1 -> 0 < r2 -> 0 < r1 * r2 *)
  Rinv_0_lt_compat    (* 0 < r -> 0 < / r *)
  Rlt_gt              (* r1 < r2 -> r2 > r1 *)  (* THIS IS ALWAYS NEED! *)
  Rgt_lt              (* r1 > r2 -> r2 < r1 *)  (* THIS ONE, slow but useful *)
  Rgt_not_eq          (* r1 > r2 -> r1 <> r2 *)
  Rge_le              (* r1 >= r2 -> r2 <= r1 *)
  Rle_ge              (* r1 <= r2 -> r2 >= r1 *)
  Rsqr_eq_0           (* x² = 0 -> x = 0 *)
  Rlt_le              (* r1 < r2 -> r1 <= r2 *)
  Rsqr_pos_lt         (* x <> 0 -> 0 < x² *)
  Rlt_not_eq          (* r1 < r2 -> r1 <> r2 *)
  Rgt_not_eq          (* r1 > r2 -> r1 <> r2 *)
(*   sqrt_sqrt           (* 0 <= x -> sqrt x * sqrt x = x *) *)
  Rsqr_sqrt           (* 0 <= x -> (sqrt x)² = x *)
  sqrt_Rsqr           (* 0 <= x -> sqrt x² = x *)
  : R.

(** ** Control Opaque / Transparent *)
Global Opaque
  PI
  sqrt
  Rpower
  sin
  cos
  tan
  asin
  atan
  acos.

(* ==================================== *)
(** ** Equality of R *)

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

(** We always prefer x², an exception is when using ring or field tactic. *)
Lemma xx_Rsqr x : x * x = x².
Proof. auto. Qed.

(** So, there are two typical situations:
<<
  autounfold with R; ring.    (* for ring *)
  autorewrite with xx_Rsqr; auto with R.    (* for auto *)
>>
*)
Global Hint Rewrite xx_Rsqr : R.

(* --------------------------------------------------------------------- *)
(** *** R1 and 1 *)

(** We always prefer 1 *)
Lemma R1_eq_1 : R1 = 1.
Proof. auto. Qed.
Global Hint Rewrite R1_eq_1 : R.

Lemma Rsqr_1 : 1² = 1.
Proof. unfold Rsqr; ring. Qed.
Global Hint Rewrite Rsqr_1 : R.
Global Hint Resolve Rsqr_1 : R.

Lemma Rinv_1 : /1 = 1.
Proof. auto with real. Qed.
Global Hint Rewrite Rinv_1 : R.
Global Hint Resolve Rinv_1 : R.

Lemma zero_le_1 : 0 <= 1.
Proof. auto with real. Qed.
Global Hint Resolve zero_le_1 : R.

Lemma zero_neq_1 : 0 <> 1.
Proof. auto with real. Qed.
Global Hint Resolve zero_neq_1 : R.

Module TEST_R1_and_1.
  Goal 1 = R1. auto with R. Qed.
  Goal R1² = 1. auto with R. Qed.
  Goal 1² = R1. auto with R. Qed.
  Goal /R1 = R1. auto with R. Qed.
  Goal /R1 = 1. auto with R. Qed.
  Goal /1 = R1. auto with R. Qed.
  Goal 0 <= R1. auto with R. Qed.

End TEST_R1_and_1.

(* ==================================== *)
(** ** Rplus, Rpop, Rsub, Rmult, Rinv, Rdiv *)

Lemma Rsub_opp r1 r2 : r1 - (- r2) = r1 + r2.
Proof. ring. Qed.
Global Hint Rewrite Rsub_opp : R.

(** ** Rsqrt *)
Lemma sqrt_1 : sqrt 1 = 1.
Proof. apply Rsqr_inj; autorewrite with R; auto with R. Qed.
Global Hint Rewrite sqrt_1 : R.

Lemma sqrt_le0_eq_0 r (H : r <= 0) : sqrt r = 0.
Proof.
  Transparent sqrt. unfold sqrt. destruct (Rcase_abs r); auto.
  assert (r = 0); try lra. subst. compute.
  destruct (Rsqrt_exists). destruct a.
  symmetry in H1. auto with R.
Qed.
Global Hint Resolve sqrt_le0_eq_0 : R.

Lemma sqrt_lt0_eq_0 r (H : r < 0) : sqrt r = 0.
Proof. apply sqrt_le0_eq_0. auto with R. Qed.
Global Hint Resolve sqrt_lt0_eq_0 : R.

Lemma le0_imply_sqrt_eq0 : forall (x : R), x < 0 -> sqrt x = 0.
Proof.
  intros. Transparent sqrt. unfold sqrt. destruct (Rcase_abs x). auto.
  (* although, x < 0, x >= 0, all appear, lra fail to solve it. *)
  exfalso. lra.
Qed.
Global Hint Resolve le0_imply_sqrt_eq0 : R.

Lemma sqrt_gt0_imply_gt0 : forall (x : R), 0 < sqrt x -> 0 < x.
Proof.
  intros. replace 0 with (sqrt 0) in H; auto with R.
  apply sqrt_lt_0_alt in H. auto.
Qed.
Global Hint Resolve sqrt_gt0_imply_gt0 : R.

Lemma sqrt_gt0_imply_ge0 : forall (x : R), 0 < sqrt x -> 0 <= x.
Proof. intros. auto with R. Qed.
Global Hint Resolve sqrt_gt0_imply_ge0 : R.

Lemma sqrt_eq1_imply_eq1 : forall (x : R), sqrt x = 1 -> x = 1.
Proof.
  intros.
  assert ((sqrt x)² = 1). rewrite H. autounfold with R in *; ring.
  rewrite <- H0.
  apply eq_sym. apply Rsqr_sqrt.
  assert (0 < sqrt x). rewrite H; auto with R.
  apply sqrt_gt0_imply_gt0 in H1. auto with R.
Qed.
Global Hint Resolve sqrt_eq1_imply_eq1 : R.

(** ( √ r1 * √ r2)^2 = r1 * r2 *)
Lemma Rsqr_sqrt_sqrt r1 r2 : 0 <= r1 -> 0 <= r2 ->
  ((sqrt r1) * (sqrt r2))² = r1 * r2.
Proof.
  destruct (Rcase_abs r1), (Rcase_abs r2); try lra.
  autorewrite with R; auto with R.
Qed.
Global Hint Resolve Rsqr_sqrt_sqrt : R.
Global Hint Rewrite Rsqr_sqrt_sqrt : R.

(** ( √ r1 * √ r2)^2 = r1 * r2 *)
Lemma sqrt_mult_sqrt : forall (r1 r2 : R),
  0 <= r1 -> 0 <= r2 ->
  ((sqrt r1) * (sqrt r2)) * ((sqrt r1) * (sqrt r2)) = r1 * r2.
Proof.
  intros. ring_simplify. repeat rewrite pow2_sqrt; auto.
Qed.
Global Hint Resolve sqrt_mult_sqrt : R.
Global Hint Rewrite sqrt_mult_sqrt : R.

Module TEST_Rsqrt.
  Goal sqrt R1 = R1. autorewrite with R; auto with R. Qed.

End TEST_Rsqrt.

(* ==================================== *)
(** ** sin,cos,tan *)
Lemma cos2_sin2 x : (cos x)² + (sin x)² = 1.
Proof. rewrite Rplus_comm; auto with R. Qed.
Global Hint Resolve cos2_sin2 : R.
Global Hint Rewrite cos2_sin2 : R.

Module TEST_sin_cos_tan.
  Goal forall x, cos x * cos x + sin x * sin x = R1.
  intros; autorewrite with R; auto with R. Qed.

  Goal forall x, sin x * sin x + cos x * cos x = R1.
  intros; autorewrite with R; auto with R. Qed.

End TEST_sin_cos_tan.

(* ==================================== *)
(** ** Rpower *)

(**
Rpower rules:
<<
  1. Definition of Rpower
  a^n       = a * a * ... * a    (* there are n numbers *)
  a^0       = 1 (a ≠ 0)
  a^(-n)    = 1 / a^n (a ≠ 0)
  a^(m/n)   = n√ a^m  (a > 0)
  a^(-m/n)  = 1 / n√ a^m  (a > 0)
>>
*)
Lemma Rpower_neq0 x y : x <> 0 -> Rpower x y <> 0.
Proof.
  Admitted.

(* ==================================== *)
(** ** Inequality of R *)

(** ** x = 0 *)

Lemma Req0_imply_Rsqr_eq0 r : r = 0 -> r² = 0.
Proof. intros. subst; unfold Rsqr; ring. Qed.
Global Hint Resolve Req0_imply_Rsqr_eq0 : R.

(* Lemma Rsqr_eq0_iff_eq0 r : r² = 0 <-> r = 0.
Proof. split; auto with R. Qed.
Global Hint Resolve Rsqr_eq0_iff_eq0 : R. *)

(* ==================================== *)
(** ** 0 <= x *)

Lemma zero_le_Rsqr r : 0 <= r².
Proof. auto with R. Qed.
Global Hint Resolve zero_le_Rsqr : R.

Lemma Rplus_Rsqr_Rsqr_ge0 r1 r2 : 0 <= r1² + r2².
Proof. auto with R. Qed.
Global Hint Resolve Rplus_Rsqr_Rsqr_ge0 : R.

Ltac tac_zero_le :=
  intros; autorewrite with R;
  repeat (match goal with
  | |- 0 <= ?r1 * ?r2 => apply Rmult_le_pos
  | |- _ => idtac
  end;
  auto with R; try lra).

Module TEST_zero_le.

  Goal forall r, 0 <= r * r. tac_zero_le. Qed.
  Goal forall r, 0 <= r². tac_zero_le. Qed.
  Goal forall r1 r2, 0 <= r1 * r1 + r2 * r2. tac_zero_le. Qed.
  Goal forall r1 r2, 0 <= r1² + r2². tac_zero_le. Qed.
  Goal forall r1 r2, 0 <= r1 * r1 + r2². tac_zero_le. Qed.
  Goal forall r1 r2, 0 <= r1² + r2 * r2. tac_zero_le. Qed.
  Goal forall r, 0 <= r -> 0 <= r * 5. tac_zero_le. Qed.
  Goal forall r, 0 <= r -> 0 <= r * 5 * 10. tac_zero_le. Qed.
  Goal forall r, 0 <= r -> 0 <= r * (/5) * 10. tac_zero_le. Qed.

End TEST_zero_le.

(* ==================================== *)
(** ** 0 < x *)

Lemma Rneq0_imply_Rplus_gt0_2_1 r1 r2 : r1 <> 0 -> 0 < r1² + r2².
Proof. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_gt0_2_1 : R.

Lemma Rneq0_imply_Rplus_gt0_2_2 r1 r2 : r2 <> 0 -> 0 < r1² + r2².
Proof. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_gt0_2_2 : R.

Lemma Rneq0_imply_Rplus_gt0_3_1 r1 r2 r3 : r1 <> 0 -> 0 < r1² + r2² + r3².
Proof. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_gt0_3_1 : R.

Lemma Rneq0_imply_Rplus_gt0_3_2 r1 r2 r3 : r2 <> 0 -> 0 < r1² + r2² + r3².
Proof. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_gt0_3_2 : R.

Lemma Rneq0_imply_Rplus_gt0_3_3 r1 r2 r3 : r3 <> 0 -> 0 < r1² + r2² + r3².
Proof. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_gt0_3_3 : R.

Lemma Rgt0_imply_Rplus_gt0_2_1 r1 r2 : 0 < r1 -> 0 < r1² + r2².
Proof. auto with R. Qed.
Global Hint Resolve Rgt0_imply_Rplus_gt0_2_1 : R.

Lemma Rgt0_imply_Rplus_gt0_2_2 r1 r2 : 0 < r2 -> 0 < r1² + r2².
Proof. auto with R. Qed.
Global Hint Resolve Rgt0_imply_Rplus_gt0_2_2 : R.

Lemma Rgt0_imply_Rplus_gt0_3_1 r1 r2 r3 : 0 < r1 -> 0 < r1² + r2² + r3².
Proof. auto with R. Qed.
Global Hint Resolve Rgt0_imply_Rplus_gt0_3_1 : R.

Lemma Rgt0_imply_Rplus_gt0_3_2 r1 r2 r3 : 0 < r2 -> 0 < r1² + r2² + r3².
Proof. auto with R. Qed.
Global Hint Resolve Rgt0_imply_Rplus_gt0_3_2 : R.

Lemma Rgt0_imply_Rplus_gt0_3_3 r1 r2 r3 : 0 < r3 -> 0 < r1² + r2² + r3².
Proof. auto with R. Qed.
Global Hint Resolve Rgt0_imply_Rplus_gt0_3_3 : R.

(** Some times, auto cannot solve, we need customized tactic *)
Ltac tac_zero_lt :=
  intros; autorewrite with R;
  match goal with
  | H : ?r1 <> 0 |- 0 < ?r1² + ?r2² => apply Rneq0_imply_Rplus_gt0_2_1
  | H : ?r2 <> 0 |- 0 < ?r1² + ?r2² => apply Rneq0_imply_Rplus_gt0_2_2
  | H : 0 < ?r1  |- 0 < ?r1² + ?r2² => apply Rgt0_imply_Rplus_gt0_2_1
  | H : 0 < ?r2  |- 0 < ?r1² + ?r2² => apply Rgt0_imply_Rplus_gt0_2_2
  | H : 0 < ?r1  |- 0 < ?r1 * ?r2 => apply Rmult_lt_0_compat
  (* these methods are too ugly, but could work now *)
  | |- (0 < ?r1 + ?r2)%R => apply Rplus_lt_0_compat
  | |- (0 < ?r1 * ?r2)%R => apply Rmult_lt_0_compat
  | |- (0 < ?r1²)%R => apply Rlt_0_sqr
  | |- _ => idtac
  end;
  auto with R; try lra.

Module TEST_zero_lt.

  Goal forall r, 0 <> r -> 0 < r * r. tac_zero_lt. Qed.
  Goal forall r, 0 <> r -> 0 < r². tac_zero_lt. Qed.
  Goal forall r, 0 < r -> 0 < r * r. tac_zero_lt. Qed.
  Goal forall r, 0 < r -> 0 < r². tac_zero_lt. Qed.
  Goal forall r1 r2, r1 <> 0 -> 0 < r1 * r1 + r2 * r2. tac_zero_lt. Qed.
  Goal forall r1 r2, r1 <> 0 -> 0 < r1² + r2 * r2. tac_zero_lt. Qed.
  Goal forall r1 r2, r1 <> 0 -> 0 < r1 * r1 + r2². tac_zero_lt. Qed.
  Goal forall r1 r2, r1 <> 0 -> 0 < r1² + r2². tac_zero_lt. Qed.

  Goal forall r1 r2, r2 <> 0 -> 0 < r1 * r1 + r2 * r2. tac_zero_lt. Qed.
  Goal forall r1 r2, r2 <> 0 -> 0 < r1² + r2 * r2. tac_zero_lt. Qed.
  Goal forall r1 r2, r2 <> 0 -> 0 < r1 * r1 + r2². tac_zero_lt. Qed.
  Goal forall r1 r2, r2 <> 0 -> 0 < r1² + r2². tac_zero_lt. Qed.

  Goal forall r1 r2, 0 < r1 -> 0 < r1 * r1 + r2 * r2. tac_zero_lt. Qed.
  Goal forall r1 r2, 0 < r2 -> 0 < r1 * r1 + r2 * r2. tac_zero_lt. Qed.

  Goal forall r, 0 < r -> 0 < r * 10. tac_zero_lt. Qed.
  Goal forall r, 0 < r -> 0 < r + 10. tac_zero_lt. Qed.
  Goal forall r, 0 < r -> 0 < r * 100 + 23732. tac_zero_lt. Qed.

End TEST_zero_lt.

(* ==================================== *)
(** ** x <> 0 *)

(* (* we prefer the form of : r <> 0 *)
Lemma zero_neq_R_imply_Rneq0 r : 0 <> r -> r <> 0.
Proof. auto. Qed.
Global Hint Resolve zero_neq_R_imply_Rneq0 : R. *)

Lemma zero_lt_imply_Rneq0 r : 0 < r -> r <> 0.
Proof. auto with R. Qed.
Global Hint Resolve zero_lt_imply_Rneq0 : R.

(** r² <> 0 <-> r <> 0 *)

Lemma Rneq0_imply_Rsqr_neq0 r : r <> 0 -> r² <> 0.
Proof. intros. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rsqr_neq0 : R.

Lemma Rsqr_neq0_imply_Rneq0 r : r² <> 0 -> r <> 0.
Proof. intros. auto with R. Qed.
Global Hint Resolve Rsqr_neq0_imply_Rneq0 : R.

Lemma Rplus_neq0_imply_Rneq0_2_1 r1 r2 :
  r1 + r2 <> 0 -> r1 = 0 -> r2 <> 0.
Proof. intros. subst; autorewrite with R in H; auto with R. Qed.
Global Hint Resolve Rplus_neq0_imply_Rneq0_2_1 : R.

Lemma Rplus_neq0_imply_Rneq0_2_2 r1 r2 :
  r1 + r2 <> 0 -> r2 = 0 -> r1 <> 0.
Proof. intros. subst; autorewrite with R in H; auto with R. Qed.
Global Hint Resolve Rplus_neq0_imply_Rneq0_2_2 : R.

Lemma Rneq0_imply_Rplus_Rsqr_neq0_2_1 r1 r2 :
  r1 <> 0 -> r1² + r2² <> 0.
Proof. intros. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_Rsqr_neq0_2_1 : R.

Lemma Rneq0_imply_Rplus_Rsqr_neq0_2_2 r1 r2 :
  r2 <> 0 -> r1² + r2² <> 0.
Proof. intros. auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_Rsqr_neq0_2_2 : R.

Lemma Rneq0_imply_Rplus_Rsqr_neq0_2 r1 r2 :
  r1 <> 0 \/ r2 <> 0 -> r1² + r2² <> 0.
Proof. intros. destruct H; auto with R. Qed.
Global Hint Resolve Rneq0_imply_Rplus_Rsqr_neq0_2 : R.

Lemma Rplus_neq0_imply_Rneq0_2 r1 r2 :
  r1² + r2² <> 0 -> r1 <> 0 \/ r2 <> 0.
Proof.
  intro H. destruct (Req_EM_T r1² 0) as [E1|E1]; auto with R.
  right. rewrite E1 in H. autorewrite with R in H; auto with R.
Qed.
Global Hint Resolve Rplus_neq0_imply_Rneq0_2 : R.

Lemma Rplus_Rsqr_neq0_imply_gt0 r1 r2 :
  r1² + r2² <> 0 -> 0 < r1² + r2².
Proof.
  intros. apply Rplus_neq0_imply_Rneq0_2 in H. destruct H; auto with R.
Qed.
Global Hint Resolve Rplus_Rsqr_neq0_imply_gt0 : R.

Lemma Rneq0_imply_Rplus_neq0_3 r1 r2 r3 :
  r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 -> r1² + r2² + r3² <> 0.
Proof. intros. repeat (destruct H; auto with R).  Qed.
Global Hint Resolve Rneq0_imply_Rplus_neq0_3 : R.

Lemma Rplus_neq0_imply_Rneq0_3 r1 r2 r3 :
  r1² + r2² + r3² <> 0 -> r1 <> 0 \/ r2 <> 0 \/ r3 <> 0.
Proof.
  intro H. destruct (Req_EM_T r1² 0) as [E1|E1]; auto with R.
  right. rewrite E1 in H. autorewrite with R in H; auto with R.
Qed.
Global Hint Resolve Rplus_neq0_imply_Rneq0_3 : R.

Lemma Rneq0_imply_Rplus_neq0_4 r1 r2 r3 r4 :
  r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 -> r1² + r2² + r3² + r4² <> 0.
Proof. intros. repeat (destruct H; auto with R). Qed.
Global Hint Resolve Rneq0_imply_Rplus_neq0_4 : R.

Lemma Rplus_neq0_imply_Rneq0_4 r1 r2 r3 r4:
  r1² + r2² + r3² + r4² <> 0 -> r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0.
Proof.
  intro H. destruct (Req_EM_T r1² 0) as [E1|E1]; auto with R.
  right. rewrite E1 in H. autorewrite with R in H; auto with R.
Qed.
Global Hint Resolve Rplus_neq0_imply_Rneq0_4 : R.

Ltac tac_neq_zero :=
  intros; autorewrite with R in *;
  repeat match goal with
  (* symmetry *)
  | H : 0 <> ?a |- ?b <> 0 => apply not_eq_sym in H
  | H : 0 <> ?a |- 0 <> ?b => apply not_eq_sym in H; apply not_eq_sym
  (* normal *)
  | _ : 0 < ?r |- ?r <> 0 => apply zero_lt_imply_Rneq0
  | _ : ?r1 <> 0 |- ?r1² <> 0 => apply Rneq0_imply_Rsqr_neq0
  | _ : ?r1² <> 0 |- ?r1 <> 0 => apply Rsqr_neq0_imply_Rneq0
  | _ : ?r1 + ?r2 <> 0, _ : ?r1 = 0 |- ?r2 <> 0 =>
    apply Rplus_neq0_imply_Rneq0_2_1
  | _ : ?r1 + ?r2 <> 0, _ : ?r2 = 0 |- ?r1 <> 0 =>
    apply Rplus_neq0_imply_Rneq0_2_2
  (* default *)
(*   | |- ?b <> 0 => apply zero_lt_imply_Rneq0 *)
  | |- _ => idtac
  end;
  auto with R.

Module TEST_tac_neq_zero.
  Goal forall r, r² <> 0 <-> r <> 0. split; tac_neq_zero. Qed.
  Goal forall r, r² <> 0 -> r <> 0. tac_neq_zero. Qed.
  Goal forall r, r <> 0 -> r * r <> 0. tac_neq_zero. Qed.
  Goal forall r, r <> 0 -> r² <> 0. tac_neq_zero. Qed.

  Goal forall r, 0 <> r * r -> r <> 0. tac_neq_zero. Qed.
  Goal forall r, r * r <> 0 -> 0 <> r. tac_neq_zero. Qed.
  Goal forall r, 0 <> r * r -> 0 <> r. tac_neq_zero. Qed.

  Goal forall r1 r2 r3 r4 : R,
    r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 <->
    r1 * r1 + r2 * r2 + r3 * r3 + r4 * r4 <> 0.
  Proof. split; tac_neq_zero. Qed.

End TEST_tac_neq_zero.

(* ==================================== *)
(** ** a < b *)

Lemma Rdiv_le_imply_Rmul_gt a b c : b > 0 -> a * /b < c -> a < b * c.
Proof.
  intros.
  apply (Rmult_lt_compat_l b) in H0; auto.
  replace (b * (a * /b)) with a in H0; auto.
  field. auto with R.
Qed.
Global Hint Resolve Rdiv_le_imply_Rmul_gt : R.

Lemma Rmul_gt_imply_Rdiv_le a b c : b > 0 -> a < b * c -> a * /b < c.
Proof.
  intros.
  apply (Rmult_lt_compat_l (/b)) in H0; auto with R.
  autorewrite with R in *.
  replace (/b * a) with (a / b) in *; try field; auto with R.
  replace (/b * (b * c)) with c in *; try field; auto with R.
Qed.
Global Hint Resolve Rmul_gt_imply_Rdiv_le : R.

Global Hint Resolve
    Rminus_gt_0_lt  (* 0 < b - a -> a < b *)
    Rlt_Rminus      (* a < b -> 0 < b - a *)
    Rlt_minus       (* r1 < r2 -> r1 - r2 < 0 *)
    : R.

Ltac tac_le :=
  autounfold with R;
  match goal with
  | |- 0 < ?a + - ?b => apply Rlt_Rminus
  | |- ?a * (?b * /?c) < ?e => replace (a * (b * /c)) with ((a * b) * /c)
  | |- ?a * /?b < ?c => assert (a < b * c); assert (0 < b)
  | |- _ => idtac
  end; try lra; auto with R.

Module TEST_tac_le.

  Section sec1.
    Variable h T : R.
    Hypothesis Hh1 : 0 < h.
    Hypothesis Hh2 : h < 9200.
    Hypothesis HT1 : -60 < T.
    Hypothesis HT2 : T < 60.

    Lemma aux1 : h * 0.0065 < 273.15 + T.
    Proof. lra. Qed.

    Lemma aux2 : h / (273.15 + T) < 153.
    Proof.
      autounfold with R.
      assert (273.15 + T > 0). lra. auto with R.
      assert (h < (273.15 + T) * 153). lra. auto with R.
    Qed.

    Lemma aux3 : h / (273.15 + T) < 1 / 0.0065.
    Proof.
      autounfold with R.
      assert (273.15 + T > 0). lra. auto with R.
      assert (h < (273.15 + T) * (1/0.0065)). lra. auto with R.
    Qed.

    (** auto proof of aux3 *)
    Lemma aux3' : h / (273.15 + T) < 1 / 0.0065.
    Proof. tac_le. Qed.

    Lemma ex1 : 0 < 1 - (0.0065 * (h * / (273.15 + T))).
    Proof.
      (* construct condition manually, then try to automate *)
      assert (h / (273.15 + T) < 1/0.0065).
      (* apply aux3. *) tac_le.
      lra.
    Qed.

    (** auto proof of ex1 *)
    Lemma ex1' : 0 < 1 - (0.0065 * (h * / (273.15 + T))).
    Proof.
      do 5 tac_le.
    Qed.

  End sec1.

End TEST_tac_le.

(* ==================================== *)
(** ** 这些是早期的实现，虽然自动化程度高，但有些转换不完善，需要进一步整合。*)

(** a + b <> 0 *)
Ltac plus_neq0 :=
  match goal with
  | |- ?a + ?b <> 0 => apply Rgt_not_eq,Rlt_gt,Rplus_lt_0_compat;
    auto with R fcs
  end.

(** 0 < a *)
Ltac zero_lt :=
  repeat match goal with
  (* 0 *)
  | H: ?a <> 0 |- 0 < ?a * ?a => apply Rlt_0_sqr; apply H
  | |- 0 < ?a + ?b => apply Rplus_lt_0_compat
  | |- 0 < ?a * ?b => apply Rmult_lt_0_compat
  | |- 0 < sqrt ?a => apply sqrt_lt_R0
  | |- 0 < ?a / ?b => unfold Rdiv
  | |- 0 < / ?a => apply Rinv_0_lt_compat
  | |- 0 < ?a ^ _ => simpl
  | |- 0 < (?a)² => unfold Rsqr
  | |- 0 < ?a => auto with R fcs; try lra
  (* R0 *)
  | |- R0 < ?a * ?b => apply Rmult_lt_0_compat; try lra; auto with R fcs
  | |- R0 < sqrt ?a => apply sqrt_lt_R0
  | |- R0 < ?a / ?b => unfold Rdiv
  | |- R0 < / ?a => apply Rinv_0_lt_compat
  | |- R0 < ?a ^ _ => simpl
  | |- R0 < (?a)² => unfold Rsqr
  | |- R0 < ?a => auto with R fcs; try lra
  end.

(** simplify expression has sqrt and pow2 *)
Ltac simpl_sqrt_pow2 :=
  repeat (
  (* (_²) -> x * x *)
  unfold Rsqr;
  (* (sqrt r1 * sqrt r2)^2 = r1 * r2 *)
  try rewrite sqrt_mult_sqrt;
  (* (sqrt x) ^ 2 = x *)
  try rewrite pow2_sqrt;
  (* sqrt (x ^ 2) = x *)
  try rewrite sqrt_pow2;
  (* (sqrt x * sqrt x) = x *)
  try rewrite sqrt_sqrt
  ).

(** 0 <= a *)
Ltac zero_le :=
  (* simplify sqrt+pow2 *)
  repeat (
  try simpl_sqrt_pow2;
  try match goal with
  (* 0 <= sqrt x *)
  | |- 0 <= sqrt _ => apply sqrt_pos
  (* 0 <= a * a *)
  | |- 0 <= ?a * ?a => apply Rle_0_sqr
  (* 0 <= a -> 0 <= b -> 0 <= a + b *)
  | |- 0 <= ?a + ?b => apply Rplus_le_le_0_compat
  (* 0 <= a -> 0 <= b -> 0 <= a * b *)
  | |- 0 <= ?a * ?b => apply Rmult_le_pos
  (* if fail, proof < again *)
(*   | |- 0 <= ?a => apply Rlt_le; zero_le
  | |- R0 <= ?a => apply Rlt_le; zero_le *)
  end).

(** a * b <> 0 *)
Ltac mult_neq0 :=
  match goal with
  | |- ?a * ?b <> 0 => apply Rgt_not_eq,Rlt_gt;zero_le
  end.

(** a <> 0 *)
Ltac neq0 :=
  repeat match goal with
  | |- ?a /\ ?b => repeat split
  | |- ?a <> 0 => apply Rgt_not_eq,Rlt_gt; zero_le
  end.

(** Simplification for trigonometric functions *)

Lemma xx_sqr : forall x:R, x * x = Rsqr x.
Proof. auto. Qed.

Lemma cos2_sin2' : forall x:R, Rsqr (cos x) + Rsqr (sin x) = 1.
Proof. intros. rewrite Rplus_comm. apply sin2_cos2. Qed.

Lemma cos_sin : forall x:R, cos x * sin x = sin x * cos x.
Proof. intros. lra. Qed.

Lemma x_neg_x : forall x:R, x + - x = 0.
Proof. intros. lra. Qed.

Lemma neg_x_x : forall x:R, -x + x = 0.
Proof. intros. lra. Qed.

Lemma x_mul_neg_x : forall x y : R, y * -x = - (x * y).
Proof. intros. lra. Qed.

Lemma neg_x_mul_x : forall x y : R, -y * x = - (y * x).
Proof. intros. lra. Qed.

Lemma sqrR1_R1 : R1² = R1.
Proof. unfold Rsqr. ring. Qed.

Lemma one_R1 : 1 = R1.
Proof. ring. Qed.

Lemma inv1_R1 : /1 = R1.
Proof. field. Qed.

Lemma invR1_R1 : /R1 = R1.
Proof. field. Qed.

Lemma sqrtR1_R1 : sqrt R1 = R1.
Proof. apply Rsqr_inj. zero_le. lra. rewrite Rsqr_sqrt.
  rewrite sqrR1_R1. auto. lra.
Qed.

Lemma sqrt1_R1 : sqrt 1 = R1.
Proof. rewrite one_R1. apply sqrtR1_R1. Qed.

Lemma coscos_sinsin : forall x : R, (cos x * cos x + sin x * sin x) = 1.
Proof. intros. rewrite ?xx_sqr. rewrite ?cos2_sin2. auto. Qed.

Lemma sinsin_coscos : forall x : R, (sin x * sin x + cos x * cos x) = 1.
Proof. intros. rewrite ?xx_sqr. rewrite ?sin2_cos2. auto. Qed.

(** r1 - (-r2) = r1 + r2 *)
Lemma Rsub_Rneg : forall (r1 r2 : R), r1 - (- r2) = r1 + r2.
Proof. intros. ring. Qed.

(** Simplify trigonometric function and expression of real number *)
Ltac trigo_simp :=
  rewrite ?Rmult_opp_opp;   (* -x * -x = x * x *)
(*   rewrite ?xx_sqr;          (* x * x = Rsqr x  *) *)
  rewrite ?Rsub_Rneg,       (* r1 - (-r2) = r1 + r2 *)
          ?sin2_cos2,       (* sin^2 + cos^2 = 1 *)
          ?cos2_sin2,       (* cos^2 + sin^2 = 1 *)
          ?coscos_sinsin,   (* cos*cos + sin*sin = 1 *)
          ?sinsin_coscos,   (* sin*sin + cos*cos = 1 *)
          ?cos_sin,         (* cos * sin = sin * cos *)
          ?x_mul_neg_x,     (* y * -x = - (x * y) *)
          ?neg_x_mul_x,     (* -y * x = - (x * y) *)
          ?x_neg_x,         (* x + -x = 0 *)
          ?neg_x_x,         (* -x + x = 0 *)
          ?sqrtR1_R1,       (* sqrt R1 = R1 *)
          ?sqrt1_R1,        (* sqrt 1 = 1 *)
          ?sqrR1_R1,        (* R1² = R1 *)
(*           ?Rinv_1,           (* /1 = 1 *) *)
          ?inv1_R1,         (* /1 = R1 *)
          ?invR1_R1,        (* /R1 = R1 *)
          ?one_R1           (* 1 = R1 *)
  ;
  autorewrite with R;       (* +0, 0+, *0, 0*, *1, 1* *)
  try field;
  auto.

(** Properties about sqrt *)

(* sqrt x = R1 -> x = R1 *)
Lemma sqrt_eqR1_imply_R1 : forall (x : R), sqrt x = R1 -> x = R1.
Proof.
  intros.
  assert ((sqrt x)² = R1). rewrite H. unfold Rsqr. lra. rewrite <- H0.
  rewrite Rsqr_sqrt; auto.
  assert (0 < sqrt x). rewrite H. lra.
  apply sqrt_gt0_imply_gt0 in H1. lra.
Qed.

(* ==================================== *)
(** ** Other properties *)

(** r * r = 0 <-> r = 0 *)
Lemma Rmult_eq0_iff_eq0 : forall r, r * r = 0 <-> r = 0.
Proof.
  intros. split; intros.
  - apply Rmult_integral in H. lra.
  - rewrite H. ring.
Qed.

Global Hint Resolve Rmult_eq0_iff_eq0 : R.

(** r * r <> 0 <-> r <> 0 *)
Lemma Rsqr_neq0_iff_neq0 : forall r, r * r <> 0 <-> r <> 0.
Proof.
  intros. split; intros; intro.
  - rewrite H0 in H. lra.
  - apply Rmult_integral in H0. lra.
Qed.

Global Hint Resolve Rsqr_neq0_iff_neq0 : R.

(** 0 <= r1*r1 + r2*r2 *)
Lemma Rplus_sqr_sqr_ge0 : forall r1 r2 : R, 0 <= r1 * r1 + r2 * r2.
Proof.
  intros. apply Rplus_le_le_0_compat; zero_le.
Qed.

(** r1 <> 0 \/ r2 <> 0 <-> r1 * r1 + r2 * r2 <> 0 *)
Lemma Rplus_sqr_neq0_iff2 : forall r1 r2 : R,
  r1 <> 0 \/ r2 <> 0 <-> r1 * r1 + r2 * r2 <> 0.
Proof.
  intros. split; intro H.
  - destruct H.
    + rewrite Rplus_comm. apply tech_Rplus; zero_le; zero_lt.
    + apply tech_Rplus; zero_le; zero_lt.
  - destruct (Req_EM_T (r1 * r1) 0) as [E1|E1].
    + rewrite Rmult_eq0_iff_eq0 in E1. right. subst.
      ring_simplify (0 * 0 + r2 * r2) in H. intro. subst. lra.
    + rewrite Rsqr_neq0_iff_neq0 in E1. auto.
Qed.

(** r1*r1 + r2*r2 <> 0 -> 0 < r1*r1 + r2*r2 *)
Lemma Rplus_sqr_sqr_neq0_iff_Rplus_sqr_sqr_gt0 : forall r1 r2 : R,
  r1 * r1 + r2 * r2 <> 0 <-> 0 < r1 * r1 + r2 * r2.
Proof.
  intros. split; intros.
  - apply Rplus_sqr_neq0_iff2 in H. destruct H.
    + apply Rplus_lt_le_0_compat. zero_lt. zero_le.
    + apply Rplus_le_lt_0_compat. zero_le. zero_lt.
  - lra.
Qed.

Global Hint Resolve Rplus_sqr_sqr_neq0_iff_Rplus_sqr_sqr_gt0 : R.

(** r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 <-> r1 * r1 + r2 * r2 + r3 * r3 <> 0 *)
Lemma Rplus_sqr_neq0_iff3 : forall r1 r2 r3 : R,
  r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 <-> r1 * r1 + r2 * r2 + r3 * r3 <> 0.
Proof.
  intros. split; intros.
  - destruct H.
    + rewrite Rplus_assoc. rewrite Rplus_comm. apply tech_Rplus.
      * zero_le.
      * zero_lt.
    + rewrite Rplus_sqr_neq0_iff2 in H.
      rewrite Rplus_assoc. apply tech_Rplus. zero_le.
      auto with R. (* why fail? *)
      apply Rplus_sqr_sqr_neq0_iff_Rplus_sqr_sqr_gt0; auto.
  - rewrite Rplus_sqr_neq0_iff2.
    destruct (Req_EM_T r1 0),(Req_EM_T r2 0),(Req_EM_T r3 0); subst;
    auto; try lra.
Qed.

(** r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 <->
    r1 * r1 + r2 * r2 + r3 * r3 + r4 * r4 <> 0 *)
Lemma Rplus_sqr_neq0_iff4 : forall r1 r2 r3 r4 : R,
  r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 <->
  r1 * r1 + r2 * r2 + r3 * r3 + r4 * r4 <> 0.
Proof.
  intros. split; intro H.
  - destruct H.
    + rewrite Rplus_comm. rewrite Rplus_comm with (r1 := r1*r1).
      rewrite Rplus_assoc. rewrite Rplus_comm with (r1 := r1*r1).
      repeat rewrite <- Rplus_assoc. apply tech_Rplus; zero_le; zero_lt.
    + destruct H.
      * rewrite Rplus_comm. rewrite Rplus_assoc.
        rewrite Rplus_comm with (r1 := r2 * r2).
        repeat rewrite <- Rplus_assoc. apply tech_Rplus; zero_le; zero_lt.
      * destruct H.
        { repeat rewrite Rplus_assoc. rewrite Rplus_comm with (r2 := r4 * r4).
          repeat rewrite <- Rplus_assoc. apply tech_Rplus; zero_le; zero_lt. }
        { apply tech_Rplus; zero_le; zero_lt. }
  - destruct (r1 * r1 =? 0) eqn : E1.
    + apply Reqb_true_iff in E1. destruct (r2 * r2 =? 0) eqn : E2.
      * apply Reqb_true_iff in E2. destruct (r3 * r3 =? 0) eqn : E3.
        { apply Reqb_true_iff in E3. rewrite E1,E2,E3 in H.
          repeat rewrite Rplus_0_l in H. right;right;right.
          apply Rsqr_neq0_iff_neq0; auto. }
        { apply Reqb_false_iff in E3. right; right; left.
          apply Rsqr_neq0_iff_neq0; auto. }
      * apply Reqb_false_iff in E2. right; left.
          apply Rsqr_neq0_iff_neq0; auto.
    + apply Reqb_false_iff in E1. left. apply Rsqr_neq0_iff_neq0; auto.
Qed.

(* ==================================== *)
(** ** Approximate of two real numbers *)

(** r1 ≈ r2, that means |r1 - r2| <= diff *)
Definition Rapprox (r1 r2 diff : R) : Prop := Rabs (r1 - r2) <= diff.

(** boolean version of approximate function *)
Definition Rapproxb (r1 r2 diff : R) : bool := Rleb (Rabs (r1 - r2)) diff.