From AIM Require Export Coqlib.

Hint Extern 4 (~( _ = _ )) => discriminate.

Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) =>
                  generalize X1 X2; decide equality.

Module Type MapSpec.

Parameter domain : Set.
Parameter image : Set.
Parameter beq_Domain : forall (x y : domain), {x = y} + {x <> y}.

End MapSpec.

(* Partial Map *)

Module MapFun(Spec : MapSpec).

Set Implicit Arguments.
Definition A : Set := Spec.domain.
Definition B : Set := Spec.image.
Definition beq_A := Spec.beq_Domain.

(* partial map *)
Definition Map := A -> option B.

(* empty map *)
Definition emp : Map :=
  fun a : A => None.

(* map extension *)
Definition put : Map -> A -> B -> Map :=
  fun M a b =>
    fun x => if (beq_A x a) then (Some b) else M x.

Definition remove : Map -> A -> Map :=
  fun M a =>
    fun x => if (beq_A x a) then None else M x.

Definition maps_to : Map -> A -> B -> Prop :=
  fun M a b => M a = Some b.

Definition in_dom : A -> Map -> Prop :=
  fun a M => exists b : B, M a = Some b.

Definition not_in_dom : A -> Map -> Prop :=
  fun a M => M a = None.

(* map that has only one element in the domain *)
Definition sgltonM : Map -> A -> B -> Prop :=
  fun M a b =>
    maps_to M a b /\ (forall (x : A), x <> a -> not_in_dom x M).

Definition sub_dom : Map -> Map -> Prop :=
  fun M M' => forall (x : A), in_dom x M -> in_dom x M'.

Definition eqDom : Map -> Map -> Prop :=
  fun M M' => sub_dom M M' /\ sub_dom M' M.

Definition merge : Map -> Map -> Map :=
  fun M1 M2 =>
    fun x =>
      match M1 x with
        None => M2 x
      | _ => M1 x
      end.

Definition disjoint : Map -> Map -> Prop :=
  fun M1 M2 =>
    forall (x : A), not_in_dom x M1 \/ not_in_dom x M2.

Definition disjUnion : Map -> Map -> Map -> Prop :=
  fun M' M'' M => disjoint M' M'' /\ (M = merge M' M'').

Definition subseteq : Map -> Map -> Prop :=
  fun M1 M2 =>
    forall (x : A), in_dom x M1 -> M1 x = M2 x.

Definition compat : Map -> Map -> Prop :=
  fun M1 M2 =>
    forall (x : A) (y : B), maps_to M1 x y -> not_in_dom x M2 \/ maps_to M2 x y.

(* extensional equality about Maps *)
Definition extensional_eqMap := extensionality A (option B).

Lemma eq_get : forall (M M' : Map) (x : A), M = M' -> M x = M' x.
Proof.
  intros; subst; trivial.
Qed.

(* ****************************** *)
(* properties about map extension *)
(* ****************************** *)

Lemma put_get_eq :
  forall (M : Map) (x: A) (y : B), (put M x y) x = Some y.
Proof.
intros.
unfold put.
case (beq_A x x).
auto.
intro.
assert (x=x). auto. contradiction.
Qed.

Lemma put_noninterfere:
  forall (M : Map) (x x' : A) (y : B), x <> x' -> (put M x y) x' = M x'.
Proof.
intros M x x' y x_neq.
unfold put.
case (beq_A x' x).
intro. assert (x = x'). symmetry. auto. contradiction.
auto.
Qed.

Hint Resolve put_get_eq put_noninterfere: PMap.

Lemma put_unique :
  forall (M : Map) (x : A) (y y' : B),
    put M x y = put M x y'
    -> y = y'.
Proof.
  intros.
  assert (H': put M x y x = put M x y' x).
    rewrite H; trivial.
  rewrite put_get_eq in H'.
  rewrite put_get_eq in H'.
  injection H'; trivial.
Qed.

(* ****************************** *)
(*    properties about remove     *)
(* ****************************** *)
Lemma remove_shrinks_dom:
  forall (M : Map) (x : A),
    forall (y : A), not_in_dom y M -> not_in_dom y (remove M x).
Proof.
  intros.
  unfold not_in_dom.
  unfold remove.
  induction (beq_A y x).
  auto.
  unfold not_in_dom in H. auto.
Qed.

Lemma nid_remove:
  forall (M : Map) (x : A), not_in_dom x (remove M x).
Proof.
  intros M x.
  unfold remove.
  unfold not_in_dom.
  induction (beq_A x x). auto.
  assert (x = x); auto. contradiction.
Qed.

Hint Resolve remove_shrinks_dom nid_remove : PMap.

Lemma remove_nothing:
  forall (M : Map) (x : A), not_in_dom x M -> M = (remove M x).
Proof.
  intros.
  apply extensional_eqMap.
  intros.
  unfold remove.
  induction (beq_A x0 x).
  unfold not_in_dom in H.
  rewrite <- a in H. auto.
  auto.
Qed.

Lemma remove_cancel_put:
  forall (M : Map) (x : A) (y : B), remove (put M x y) x = remove M x.
Proof.
  intros.
  apply extensional_eqMap.
  intros.
  unfold remove.
  induction (beq_A x0 x).
  auto.
  unfold put.
  induction (beq_A x0 x).
  contradiction.
  auto.
Qed.

Lemma put_cancel_remove:
  forall (M : Map) (x : A) (y : B), put (remove M x) x y = put M x y.
Proof.
  intros M x y.
  apply extensional_eqMap.
  intro x0.
  unfold put.
  unfold remove.
  induction (beq_A x0 x); auto.
Qed.

Lemma remove_ext_ext_remove:
  forall (M : Map) (x x' : A) (y : B), x <> x' -> remove (put M x y) x' = put (remove M x') x y.
Proof.
  intros.
  apply extensional_eqMap.
  intros.
  unfold put.
  unfold remove.
  induction (beq_A x0 x).
  induction (beq_A x0 x').
  rewrite a in a0. contradiction. auto.
  induction (beq_A x0 x'). auto. auto.
Qed.

Hint Resolve remove_nothing remove_cancel_put put_cancel_remove remove_ext_ext_remove : PMap.

(******************************************)
(* properties about in_dom and not_in_dom *)
(******************************************)

Lemma in_not_notin :
  forall (x : A) (M : Map), in_dom x M -> ~ (not_in_dom x M).
Proof.
  intros.
  intro.
  unfold in_dom in H. unfold not_in_dom in H0.
  inversion_clear H.
  rewrite H0 in H1. inversion_clear H1.
Qed.

Lemma notin_not_in:
  forall (x : A) (M : Map), not_in_dom x M -> ~ (in_dom x M).
Proof.
  intros.
  intro.
  unfold in_dom in H0. unfold not_in_dom in H.
  inversion_clear H0.
  rewrite H in H1. inversion_clear H1.
Qed.

Lemma not_in_notin:
  forall (x : A) (M : Map), ~ in_dom x M -> not_in_dom x M.
Proof.
  intros.
  unfold not_in_dom.
  unfold in_dom in H.
  induction (M x).
  assert (exists b : B, Some a = Some b). exists a; auto.
  contradiction.
  auto.
Qed.

Lemma not_notin_in:
  forall (x : A) (M : Map), ~ not_in_dom x M -> in_dom x M.
Proof.
  intros.
  unfold in_dom. unfold not_in_dom in H.
  induction (M x). exists a. auto. elim H. auto.
Qed.

Lemma in_or_notin:
  forall x M, in_dom x M \/ not_in_dom x M.
Proof.
  intros x M.
  unfold in_dom.
  unfold not_in_dom.
  elim (M x).
  left. exists a. auto.
  right. auto.
Qed.

Hint Resolve in_not_notin notin_not_in not_in_notin not_notin_in in_or_notin : PMap.

(* properties about disjoint *)
Lemma disjoint_commut: forall M1 M2, disjoint M1 M2 -> disjoint M2 M1.
Proof.
  intros M1 M2.
  unfold disjoint.
  intros.
  assert (not_in_dom x M1 \/ not_in_dom x M2); auto.
  inversion_clear H0.
  right; auto.
  left; auto.
Qed.

Hint Resolve disjoint_commut : PMap.

Lemma putA_presv_nidB :
  forall M x x' y,
    not_in_dom x M -> x<>x' -> not_in_dom x (put M x' y).
Proof.
  intros.
  unfold not_in_dom.
  unfold put.
  induction (beq_A  x x'); auto.
  contradiction.
Qed.

Lemma extend_presv_disj_left:
  forall (M1 M2 : Map) (x : A) (y : B),
    disjoint M1 M2 -> not_in_dom x M2 -> disjoint (put M1 x y) M2.
Proof.
  intros.
  unfold disjoint.
  unfold not_in_dom in H0.
  unfold disjoint in H.
  intro.
  assert (not_in_dom x0 M1 \/ not_in_dom x0 M2).
  apply H.
  inversion_clear H1.
  unfold put.
  unfold not_in_dom.
  induction (beq_A x0 x).
  right. rewrite a. auto.
  left. unfold not_in_dom in H2. auto.
  right. auto.
Qed.

Hint Resolve extend_presv_disj_left putA_presv_nidB : PMap.

Lemma extend_presv_disj_right:
  forall (M1 M2 : Map) (x : A) (y : B),
    disjoint M1 M2 -> not_in_dom x M1 -> disjoint M1 (put M2 x y).
Proof.
  intros.
  apply disjoint_commut.
  assert (disjoint M2 M1). auto with PMap.
  auto with PMap.
Qed.

Hint Resolve extend_presv_disj_right : PMap.

(* ******************************** *)
(* Disjoint and in_dom / not_in_dom *)
(* ******************************** *)
Lemma disj_exclusive_left :
  forall (x : A) (M M' : Map),
    disjoint M M' -> in_dom x M -> not_in_dom x M'.
Proof.
  intros.
  unfold disjoint in H.
  assert (not_in_dom x M \/ not_in_dom x M'). auto.
  inversion_clear H1.
  assert (~ in_dom x M); auto with PMap.
  auto.
Qed.

Hint Resolve disj_exclusive_left : PMap.

Lemma disj_exclusive_right :
  forall (x : A) (M M' : Map),
    disjoint M M' -> in_dom x M' -> not_in_dom x M.
Proof.
  intros.
  assert (disjoint M' M); auto with PMap.
  apply disj_exclusive_left with M'; auto.
Qed.
Hint Resolve disj_exclusive_right : PMap.

Lemma update_presv_disj_left:
  forall (M1 M2 : Map) (x : A) (y : B),
    disjoint M1 M2 -> in_dom x M1 -> disjoint (put M1 x y) M2.
Proof.
  intros.
  assert (not_in_dom x M2).
  apply disj_exclusive_left with M1; auto.
  auto with PMap.
Qed.

Hint Resolve update_presv_disj_left : PMap.

Lemma update_presv_disj_right:
  forall (M1 M2 : Map) (x : A) (y : B),
    disjoint M1 M2 -> in_dom x M2 -> disjoint M1 (put M2 x y).
Proof.
  intros.
  apply disjoint_commut.
  assert (disjoint M2 M1); auto with PMap.
Qed.

Hint Resolve update_presv_disj_right : PMap.

Lemma remove_presv_disj_left:
  forall (M1 M2 : Map) (x : A),
    disjoint M1 M2 -> disjoint (remove M1 x) M2.
Proof.
  intros.
  unfold disjoint.
  unfold disjoint in H.
  intro.
  assert (not_in_dom x0 M1 \/ not_in_dom x0 M2).
  apply H.
  inversion_clear H0.
  left.
  auto with PMap.
  right. auto.
Qed.

Hint Resolve remove_presv_disj_left : PMap.

Lemma remove_presv_disj_right:
  forall (M1 M2 : Map) (x : A),
    disjoint M1 M2 -> disjoint (remove M1 x) M2.
Proof.
  intros.
  apply disjoint_commut.
  assert (disjoint M2 M1); auto with PMap.
Qed.

Hint Resolve remove_presv_disj_right : PMap.

(* ******************************** *)
(*  Merge and in_dom / not_in_dom   *)
(* ******************************** *)
Lemma notin_merge_distr_left :
  forall (M1 M2 : Map) (x : A),
    not_in_dom x (merge M1 M2) -> not_in_dom x M1.
Proof.
intros M1 M2 x.
unfold not_in_dom.
unfold merge.
elim (M1 x); auto.
Qed.

Hint Resolve notin_merge_distr_left: PMap.

Lemma notin_merge_distr_right :
  forall (M1 M2 : Map) (x : A),
    not_in_dom x (merge M1 M2) -> not_in_dom x M2.
Proof.
intros M1 M2 x.
unfold not_in_dom.
unfold merge.
elim (M1 x).
intros.
inversion_clear H.
auto.
Qed.
Hint Resolve notin_merge_distr_right: PMap.

Lemma merge_presv_indom_left:
  forall (M1 M2: Map) (x: A), in_dom x M1 -> in_dom x (merge M1 M2).
Proof.
  intros M1 M2 x.
  unfold in_dom.
  unfold merge.
  intro.
  inversion_clear H.
  exists x0.
  rewrite H0.
  auto.
Qed.

Lemma merge_presv_indom_right:
  forall (M1 M2: Map) (x: A), in_dom x M2 -> in_dom x (merge M1 M2).
Proof.
  intros.
  unfold in_dom. unfold in_dom in H.
  unfold merge.
  assert ((exists y, M1 x = Some y) \/ (M1 x = None)).
  induction (M1 x).
  left. exists a. auto. right. auto.
  inversion_clear H0.
  inversion_clear H1.
  exists x0. rewrite H0. auto.
  inversion_clear H.
  exists x0. rewrite H1. auto.
Qed.

Hint Resolve merge_presv_indom_left merge_presv_indom_right : PMap.

Lemma in_merge_left_or_right:
  forall (M1 M2: Map) (x: A), in_dom x (merge M1 M2) -> in_dom x M1 \/ in_dom x M2.
Proof.
  intros.
  unfold in_dom in H.
  unfold merge in H.
  unfold in_dom.
  induction (M1 x).
  left. auto.
  right. auto.
Qed.

Hint Resolve in_merge_left_or_right : PMap.

Lemma in_merge_not_left_in_right:
  forall (M1 M2: Map) (x: A), in_dom x (merge M1 M2) -> not_in_dom x M1 -> in_dom x M2.
Proof.
  intros.
  assert (in_dom x M1 \/ in_dom x M2); auto with PMap.
  inversion_clear H1.
  assert (~ in_dom x M1). auto with PMap.
  contradiction. auto.
Qed.
Hint Resolve in_merge_not_left_in_right: PMap.

Lemma in_merge_not_right_in_left:
  forall (M1 M2: Map) (x: A), in_dom x (merge M1 M2) -> not_in_dom x M2 -> in_dom x M1.
Proof.
  intros.
  assert (in_dom x M1 \/ in_dom x M2); auto with PMap.
  inversion_clear H1; auto.
  assert (~ in_dom x M2). auto with PMap.
  contradiction.
Qed.
Hint Resolve in_merge_not_right_in_left: PMap.

Lemma in_merge_commut:
  forall (M1 M2: Map) (x: A), in_dom x (merge M1 M2) -> in_dom x (merge M2 M1).
Proof.
  intros.
  assert (in_dom x M1 \/ in_dom x M2); auto with PMap.
  inversion_clear H0; auto with PMap.
Qed.

Hint Resolve in_merge_commut : PMap.

Lemma not_in_merge_commut:
  forall (M1 M2: Map) (x: A), not_in_dom x (merge M1 M2) -> not_in_dom x (merge M2 M1).
Proof.
  intros.
  assert (in_dom x (merge M2 M1) \/ not_in_dom x (merge M2 M1)); auto with PMap.
  inversion_clear H0; auto.
  assert (in_dom x (merge M1 M2)); auto with PMap.
  assert (~ (in_dom x (merge M1 M2))); auto with PMap.
Qed.

Hint Resolve not_in_merge_commut : PMap.

Lemma notin_left_notin_right_notin_merge:
  forall (M1 M2 : Map) (x : A), not_in_dom x M1 -> not_in_dom x M2 -> not_in_dom x (merge M1 M2).
Proof.
  intros.
  assert (in_dom x (merge M1 M2) \/ not_in_dom x (merge M1 M2)); auto with PMap.
  inversion_clear H1; auto.
  assert (in_dom x M1 \/ in_dom x M2); auto with PMap.
  inversion_clear H1.
  assert (~ (in_dom x M1)); auto with PMap.
  assert (~ (in_dom x M2)); auto with PMap.
Qed.

Hint Resolve notin_left_notin_right_notin_merge : PMap.
(* *************************************** *)
(*              merge and subseteq         *)
(* *************************************** *)
Lemma merge_extends_map:
  forall (M1 M2 : Map), subseteq M1 (merge M1 M2).
Proof.
  intros.
  unfold subseteq.
  unfold merge.
  intros.
  unfold in_dom in H.
  inversion H.
  rewrite H0.
  auto.
Qed.

Hint Resolve merge_extends_map : PMap.

(* ********************* *)
(* Propeties about merge *)
(* ********************* *)
Lemma merge_assoc:
  forall M1 M2 M3, merge (merge M1 M2) M3 = merge M1 (merge M2 M3).
Proof.
intros M1 M2 M3.
apply extensional_eqMap.
intro.
unfold merge.
elim (M1 x).
auto.
elim (M2 x); auto.
Qed.

Hint Resolve merge_assoc : PMap.

Lemma in_left_in_merge:
  forall M1 M2 x y,
    maps_to M1 x y -> maps_to (merge M1 M2) x y.
Proof.
  unfold maps_to.
  intros.
  unfold merge.
  rewrite H. auto.
Qed.

Hint Resolve in_left_in_merge.

Lemma in_right_in_merge :
  forall M1 M2 x y,
    not_in_dom x M1 -> maps_to M2 x y -> maps_to (merge M1 M2) x y.
Proof.
  unfold maps_to.
  unfold merge.
  unfold not_in_dom.
  intros.
  rewrite H. auto.
Qed.

Hint Resolve in_right_in_merge.

Lemma put_merge_merge_put:
  forall (M1 M2 : Map) (x : A) (y : B),
    put (merge M1 M2) x y = merge (put M1 x y) M2.
Proof.
  intros M1 M2 x y.
  apply extensional_eqMap.
  intro.
  unfold put. unfold merge.
  induction (beq_A x0 x). auto. induction (M1 x0); auto.
Qed.

Hint Resolve put_merge_merge_put : PMap.

Lemma remove_merge_merge_remove_right:
  forall (M1 M2 : Map) (x : A),
    not_in_dom x M1 -> remove (merge M1 M2) x = merge M1 (remove M2 x).
Proof.
  intros.
  apply extensional_eqMap.
  intro.
  unfold remove.
  unfold merge.
  induction (beq_A x0 x).
  rewrite <- a in H. unfold not_in_dom in H.
  rewrite H. auto.
  induction (M1 x0); auto.
Qed.

Lemma disj_remove_merge_merge_remove :
  forall (M1 M2 : Map) (x : A),
    disjoint M1 M2 -> in_dom x M1 -> remove (merge M1 M2) x = merge (remove M1 x) M2.
Proof.
  intros.
  assert (not_in_dom x M2).
  apply disj_exclusive_left with M1; auto.
  apply extensional_eqMap.
  intro.
  unfold remove. unfold merge.
  induction (beq_A x0 x).
  rewrite a. unfold not_in_dom in H1. auto.
  auto.
Qed.

Hint Resolve remove_merge_merge_remove_right disj_remove_merge_merge_remove : PMap.

(* *************************************** *)
(*  Properties about disjoint and  merge   *)
(* *************************************** *)
Lemma disj_merge_disj_left:
  forall M1 M2 M' : Map, disjoint (merge M1 M2) M' -> disjoint M1 M'.
Proof.
intros M1 M2 M'.
unfold disjoint.
intros.
assert (not_in_dom x (merge M1 M2) \/ not_in_dom x M'); auto.
inversion_clear H0.
left.
apply notin_merge_distr_left with M2; auto.
right. auto.
Qed.
Hint Resolve disj_merge_disj_left: PMap.

Lemma disj_merge_disj_right:
  forall M1 M2 M' : Map, disjoint (merge M1 M2) M' -> disjoint M2 M'.
Proof.
intros M1 M2 M'.
unfold disjoint.
intros.
assert (not_in_dom x (merge M1 M2) \/ not_in_dom x M'); auto.
inversion_clear H0.
left.
apply notin_merge_distr_right with M1; auto.
right. auto.
Qed.
Hint Resolve disj_merge_disj_right: PMap.

Lemma disj_x_merge_disj_left:
  forall M1 M2 M' : Map, disjoint M' (merge M1 M2) -> disjoint M' M1.
Proof.
  intros.
  assert (disjoint (merge M1 M2) M'). auto with PMap.
  assert (disjoint M1 M'); auto with PMap.
  apply disj_merge_disj_left with M2. auto.
Qed.

Lemma disj_x_merge_disj_right:
  forall M1 M2 M' : Map, disjoint M' (merge M1 M2) -> disjoint M' M2.
Proof.
  intros.
  assert (disjoint (merge M1 M2) M'). auto with PMap.
  assert (disjoint M2 M'); auto with PMap.
  apply disj_merge_disj_right with M1. auto.
Qed.

Hint Resolve disj_x_merge_disj_left  disj_x_merge_disj_right: PMap.

Lemma disj_merge_commut : forall M1 M2 : Map, disjoint M1 M2 -> (merge M1 M2) = (merge M2 M1).
Proof.
intros M1 M2 disj.
apply extensional_eqMap.
intro.
unfold merge.
unfold disjoint in disj.
unfold not_in_dom in disj.
assert (M1 x = None \/ M2 x = None); auto.
inversion H.
rewrite H0.
elim (M2 x); auto.
rewrite H0.
elim (M1 x); auto.
Qed.

Hint Resolve disj_merge_commut : PMap.

Lemma disj_merge_disjUnion: forall M1 M2 : Map, disjoint M1 M2 -> disjUnion M1 M2 (merge M1 M2).
Proof.
intros M1 M2 disj.
unfold disjUnion.
split; auto.
Qed.

Hint Resolve disj_merge_disjUnion : PMap.
Lemma disj_merge_A:
  forall M1 M2 M3, disjoint M1 M2 -> disjoint M1 M3 -> disjoint M1 (merge M2 M3).
Proof.
  intros M1 M2 M3.
  unfold disjoint.
  intros disj1 disj2.
  intro.
  assert (not_in_dom x M1 \/ not_in_dom x M2); auto.
  assert (not_in_dom x M1 \/ not_in_dom x M3); auto.
  inversion_clear H.
  left; auto.
  inversion_clear H0.
  left; auto.
  right.
  unfold not_in_dom in * |- * .
  unfold merge.
  rewrite H1.
  auto.
Qed.
Hint Resolve disj_merge_A : PMap.

Lemma disj_merge_B:
  forall M1 M2 M3, disjoint M2 M1 -> disjoint M3 M1 -> disjoint (merge M2 M3) M1.
Proof.
  intros.
  assert (disjoint M1 (merge M2 M3)); auto with PMap.
Qed.

Hint Resolve disj_merge_B : PMap.

Lemma disj_merge_assoc_left_right:
  forall M1 M2 M3, disjoint M1 M2 -> disjoint (merge M1 M2) M3 -> disjoint M1 (merge M2 M3).
Proof.
  intros M1 M2 M3 disj1 disj2.
  assert (disjoint M1 M3).
  apply disj_merge_disj_left with M2.
  auto.
  apply disj_merge_A; auto.
Qed.

Lemma disj_merge_assoc_right_left:
  forall M1 M2 M3, disjoint M2 M3 -> disjoint M1 (merge M2 M3) -> disjoint (merge M1 M2) M3.
Proof.
  intros M1 M2 M3 disj1 disj2.
  assert (disjoint M1 M3).
  apply disj_x_merge_disj_right with M2.
  auto.
  assert (disjoint M3 (merge M1 M2)); auto with PMap.
Qed.

Lemma disj_merge_ABC_BAC:
  forall M1 M2 M3, disjoint M1 M2 -> merge (merge M1 M2) M3 = merge M2 (merge M1 M3).
Proof.
intros M1 M2 M3 disj.
assert (merge M1 M2 = merge M2 M1).
apply disj_merge_commut. auto.
rewrite H.
apply merge_assoc.
Qed.

Hint Resolve disj_merge_assoc_left_right disj_merge_assoc_right_left disj_merge_ABC_BAC : PMap.

Lemma disj_merge_ABC_CAB:
  forall (M_1 M_2 M_3 : Map),
    disjoint M_1 M_2 -> disjoint M_3 M_1 -> disjoint M_3 M_2 ->
    (merge (merge M_1 M_2) M_3) = (merge (merge M_3 M_1) M_2).
Proof.
  intros.
  assert (merge M_1 M_2 = merge M_2 M_1). auto with PMap.
  rewrite H2.
  assert (merge M_3 M_1 = merge M_1 M_3). auto with PMap.
  rewrite H3.
  assert ((merge (merge M_1 M_3) M_2) = (merge M_2 (merge M_1 M_3)));  auto with PMap.
  rewrite H4. auto with PMap.
Qed.

Hint Resolve disj_merge_ABC_CAB : PMap.

(* Properties about disjUnion and merge *)
Lemma disj_emp : forall M, disjoint M emp.
Proof.
  unfold disjoint.
  intros.
  right.
  unfold not_in_dom.
  unfold emp.
  auto.
Qed.

Lemma disj_emp_B : forall M, disjoint emp M.
Proof.
  intro.
  assert (disjoint M emp). apply disj_emp.
  auto with PMap.
Qed.

Lemma unit_emp_merge: forall M, merge M emp = M.
Proof.
  intro M.
  apply extensional_eqMap.
  intros.
  unfold merge.
  induction (M x).
  auto.
  unfold emp.
  auto.
Qed.

Hint Resolve disj_emp disj_emp_B unit_emp_merge : PMap.

Lemma unit_emp_merge_B : forall M, merge emp M = M.
Proof.
  intros.
  assert (merge emp M = merge M emp).
  auto with PMap.
  rewrite H. auto with PMap.
Qed.

Hint Resolve unit_emp_merge_B : PMap.

Lemma unit_emp_disjUnion: forall M, disjUnion M emp M.
Proof.
  intro.
  unfold disjUnion.
  split; auto with PMap.
Qed.

Hint Resolve unit_emp_disjUnion : PMap.

Lemma emp_disjUnion_unique:
  forall M M', disjUnion M emp M' -> M = M'.
Proof.
  intros.
  unfold disjUnion in H.
  inversion_clear H.
  assert (merge M emp = M); auto with PMap.
  rewrite H in H1. auto.
Qed.

Hint Resolve  emp_disjUnion_unique : PMap.

Lemma disjUnion_commut :
  forall M1 M2 M, disjUnion M1 M2 M -> disjUnion M2 M1 M.
Proof.
  unfold disjUnion. intros.
  inversion_clear H.
  split.
  apply disjoint_commut.
  auto.
  assert (merge M1 M2 = merge M2 M1).
  apply disj_merge_commut. auto. rewrite <- H; auto.
Qed.

Hint Resolve disjUnion_commut : PMap.

Lemma disjUnion_in_left:
  forall (M1 M2 M : Map) (x : A) (y : B),
    disjUnion M1 M2 M -> in_dom x M1 -> maps_to M x y -> maps_to M1 x y.
Proof.
  intros.
  unfold disjUnion in H.
  inversion_clear H.
  assert (not_in_dom x M2).
  apply disj_exclusive_left with M1; auto.
  rewrite H3 in H1. unfold not_in_dom in H.
  unfold maps_to. unfold maps_to in H1.
  unfold merge in H1. rewrite H in H1.
  induction (M1 x). auto. inversion_clear H1.
Qed.

Lemma disjUnion_in_right:
  forall (M1 M2 M : Map) (x : A) (y : B),
    disjUnion M1 M2 M -> in_dom x M2 -> maps_to M x y -> maps_to M2 x y.
Proof.
  intros.
  apply disjUnion_in_left with M1 M; auto with PMap.
Qed.

Hint Resolve disjUnion_in_left  disjUnion_in_right: PMap.

Lemma disjUnion_assoc_left_right:
  forall M1 M2 M3 M, disjoint M1 M2 -> disjUnion (merge M1 M2) M3 M -> disjUnion M1 (merge M2 M3) M.
Proof.
  unfold disjUnion. intros.
  inversion_clear H0.
  split.
  auto with PMap.
  rewrite H2. auto with PMap.
Qed.

Hint Resolve disjUnion_assoc_left_right: PMap.

Lemma disjUnion_assoc_right_left:
  forall M1 M2 M3 M, disjoint M2 M3 -> disjUnion M1 (merge M2 M3) M -> disjUnion (merge M1 M2) M3 M.
Proof.
  unfold disjUnion.
  intros.
  inversion_clear H0.
  split; auto with PMap.
  rewrite H2. auto with PMap.
Qed.

Hint Resolve disjUnion_assoc_right_left: PMap.

Lemma disj_merge_unique :
  forall M1 M2 M3 M4, disjoint M1 M2 -> disjoint M3 M4 -> merge M1 M2 = merge M3 M4 -> M1 = M3 -> M2 = M4.
Proof.
  intros M1 M2 M3 M4 disj1 disj2.
  intro eqMerge. intro eq13.
  rewrite eq13 in eqMerge.
  apply extensional_eqMap.
  intro.
  assert (merge M3 M2 x = merge M3 M4 x).
  rewrite <- eqMerge. auto.
  unfold merge in H.
  assert (in_dom x M3 \/ not_in_dom x M3).
  apply in_or_notin.
  inversion_clear H0.
  rewrite eq13 in disj1.
  unfold disjoint in disj1.
  unfold disjoint in disj2.
  assert (not_in_dom x M3 \/ not_in_dom x M4); auto.
  assert (not_in_dom x M3 \/ not_in_dom x M2); auto.
  inversion_clear H0.
  unfold not_in_dom in H3.
  unfold in_dom in H1.
  inversion_clear H1.
  rewrite H3 in H0. inversion_clear H0.
  inversion_clear H2.
  unfold not_in_dom in H0.
  unfold in_dom in H1.
  inversion_clear H1.
  rewrite H0 in H2. inversion_clear H2.
  unfold not_in_dom in H3.
  unfold not_in_dom in H0.
  rewrite <- H3 in H0. auto.
  unfold not_in_dom in H1.
  rewrite H1 in H. auto.
Qed.

Hint Resolve  disj_merge_unique : PMap.

Lemma disj_merge_unique_right :
  forall M1 M2 M3 M4, disjoint M1 M2 -> disjoint M3 M4 -> merge M1 M2 = merge M3 M4 -> M2 = M4 -> M1 = M3.
Proof.
  intros.
  assert (disjoint M2 M1).
  auto with PMap.
  assert (disjoint M4 M3).
  auto with PMap.
  assert (merge M1 M2 = merge M2 M1); auto with PMap.
  assert (merge M3 M4 = merge M4 M3); auto with PMap.
  rewrite H5 in H1. rewrite H6 in H1.
  apply disj_merge_unique with M2 M4; auto.
Qed.

Lemma disjUnion_unique:
  forall M1 M2 M3 M4 M5,
    disjUnion M1 M2 M5 -> disjUnion M3 M4 M5 -> M1 = M3 -> M2 = M4.
Proof.
  intros.
  unfold disjUnion in H.
  unfold disjUnion in H0.
  inversion_clear H.
  inversion_clear H0.
  rewrite H3 in H4.
  apply disj_merge_unique with M1 M3; auto.
Qed.

Lemma disjUnion_equ:
   forall M1 M2 M3 M4 M5,
     disjUnion M1 M3 M4 -> disjUnion M2 M3 M5 -> M1 = M2 -> M4 = M5.
Proof.
   intros.
   unfold disjUnion in H.
   unfold disjUnion in H0.
   inversion_clear H.
   inversion_clear H0.
   rewrite H1 in H3.
   rewrite H3.
   rewrite H4.
   auto.
Qed.

Hint Resolve disj_merge_unique_right disjUnion_unique disjUnion_equ: PMap.

Lemma disjUnion_reshuffle:
  forall M M1 M2 M1' M2' M11,
      disjUnion M1 M2 M -> disjUnion M1' M2' M -> disjUnion M11 M2' M1
      -> disjUnion M11 M2 M1'.
Proof.
  intros.
  unfold disjUnion in H. unfold disjUnion in H0. unfold disjUnion in H1.
  InvertAll.
  assert (disjoint M11 M2).
  rewrite H3 in H0.
  apply disj_merge_disj_left with M2'; auto.
  assert (disjoint M2' M2).
  rewrite H3 in H0.
  apply disj_merge_disj_right with M11; auto.
  unfold disjUnion. split; auto.
  rewrite H3 in H5.
  assert (merge (merge M11 M2') M2 = merge (merge M2 M11) M2').
  auto with PMap.
  rewrite H7 in H5.
  rewrite H5 in H4.
  assert (merge M11 M2 = merge M2 M11). auto with PMap.
  rewrite H8.
  cut (merge M2 M11 = M1'). auto.
  apply disj_merge_unique_right with M2' M2'; auto.
  assert (disjoint M2' M2). auto with PMap.
  auto with PMap.
Qed.

(* properties about subDom and eqDom *)
Lemma eqDom_refl: forall M, eqDom M M.
Proof.
  intro.
  unfold eqDom.
  unfold sub_dom. auto.
Qed.

Lemma eqDom_sym: forall M1 M2, eqDom M1 M2 -> eqDom M2 M1.
Proof.
  intros M1 M2.
  unfold eqDom.
  tauto.
Qed.

Lemma subDom_trans: forall M1 M2 M3, sub_dom M1 M2 -> sub_dom M2 M3 -> sub_dom M1 M3.
Proof.
  intros M1 M2 M3.
  unfold sub_dom.
  intros. auto.
Qed.

Lemma eqDom_trans : forall M1 M2 M3, eqDom M1 M2 -> eqDom M2 M3 -> eqDom M1 M3.
Proof.
  intros M1 M2 M3.
  unfold eqDom.
  intros. inversion_clear H. inversion_clear H0.
  split. apply subDom_trans with M2; auto. apply subDom_trans with M2; auto.
Qed.

Hint Resolve eqDom_refl eqDom_sym subDom_trans eqDom_trans: PMap.

Lemma subDom_update: forall (M : Map) (x : A) (y : B), sub_dom M (put M x y).
Proof.
  intros M x y.
  unfold sub_dom.
  intros x0 INDOM.
  unfold in_dom.
  unfold in_dom in INDOM.
  inversion_clear INDOM.
  unfold put.
  induction (beq_A x0 x). exists y. auto.
  rewrite H. exists x1. auto.
Qed.

Lemma subDom_inDom_update :
  forall (M : Map) (x : A) (y : B), in_dom x M -> sub_dom (put M x y) M.
Proof.
  intros.
  unfold sub_dom.
  unfold in_dom.
  intros.
  inversion_clear H0.
  unfold put in H1.
  induction (beq_A x0 x). unfold in_dom in H.
  inversion_clear H. rewrite a. exists x2. auto.
  exists x1. auto.
Qed.

Lemma eqDom_indom_update_eq :
  forall (M : Map) (x : A) (y : B), in_dom x M -> eqDom M (put M x y).
Proof.
  intros M x y indom.
  unfold eqDom.
  split.
  apply subDom_update.
  apply subDom_inDom_update; auto.
Qed.

Hint Resolve subDom_update subDom_inDom_update eqDom_indom_update_eq : PMap.

(* eqDom and merge / disjUnion *)
Lemma eqDom_merge:
  forall M1 M2 M3 M4, merge M1 M2 = merge M3 M4 -> eqDom M1 M3 -> M1 = M3.
Proof.
  intros M1 M2 M3 M4 MG ED.
  apply extensional_eqMap.
  intro.
  unfold eqDom in ED.
  unfold sub_dom in ED.
  inversion_clear ED.
  assert (in_dom x M1 \/ not_in_dom x M1).
  apply in_or_notin.
  inversion_clear H1.
  assert (in_dom x M3). apply H. auto.
  unfold in_dom in H2. inversion_clear H2.
  unfold in_dom in H1. inversion_clear H1.
  assert (merge M1 M2 x = merge M3 M4 x). rewrite MG. auto.
  unfold merge in H1.
  rewrite H3 in H1. rewrite H2 in H1.
  rewrite H2. rewrite H3. auto.
  assert (in_dom x M3 \/ not_in_dom x M3).
  apply in_or_notin.
  inversion_clear H1.
  assert (in_dom x M1). apply H0. auto.
  unfold in_dom in H1. unfold not_in_dom in H2.
  rewrite H2 in H1. inversion_clear H1. inversion_clear H4.
  unfold not_in_dom in H2. unfold not_in_dom in H3.
  rewrite <- H3 in H2. auto.
Qed.

Lemma eqDom_disjUnion_left:
  forall (M1 M2 M3 M4 M : Map),
    disjUnion M1 M2 M -> disjUnion M3 M4 M -> eqDom M1 M3 -> M1 = M3.
Proof.
  intros M1 M2 M3 M4 M. unfold disjUnion.
  intros DU1 DU2 ED.
  inversion_clear DU1. inversion_clear DU2.
  rewrite H0 in H2.
  apply eqDom_merge with M2 M4; auto.
Qed.

Lemma eqDom_disjUnion_right:
  forall M1 M2 M3 M4 M,
    disjUnion M1 M2 M -> disjUnion M3 M4 M -> eqDom M1 M3 -> M2 = M4.
Proof.
  intros M1 M2 M3 M4 M DU1 DU2 ED.
  assert (M1 = M3). apply eqDom_disjUnion_left with M2 M4 M; auto.
  unfold disjUnion in DU1. unfold disjUnion in DU2.
  inversion_clear DU1. inversion_clear DU2.
  rewrite H1 in H3.
  apply disj_merge_unique with M1 M3; auto.
Qed.
Hint Resolve  eqDom_merge eqDom_disjUnion_left eqDom_disjUnion_right: PMap.

Lemma eqDom_notin_presv:
  forall (M1 M2 : Map) (x : A), eqDom M1 M2 -> not_in_dom x M1 -> not_in_dom x M2.
Proof.
  intros M1 M2 x ED.
  unfold not_in_dom.
  unfold eqDom in ED.
  unfold sub_dom in ED.
  unfold in_dom in ED.
  inversion_clear ED.
  intro.
  assert ((exists b : B, M1 x = Some b) -> exists b : B, M2 x = Some b). auto.
  assert ((exists b : B, M2 x = Some b) -> exists b : B, M1 x = Some b). auto.
  induction (M2 x).
  assert (exists b : B, M1 x = Some b). apply H3. exists a. auto.
  inversion_clear H4. rewrite H1 in H5. inversion_clear H5.
  auto.
Qed.

Lemma eqDom_disj_presv:
  forall (M1 M2 M : Map), eqDom M1 M2 -> disjoint M1 M -> disjoint M2 M.
Proof.
  intros M1 M2 M ED.
  unfold disjoint.
  intros.
  assert (not_in_dom x M1 \/ not_in_dom x M). auto.
  inversion_clear H0. left.
  unfold eqDom in ED.
  apply eqDom_notin_presv with M1; auto.
  right. auto.
Qed.
Hint Resolve  eqDom_notin_presv eqDom_disj_presv: PMap.

Lemma disjUnion_presv_in_dom:
  forall (M1 M2 M : Map) (x : A), in_dom x M1 -> disjUnion M1 M2 M -> in_dom x M.
Proof.
  intros.
  unfold disjUnion in H0.
  inversion_clear H0.
  rewrite H2.
  auto with PMap.
Qed.

Lemma disjUnion_presv_eqDom:
  forall (M1 M2 M3 M4 M M' : Map),
    disjUnion M1 M2 M -> disjUnion M3 M4 M' -> eqDom M1 M3 -> eqDom M2 M4 -> eqDom M M'.
Proof.
  unfold eqDom.
  unfold sub_dom.
  unfold disjUnion.
  intros.
  inversion_clear H1.
  inversion_clear H2.
  inversion_clear H.
  inversion_clear H0.
  unfold in_dom.
  split.
  intros.
  inversion_clear H0.
  rewrite H6 in H8.
  unfold merge in H8.
  assert ((exists b : B, M1 x = Some b) \/ (M1 x = None)).
  induction (M1 x).
  left. exists a. auto. right. auto.
  inversion_clear H0.
  assert (in_dom x M3). apply H3. unfold in_dom. auto.
  unfold in_dom in H0. inversion_clear H0. rewrite H7. unfold merge.
  exists x1. rewrite H10. auto.
  assert (not_in_dom x M3).
  apply not_in_notin. intro. assert (in_dom x M1). apply H4; auto.
  unfold in_dom in H10. inversion_clear H10. rewrite H9 in H11. inversion_clear H11.
  rewrite H9 in H8. assert (in_dom x M4). apply H1. unfold in_dom. exists x0. auto.
  unfold in_dom in H10. inversion_clear H10. exists x1.
  rewrite H7. unfold merge. unfold not_in_dom in H0. rewrite H0. auto.

  intros.
  inversion_clear H0.
  rewrite H7 in H8.
  unfold merge in H8.
  assert ((exists b : B, M3 x = Some b) \/ (M3 x = None)).
  induction (M3 x).
  left. exists a. auto. right. auto.
  inversion_clear H0.
  assert (in_dom x M1). apply H4. unfold in_dom. auto.
  unfold in_dom in H0. inversion_clear H0. rewrite H6. unfold merge.
  exists x1. rewrite H10. auto.
  assert (not_in_dom x M1).
  apply not_in_notin. intro. assert (in_dom x M3). apply H3; auto.
  unfold in_dom in H10. inversion_clear H10. rewrite H9 in H11. inversion_clear H11.
  rewrite H9 in H8. assert (in_dom x M2). apply H5. unfold in_dom. exists x0. auto.
  unfold in_dom in H10. inversion_clear H10. exists x1.
  rewrite H6. unfold merge. unfold not_in_dom in H0. rewrite H0. auto.
Qed.
Hint Resolve disjUnion_presv_in_dom disjUnion_presv_eqDom: PMap.

Lemma remove_left_presv_disjUnion_left:
  forall (M1 M2 M : Map) (x : A),
    disjUnion M1 M2 M -> in_dom x M1 -> disjUnion (remove M1 x) M2 (remove M x).
Proof.
  intros M1 M2 M x.
  unfold disjUnion. intros.
  inversion_clear H.
  split.
  auto with PMap.
  rewrite H2.
  apply disj_remove_merge_merge_remove; auto.
Qed.

Hint Resolve remove_left_presv_disjUnion_left : PMap.

Lemma remove_left_presv_disjUnion_right:
  forall (M1 M2 M : Map) (x : A),
    disjUnion M1 M2 M -> in_dom x M2 -> disjUnion M1 (remove M2 x) (remove M x).
Proof.
  intros.
  cut (disjUnion (remove M2 x) M1 (remove M x)); auto with PMap.
Qed.

Hint Resolve remove_left_presv_disjUnion_right : PMap.

Lemma extend_presv_disjUnion_left:
  forall (M1 M2 M : Map) (x : A) (y : B),
    disjUnion M1 M2 M -> not_in_dom x M2 -> disjUnion (put M1 x y) M2 (put M x y).
Proof.
  intros M1 M2 M x y.
  unfold disjUnion.
  intros.
  inversion_clear H.
  split.
  auto with PMap.
  rewrite H2.
  apply put_merge_merge_put.
Qed.

Hint Resolve extend_presv_disjUnion_left : PMap.

Lemma extend_presv_disjUnion_right:
  forall (M1 M2 M : Map) (x : A) (y : B),
    disjUnion M1 M2 M -> not_in_dom x M1 -> disjUnion M1 (put M2 x y) (put M x y).
Proof.
  intros.
  cut (disjUnion (put M2 x y) M1 (put M x y)); auto with PMap.
Qed.

Hint Resolve extend_presv_disjUnion_right : PMap.

Lemma update_presv_disjUnion_left:
  forall (M1 M2 M : Map) (x : A) (y : B),
    disjUnion M1 M2 M -> in_dom x M1 -> disjUnion (put M1 x y) M2 (put M x y).
Proof.
  intros.
  assert (not_in_dom x M2).
  apply disj_exclusive_left with M1; auto.
  unfold disjUnion in H. inversion_clear H. auto.
  auto with PMap.
Qed.

Hint Resolve update_presv_disjUnion_left : PMap.

Lemma update_presv_disjUnion_right:
  forall (M1 M2 M : Map) (x : A) (y : B),
    disjUnion M1 M2 M -> in_dom x M2 -> disjUnion M1 (put M2 x y) (put M x y).
Proof.
  intros.
  cut (disjUnion (put M2 x y) M1 (put M x y)); auto with PMap.
Qed.

Hint Resolve update_presv_disjUnion_right : PMap.

(* disjunion and subseteq *)
Lemma disjoint_merge_subseteq:
  forall M_1 M_2 M, disjoint M_1 M_2 -> subseteq M_1 M -> subseteq M_2 M -> subseteq (merge M_1 M_2) M.
Proof.
  intros.
  unfold subseteq.
  intros.
  unfold merge in H2.
  unfold in_dom in H2.
  unfold merge.
  unfold subseteq in H0.
  unfold in_dom in H0.
  assert (M_1 x = None \/ exists y, M_1 x = Some y).
  induction (M_1 x).
  right.
  exists a. auto.
  left. auto.
  inversion_clear H3.
  rewrite H4. rewrite H4 in H2.
  unfold subseteq in H1.
  apply H1. unfold in_dom. auto.
  inversion_clear H4.
  rewrite H3.
  rewrite <- H3.
  apply H0. exists x0. auto.
Qed.
Hint Resolve disjoint_merge_subseteq : PMap.

Lemma disjUnion_subseteq_left:
  forall M_1 M_2 M, disjUnion M_1 M_2 M -> subseteq M_1 M.
Proof.
  intros.
  unfold disjUnion in H.
  inversion_clear H.
  rewrite H1.
  apply merge_extends_map.
Qed.

Lemma disjUnion_subseteq_right:
  forall M_1 M_2 M, disjUnion M_1 M_2 M -> subseteq M_2 M.
Proof.
  intros.
  apply disjUnion_subseteq_left with M_1.
  apply disjUnion_commut; auto.
Qed.

Lemma split_sglton_free:
  forall M x y, maps_to M x y -> disjUnion (put emp x y) (remove M x) M.
Proof.
  intros.
  unfold disjUnion.
  unfold put.
  unfold remove.
  split.
  unfold disjoint.
  intro.
  unfold not_in_dom.
  induction (beq_A x0 x).
  right. auto.
  left. unfold emp. auto.
  unfold merge.
  apply extensional_eqMap.
  intro.
  induction (beq_A x0 x).
  unfold maps_to in H.
  rewrite <- a in H. auto.
  unfold emp. auto.
Qed.
Hint Resolve disjUnion_subseteq_left disjUnion_subseteq_right split_sglton_free : PMap.

Lemma ext_emp_sglton:
  forall x y, sgltonM (put emp x y) x y.
Proof.
  unfold sgltonM.
  unfold emp.
  unfold put.
  unfold maps_to.
  unfold not_in_dom.
  intros.
  split.
  induction (beq_A x x). auto.
  assert (x = x). auto.
  contradiction.
  intros.
  induction (beq_A x0 x).
  contradiction. auto.
Qed.

Hint Resolve ext_emp_sglton.

(* properties about subseteq *)

Lemma subseteq_transitivity:
  forall M M' M'', subseteq M M' -> subseteq M' M'' -> subseteq M M''.
Proof.
  intros.
  unfold subseteq.
  intros.
  assert (M x = M' x).
  unfold subseteq in H.
  apply H; auto.
  rewrite H2.
  unfold subseteq in H0.
  apply H0.
  unfold in_dom.
  unfold in_dom in H1.
  inversion H1.
  rewrite H3 in H2.
  exists x0.
  rewrite <- H2. auto.
Qed.

Hint Resolve subseteq_transitivity: PMap.

Lemma subset_unique_map:
  forall M M' x y, subseteq M M' -> maps_to M x y -> maps_to M' x y.
Proof.
  unfold subseteq.
  unfold maps_to.
  unfold in_dom.
  intros.
  assert (M x = M' x).
  apply H. exists y. auto.
  rewrite <- H1. auto.
Qed.
Hint Resolve subset_unique_map: PMap.

Definition minus (M M' : Map) : Map :=
  fun x =>
    match M' x with
      None => M x
    | Some _ => None
    end.

Lemma minus_disjoint:
  forall M M', disjoint M' (minus M M').
Proof.
  intros.
  unfold disjoint.
  unfold not_in_dom.
  intro x.
  assert (M' x = None \/ exists y, M' x = Some y).
  induction (M' x).
  right.
  exists a. auto. left. auto.
  inversion_clear H.
  left. auto.
  right.
  unfold minus.
  inversion_clear H0.
  rewrite H. auto.
Qed.
Hint Resolve minus_disjoint : PMap.

Lemma minus_disjUnion:
  forall M M', subseteq M' M -> disjUnion M' (minus M M') M.
Proof.
  intros.
  unfold disjUnion. split; auto with PMap.
  apply extensional_eqMap.
  intro.
  unfold merge. unfold minus.
  assert (M' x = None \/ exists y, M' x = Some y).
  induction (M' x). right. eauto. left. auto.
  inversion_clear H0.
  rewrite H1. auto.
  inversion_clear H1.
  rewrite H0.
  unfold subseteq in H.
  rewrite <- H0.
  assert (M' x = M x).
  apply H. unfold in_dom. exists x0. auto. auto.
Qed.
Hint Resolve minus_disjUnion: PMap.

Lemma subseteq_split:
  forall M' M, subseteq M' M -> exists M'', disjUnion M' M'' M.
Proof.
  intros.
  exists (minus M M').
  auto with PMap.
Qed.
Hint Resolve subseteq_split : PMap.

Lemma ext_in_dom:
  forall x y M, in_dom x (put M x y).
Proof.
  intros.
  unfold put.
  unfold in_dom.
  induction (beq_A x x).
  exists y. auto.
  assert (x = x). auto.
  contradiction.
Qed.

Hint Resolve ext_in_dom : PMap.

Lemma ext_mapsto:
  forall x y M, maps_to (put M x y) x y.
Proof.
  unfold maps_to.
  intros.
  auto with PMap.
Qed.

Hint Resolve ext_mapsto.

Lemma mapsto_indom:
  forall x y M, maps_to M x y -> in_dom x M.
Proof.
  unfold in_dom.
  unfold maps_to.
  intros.
  exists y. auto.
Qed.

Lemma ext_presv_mapsto:
  forall M x x' y y',
    x <> x' -> maps_to (put M x y) x' y' -> maps_to M x' y'.
Proof.
  intros.
  unfold maps_to.
  unfold maps_to in H0.
  unfold put in H0.
  induction (beq_A x' x).
  assert (x = x'). auto. contradiction.
  auto.
Qed.
Hint Resolve mapsto_indom ext_presv_mapsto: PMap.

Lemma put_xy_commut:
  forall M x x' y y',
    x <> x' -> put (put M x y) x' y' = put (put M x' y') x y.
Proof.
  intros.
  apply extensional_eqMap.
  unfold put.
  intro.
  induction (beq_A x0 x').
  induction (beq_A x0 x).
  rewrite a0 in a. contradiction. auto.
  induction (beq_A x0 x). auto.
  auto.
Qed.

Lemma put_xx_update:
  forall M x y y',
    put (put M x y) x y' = put M x y'.
Proof.
  intros.
  apply extensional_eqMap.
  unfold put.
  intro.
  induction (beq_A x0 x); auto.
Qed.

Hint Resolve put_xy_commut put_xx_update: PMap.

Lemma removeX_presv_Y:
  forall M x x' y,
    x <> x' -> maps_to M x' y -> maps_to (remove M x) x' y.
Proof.
  intros.
  unfold maps_to.
  unfold remove.
  induction (beq_A x' x).
  assert (x = x'). auto. contradiction.
  unfold maps_to in H0. auto.
Qed.
Hint Resolve removeX_presv_Y : PMap.

End MapFun.


Definition relation (A : Type) := A -> A -> Type.

Class Reflexive {A} (R : relation A) :=
  reflexivity : forall x : A, R x x.

Class Symmetric {A} (R : relation A) :=
  symmetry : forall x y, R x y -> R y x.

Class Transitive {A} (R : relation A) :=
  transitivity : forall x y z, R x y -> R y z -> R x z.

Class PreOrder {A} (R : relation A) :=
  { PreOrder_Reflexive : Reflexive R | 2 ;
    PreOrder_Transitive : Transitive R | 2 }.

Global Existing Instance PreOrder_Reflexive.
Global Existing Instance PreOrder_Transitive.

Arguments reflexivity {A R _} / _.
Arguments symmetry {A R _} / _ _ _.
Arguments transitivity {A R _} / {_ _ _} _ _.

Ltac symmetry :=
  let R := match goal with |- ?R ?x ?y => constr:(R) end in
  let x := match goal with |- ?R ?x ?y => constr:(x) end in
  let y := match goal with |- ?R ?x ?y => constr:(y) end in
  let pre_proof_term_head := constr:(@symmetry _ R _) in
  let proof_term_head := (eval cbn in pre_proof_term_head) in
  refine (proof_term_head y x _); change (R y x).

Tactic Notation "etransitivity" open_constr(y) :=
  let R := match goal with |- ?R ?x ?z => constr:(R) end in
  let x := match goal with |- ?R ?x ?z => constr:(x) end in
  let z := match goal with |- ?R ?x ?z => constr:(z) end in
  let pre_proof_term_head := constr:(@transitivity _ R _) in
  let proof_term_head := (eval cbn in pre_proof_term_head) in
  refine (proof_term_head x y z _ _); [ change (R x y) | change (R y z) ].

Tactic Notation "etransitivity" := etransitivity _.

Ltac transitivity x := etransitivity x.

Notation Type0 := Set.

Notation idmap := (fun x => x).

Delimit Scope equiv_scope with equiv.
Delimit Scope function_scope with function.
Delimit Scope path_scope with path.
Delimit Scope fibration_scope with fibration.
Delimit Scope trunc_scope with trunc.

Open Scope trunc_scope.
Open Scope equiv_scope.
Open Scope path_scope.
Open Scope fibration_scope.
Open Scope nat_scope.
Open Scope function_scope.
Open Scope type_scope.
Open Scope core_scope.

Definition const {A B} (b : B) := fun x : A => b.

Notation "( x ; y )" := (existT _ x y) : fibration_scope.

Bind Scope fibration_scope with sigT.

Notation pr1 := projT1.
Notation pr2 := projT2.

Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }.

Scheme sig_rect := Induction for sig Sort Type.
Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.

Arguments exist {A}%type P%type _ _.
Arguments proj1_sig {A P} _ / .
Arguments proj2_sig {A P} _ / .

Inductive sig2 (A:Type) (P Q:A -> Type) : Type :=
    exist2 (x : A) (_ : P x) (_ : Q x).

Notation sigT := sig (only parsing).
Notation existT := exist (only parsing).
Notation sigT_rect := sig_rect (only parsing).
Notation sigT_rec := sig_rect (only parsing).
Notation sigT_ind := sig_rect (only parsing).
Notation sigT2 := sig2 (only parsing).
Notation existT2 := exist2 (only parsing).
Notation sigT2_rect := sig2_rect (only parsing).
Notation sigT2_rec := sig2_rect (only parsing).
Notation sigT2_ind := sig2_rect (only parsing).

Notation ex_intro := existT (only parsing).

Notation "{ x | P }" := (sigT (fun x => P)) : type_scope.
Notation "{ x | P & Q }" := (sigT2 (fun x => P) (fun x => Q)) : type_scope.
Notation "{ x : A | P }" := (sigT (A := A) (fun x => P)) : type_scope.
Notation "{ x : A | P & Q }" := (sigT2 (fun x : A => P) (fun x : A => Q)) :
  type_scope.

Notation "'exists' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists' '/ ' x .. y , '/ ' p ']'")
  : type_scope.

Notation "'exists2' x , p & q" := (sigT2 (fun x => p) (fun x => q))
  (at level 200, x ident, p at level 200, right associativity) : type_scope.
Notation "'exists2' x : t , p & q" := (sigT2 (fun x:t => p) (fun x:t => q))
  (at level 200, x ident, t at level 200, p at level 200, right associativity,
    format "'[' 'exists2' '/ ' x : t , '/ ' '[' p & '/' q ']' ']'")
  : type_scope.

Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope.
Notation "{ x : A & P & Q }" := (sigT2 (fun x:A => P) (fun x:A => Q)) :
  type_scope.

Add Printing Let sig.
Add Printing Let sig2.

Arguments sig (A P)%type.
Arguments sig2 (A P Q)%type.

Notation compose := (fun g f x => g (f x)).

Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope.

Inductive option (A : Type) : Type :=
  | Some : A -> option A
  | None : option A.

Arguments None [A].

Inductive sum (A B : Type) : Type :=
  | inl : A -> sum A B
  | inr : B -> sum A B.

Notation "x + y" := (sum x y) : type_scope.

Arguments inl {A B} _ , [A] B _.
Arguments inr {A B} _ , A [B] _.

Notation "A \/ B" := (A + B)%type (only parsing) : type_scope.
Notation or := sum (only parsing).

Record prod (A B : Type) := pair { fst : A ; snd : B }.

Scheme prod_rect := Induction for prod Sort Type.

Arguments pair {A B} _ _.
Arguments fst {A B} _ / .
Arguments snd {A B} _ / .

Add Printing Let prod.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
Notation "A /\ B" := (prod A B) (only parsing) : type_scope.
Notation and := prod (only parsing).
Notation conj := pair (only parsing).

Hint Resolve pair inl inr : core.

Definition prod_curry (A B C : Type) (f : A -> B -> C)
  (p : prod A B) : C := f (fst p) (snd p).

Definition iff (A B : Type) := prod (A -> B) (B -> A).

Notation "A <-> B" := (iff A B) : type_scope.

Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

Delimit Scope nat_scope with nat.
Bind Scope nat_scope with nat.
Arguments S _%nat.
Arguments S _.

Open Scope nat_scope.

Definition iff_compose {A B C : Type} (g : B <-> C) (f : A <-> B): A <-> C := (fst g o fst f , snd f o snd g).

Definition iff_inverse {A B : Type} : (A <-> B) -> (B <-> A) := fun f => (snd f , fst f).

Definition composeD {A B C} (g : forall b, C b) (f : A -> B) := fun x : A => g (f x).

Global Arguments composeD {A B C}%type_scope (g f)%function_scope x.

Hint Unfold composeD.

Notation "g 'oD' f" := (composeD g f) (at level 40, left associativity) : function_scope.

(*The groupoid structure of identity types.*)

Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.

Arguments paths_ind [A] a P f y p.
Arguments paths_rec [A] a P f y p.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Lemma paths_rew A a y P (X : P a) (H : a = y :> A) : P y.
Proof.
rewrite <- H.
apply X.
Qed.

Lemma paths_rew_r A a y P (X : P y) (H : a = y :> A) : P a.
Proof.
rewrite -> H.
apply X.
Qed.

Global Instance reflexive_paths {A} : Reflexive (@paths A) | 0 := @idpath A.
Arguments reflexive_paths / .

Bind Scope path_scope with paths.

Local Open Scope path_scope.

Definition inverse {A : Type} {x y : A} (p : x = y) : y = x.
rewrite -> p.
reflexivity.
Qed.

Arguments inverse {A x y} p : simpl nomatch.

Global Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A.
Arguments symmetric_paths / .

Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
Proof.
induction p.
rewrite q.
reflexivity.
Qed.

Arguments concat {A x y z} p q : simpl nomatch.

Global Instance transitive_paths {A} : Transitive (@paths A) | 0 := @concat A.
Arguments transitive_paths / .

Notation "1" := idpath : path_scope.

Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope.

Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope.

Notation "p @' q" := (concat p q) (at level 21, left associativity,
  format "'[v' p '/' '@'' q ']'") : long_path_scope.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y.
Proof.
rewrite <- p.
apply u.
Qed.

Arguments transport {A}%type_scope P%function_scope {x y} p%path_scope u : simpl nomatch.

Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y.
Proof.
rewrite <- p.
reflexivity.
Qed.

Global Arguments ap {A B}%type_scope f%function_scope {x y} p%path_scope.

Definition pointwise_paths {A} {P:A -> Type} (f g : forall x : A, P x) := forall x:A, f x = g x.

Global Arguments pointwise_paths {A}%type_scope {P} (f g)%function_scope.

Hint Unfold pointwise_paths : typeclass_instances.

Definition pointwise_paths_refl {A} {P:A -> Type} (f : forall x : A, P x) := forall x:A, f x = f x.

Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.

Require Import Setoid.

Definition apD10 {A} {B:A -> Type} {f g : forall x, B x} (h:f=g)
  : f == g.
Proof.
rewrite <- h.
intros x.
reflexivity.
Qed.

Global Arguments apD10 {A%type_scope B} {f g}%function_scope h%path_scope _.

Definition ap10 {A B} {f g:A -> B} (h:f=g) : f == g
  := apD10 h.

Global Arguments ap10 {A B}%type_scope {f g}%function_scope h%path_scope _.

Notation happly := ap10 (only parsing).

Definition ap11 {A B} {f g:A -> B} (h:f=g) {x y:A} (p:x=y) : f x = g y.
Proof.
  case h, p; reflexivity.
Defined.

Global Arguments ap11 {A B}%type_scope {f g}%function_scope h%path_scope {x y} p%path_scope.

Arguments ap {A B} f {x y} p : simpl nomatch.

Ltac path_induction :=
intros; repeat progress (
match goal with
 | [p: _ = _ |-_] => induction p
 | _ => idtac
 end
); auto.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Global Arguments Sect {A B}%type_scope (s r)%function_scope.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
}.

Arguments eisretr {A B}%type_scope f%function_scope {_} _.
Arguments eissect {A B}%type_scope f%function_scope {_} _.
Arguments eisadj {A B}%type_scope f%function_scope {_} _.
Arguments IsEquiv {A B}%type_scope f%function_scope.

Record Equiv A B := BuildEquiv {
  equiv_fun : A -> B ;
  equiv_isequiv : IsEquiv equiv_fun
}.

Coercion equiv_fun : Equiv >-> Funclass.

Global Existing Instance equiv_isequiv.

Arguments equiv_fun {A B} _ _.
Arguments equiv_isequiv {A B} _.

Bind Scope equiv_scope with Equiv.

Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope.

Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope.

Definition ap10_equiv {A B : Type} {f g : A <~> B} (h : f = g) : f == g.
Proof.
path_induction.
intros x.
reflexivity.
Qed.

Class Contr_internal (A : Type) := BuildContr {
  center : A ;
  contr : (forall y : A, center = y)
}.

Arguments center A {_}.

Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

Bind Scope trunc_scope with trunc_index.
Arguments trunc_S _%trunc_scope.

Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
Notation "n .+1" := (S n) (at level 2, left associativity, format "n .+1") : nat_scope.
Notation "n .+2" := (n.+1.+1)%trunc (at level 2, left associativity, format "n .+2") : trunc_scope.
Notation "n .+2" := (n.+1.+1)%nat (at level 2, left associativity, format "n .+2") : nat_scope.
Notation "n .+3" := (n.+1.+2)%trunc (at level 2, left associativity, format "n .+3") : trunc_scope.
Notation "n .+3" := (n.+1.+2)%nat (at level 2, left associativity, format "n .+3") : nat_scope.
Notation "n .+4" := (n.+1.+3)%trunc (at level 2, left associativity, format "n .+4") : trunc_scope.
Notation "n .+4" := (n.+1.+3)%nat (at level 2, left associativity, format "n .+4") : nat_scope.
Notation "n .+5" := (n.+1.+4)%trunc (at level 2, left associativity, format "n .+5") : trunc_scope.
Notation "n .+5" := (n.+1.+4)%nat (at level 2, left associativity, format "n .+5") : nat_scope.
Local Open Scope trunc_scope.
Notation "-2" := minus_two (at level 0) : trunc_scope.
Notation "-1" := (-2.+1) (at level 0) : trunc_scope.
Notation "0" := (-1.+1) : trunc_scope.
Notation "1" := (0.+1) : trunc_scope.
Notation "2" := (1.+1) : trunc_scope.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | -2 => Contr_internal A
    | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Arguments IsTrunc_internal n A : simpl nomatch.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.

Typeclasses Opaque IsTrunc.
Arguments IsTrunc : simpl never.
Global Instance istrunc_paths (A : Type) n `{H : IsTrunc n.+1 A} (x y : A)
: IsTrunc n (x = y)
  := H x y.

Notation Contr := (IsTrunc -2).
Notation IsHProp := (IsTrunc -1).
Notation IsHSet := (IsTrunc 0).

Ltac simple_induction n n' IH :=
  generalize dependent n;
  fix IH 1;
  intros [| n'];
  [ clear IH | specialize (IH n') ].

Notation is_mere_relation A R := (forall (x y : A), IsHProp (R x y)).

Monomorphic Axiom dummy_funext_type : Type0.
Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.
Axiom isequiv_apD10 : forall `{Funext} (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g).
Global Existing Instance isequiv_apD10.

Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) :
  f == g -> f = g
  :=
  (@apD10 A P f g)^-1.

Global Arguments path_forall {_ A%type_scope P} (f g)%function_scope _.

Definition path_forall2 `{Funext} {A B : Type} {P : A -> B -> Type} (f g : forall x y, P x y) :
  (forall x y, f x y = g x y) -> f = g
  :=
  (fun E => path_forall f g (fun x => path_forall (f x) (g x) (E x))).

Global Arguments path_forall2 {_} {A B}%type_scope {P} (f g)%function_scope _.

Hint Resolve
  @idpath @inverse
 : path_hints.

Hint Resolve @idpath : core.

Ltac path_via mid := apply @concat with (y := mid); auto with path_hints.

Definition Type1 := Type.

Inductive Empty : Type1 := .

Definition not (A:Type) : Type := A -> Empty.
Notation "~ x" := (not x) : type_scope.
Hint Unfold not: core.
Notation "x <> y :> T" := (not (x = y :> T))
(at level 70, y at next level, no associativity) : type_scope.
Notation "x <> y" := (not(x = y :> _)) (at level 70, no associativity) : type_scope.

Definition symmetric_neq {A} {x y : A} : x <> y -> y <> x
  := fun np p => np (p^).
Typeclasses Opaque complement.

Definition complement {A} (x y : A) (R : relation A) := ~ (R x y).

Definition irreflexive {A} (x : A) (R : relation A) := ~ (R x x).

Definition Asymmetric {A} (x y : A) (R : relation A) := ~ (R x y -> R y x).

Class IsPointed (A : Type) := point : A.

Arguments point A {_}.

Record pType :=
  { pointed_type : Type ;
    ispointed_type : IsPointed pointed_type }.

Coercion pointed_type : pType >-> Sortclass.

Global Existing Instance ispointed_type.

Inductive Unit : Type1 :=
    tt : Unit.

Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.

Ltac rapply p :=
  refine p ||
  refine (p _) ||
  refine (p _ _) ||
  refine (p _ _ _) ||
  refine (p _ _ _ _) ||
  refine (p _ _ _ _ _) ||
  refine (p _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _).

Ltac rapply' p :=
  refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _ _) ||
  refine (p _ _ _ _ _ _) ||
  refine (p _ _ _ _ _) ||
  refine (p _ _ _ _) ||
  refine (p _ _ _) ||
  refine (p _ _) ||
  refine (p _) ||
  refine p.

Tactic Notation "erapply" open_constr(term) := rapply term.

Tactic Notation "erapply'" open_constr(term) := rapply' term.

Ltac done :=
  trivial; intros; solve
    [ repeat first
      [ solve [trivial]
      | solve [symmetry; trivial]
      | reflexivity

      | contradiction
      | split ]
    | match goal with
      H : ~ _ |- _ => solve [destruct H; trivial]
      end ].
Tactic Notation "by" tactic(tac) :=
  tac; done.

Ltac by_extensionality x :=
  intros;
  match goal with
  | [ |- ?f = ?g ] => eapply path_forall; intro x;
      match goal with
        | [ |- forall (_ : prod _ _), _ ] => intros [? ?]
        | [ |- forall (_ : sigT _ _), _ ] => intros [? ?]
        | _ => intros
    end;
    simpl; auto with path_hints
  end.

Ltac f_ap :=
  idtac;
  lazymatch goal with
    | [ |- ?f ?x = ?g ?x ] => apply (@apD10 _ _ f g);
                             try (done || f_ap)
    | _ => apply ap11;
          [ done || f_ap
          | trivial ]
  end.

Ltac expand :=
  idtac;
  match goal with
    | [ |- ?X = ?Y ] =>
      let X' := eval hnf in X in let Y' := eval hnf in Y in change (X' = Y')
    | [ |- ?X == ?Y ] =>
      let X' := eval hnf in X in let Y' := eval hnf in Y in change (X' == Y')
  end; simpl.

Ltac revert_opaque x :=
  revert x;
  match goal with
    | [ |- forall _, _ ] => idtac
    | _ => fail 1 "Reverted constant is not an opaque variable"
  end.

Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" :=
  simple refine (let __transparent_assert_hypothesis := (_ : type) in _);
  [
  | (
    let H := match goal with H := _ |- _ => constr:(H) end in
    rename H into name) ].

Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" "by" tactic3(tac) := let name := fresh "H" in transparent assert (name : type); [ solve [ tac ] | ].
Tactic Notation "transparent" "eassert" "(" ident(name) ":" open_constr(type) ")" := transparent assert (name : type).
Tactic Notation "transparent" "eassert" "(" ident(name) ":" open_constr(type) ")" "by" tactic3(tac) := transparent assert (name : type) by tac.

Ltac remember_as term name eqname :=
  set (name := term) in *;
  pose (eqname := idpath : term = name);
  clearbody eqname name.

Tactic Notation "remember" constr(term) "as" ident(name) "eqn:" ident(eqname) :=
  remember_as term name eqname.

Ltac recall_as term name eqname :=
  pose (name := term);
  pose (eqname := idpath : term = name);
  clearbody eqname name.

Tactic Notation "recall" constr(term) "as" ident(name) "eqn:" ident(eqname) :=
  recall_as term name eqname.

Ltac rel_hnf :=
  idtac;
  match goal with
    | [ |- ?R ?x ?y ] => let x' := (eval hnf in x) in
                         let y' := (eval hnf in y) in
                         change (R x' y')
  end.

Inductive Pos : Type1 :=
| one : Pos
| succ_pos : Pos -> Pos.

Definition one_neq_succ_pos (z : Pos) : ~ (one = succ_pos z).
Proof.
intros x.
inversion x.
Qed.

Definition succ_pos_injective {z w : Pos} (p : succ_pos z = succ_pos w) : z = w.
Proof.
inversion p.
reflexivity.
Qed.

Inductive Int : Type1 :=
| neg : Pos -> Int
| zero : Int
| pos : Pos -> Int.

Definition neg_injective {z w : Pos} (p : neg z = neg w) : z = w.
Proof.
inversion p.
reflexivity.
Qed.

Definition pos_injective {z w : Pos} (p : pos z = pos w) : z = w.
Proof.
inversion p.
reflexivity.
Qed.

Definition neg_neq_zero {z : Pos} : ~ (neg z = zero).
Proof.
intros H.
inversion H.
Qed.

Definition pos_neq_zero {z : Pos} : ~ (pos z = zero).
Proof.
intros H.
inversion H.
Qed.

Print pos_neq_zero.

Definition neg_neq_pos {z w : Pos} : ~ (neg z = pos w).
Proof.
intros H.
inversion H.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Import Reals.

Local Open Scope R_scope.

Definition Req_bool (a b : R) : bool :=
  match Req_EM_T a b with left _ => true | _ => false end.

Lemma eqRP : Equality.axiom Req_bool.
Proof.
move=> a b.
apply: (iffP idP); rewrite /Req_bool; by case: (Req_EM_T a b).
Qed.

Canonical R_eqMixin := EqMixin eqRP.
Canonical R_eqType := Eval hnf in EqType R R_eqMixin.

Definition Rge_bool (a b : R) : bool :=
  match Rge_dec a b with left _ => true | _ => false end.

Definition Rle_bool a b := Rge_bool b a.

Definition Rlt_bool (a b : R) : bool :=
  match Rlt_dec a b with left _ => true | _ => false end.

Definition Rgt_bool a b := Rlt_bool b a.

Notation "a '>b=' b" := (Rge_bool a b) (at level 70) : Rb_scope.
Notation "a '<b=' b" := (Rle_bool a b) (at level 70) : Rb_scope.
Notation "a '<b=' b '<b=' c" := (Rle_bool a b && Rle_bool b c) (at level 70, b at next level) : Rb_scope.
Notation "a '<b' b" := (Rlt_bool a b) (at level 70) : Rb_scope.
Notation "a '<b' b '<b' c" := (Rlt_bool a b && Rlt_bool b c) (at level 70, b at next level) : Rb_scope.
Notation "a '>b' b" := (Rgt_bool a b) (at level 70) : Rb_scope.

Local Open Scope Rb_scope.

Lemma RgeP (a b : R) : reflect (a >= b) (a >b= b).
Proof.
move H : (a >b= b) => [|].
  constructor.
  rewrite /Rge_bool in H.
  by case: Rge_dec H.
constructor.
move/negP in H.
contradict H.
rewrite /Rge_bool.
by case: Rge_dec.
Qed.

Lemma RleP (a b : R) : reflect (a <= b) (a <b= b).
Proof.
move H : (a <b= b) => [|].
  constructor.
  rewrite /Rle_bool /Rge_bool in H.
  case: Rge_dec H => //.
  by move/Rge_le.
constructor.
move/negP in H.
contradict H.
rewrite /Rle_bool /Rge_bool.
case: Rge_dec => //.
rewrite /Rle in H.
rewrite /Rge /Rgt.
by intuition.
Qed.

Lemma RltP (a b : R) : reflect (a < b) (a <b b).
Proof.
move H : (a <b b) => [|].
  constructor.
  rewrite /Rlt_bool in H.
  by case: Rlt_dec H.
constructor.
move/negP in H.
contradict H.
rewrite /Rlt_bool.
by case: Rlt_dec.
Qed.

Definition add0R : left_id 0 Rplus := Rplus_0_l.
Definition addR0 : right_id 0 Rplus := Rplus_0_r.

Lemma addRC : commutative Rplus.
Proof. move=> m n; by rewrite Rplus_comm. Qed.

Lemma addRA : associative Rplus.
Proof. move=> m n p; by rewrite Rplus_assoc. Qed.

Definition subR0 : right_id 0 Rminus := Rminus_0_r.

Definition mul0R : left_zero 0 Rmult := Rmult_0_l.
Definition mulR0 : right_zero 0 Rmult := Rmult_0_r.
Definition mul1R : ssrfun.left_id 1%R Rmult := Rmult_1_l.
Definition mulR1 : ssrfun.right_id 1%R Rmult := Rmult_1_r.

Definition mulRC : commutative Rmult := Rmult_comm.

Lemma mulRDl : left_distributive Rmult Rplus.
Proof. move=> *; by rewrite Rmult_plus_distr_r. Qed.
Lemma mulRDr : right_distributive Rmult Rplus.
Proof. move=> *; by rewrite Rmult_plus_distr_l. Qed.

Lemma mulRA : associative Rmult.
Proof. move=> m n p; by rewrite Rmult_assoc. Qed.

Lemma leRR r : r <b= r.
Proof. apply/RleP. by apply Rle_refl. Qed.

(* Rnot_lt_le
     : forall r1 r2 : R, ~ r1 < r2 -> r2 <= r1 *)
(* Rlt_not_le
     : forall r1 r2 : R, r2 < r1 -> ~ r1 <= r2 *)
Lemma RleNgt m n : (m <b= n) = ~~ (n <b m).
Proof.
move H : (_ <b _) => [|].
  rewrite /=.
  apply/RleP.
  apply Rlt_not_le.
  by apply/RltP.
rewrite /=.
apply/RleP.
apply Rnot_lt_le.
apply/RltP.
by apply/negbT.
Qed.

Lemma RltNge m n : (m <b n) = ~~ (n <b= m).
Proof.
move H : (_ <b _) => [|].
  symmetry.
  apply/RleP.
  apply Rlt_not_le.
  by apply/RltP.
symmetry.
apply/RleP.
apply Rnot_lt_le.
apply/RltP.
by apply/negbT.
Qed.

Lemma ltRR n : n <b n = false.
Proof.
apply/RltP.
by apply Rlt_irrefl.
Qed.

(* Rplus_le_compat. *)
Lemma Rle_add m1 m2 n1 n2 : m1 <b= n1 -> m2 <b= n2 -> m1 + m2 <b= n1 + n2.
Proof.
move=> H1 H2.
apply/RleP.
apply Rplus_le_compat; by apply/RleP.
Qed.

Lemma Rle_eqVlt m n : (m <b= n) = (m == n) || (m <b n).
Proof.
move Hlhs : (_ <b= _) => [].
  symmetry.
  move/RleP in Hlhs.
  case/Rle_lt_or_eq_dec : Hlhs => Hlhs.
    by apply/orP; right; apply/RltP.
  by rewrite Hlhs eqxx.
symmetry.
apply/negbTE.
rewrite negb_or.
apply/andP; split.
  apply/eqP => ?; subst m.
  by rewrite leRR in Hlhs.
rewrite -RleNgt.
move/negbT in Hlhs.
rewrite -RltNge in Hlhs.
apply/RleP.
apply Rlt_le.
by apply/RltP.
Qed.

Lemma Rlt_neqAle m n : (m <b n) = (m != n) && (m <b= n).
Proof. by rewrite RltNge Rle_eqVlt negb_or -RleNgt eq_sym. Qed.

Definition RltW m n : m < n -> m <= n := Rlt_le m n.

Lemma subRKC m n : m + (n - m) = n. Proof. ring. Qed.

(* Rplus_le_compat_r
     : forall r r1 r2 : R, r1 <= r2 -> r1 + r <= r2 + r*)

Lemma Rle_add2r p m n : (m + p <b= n + p) = (m <b= n).
Proof.
move Hlhs : (_ + _ <b= _) => [].
  symmetry.
  apply/RleP.
  apply Rplus_le_reg_r with p.
  by apply/RleP.
symmetry.
apply/negP.
move/negP in Hlhs.
contradict Hlhs.
apply/RleP.
apply Rplus_le_compat_r.
by apply/RleP.
Qed.

Lemma Rlt_add2r (p m n : R) : (m + p <b n + p) = (m <b n).
Proof.
move Hlhs : (_ + _ <b _) => [].
  symmetry.
  apply/RltP.
  apply Rplus_lt_reg_r with p.
  by apply/RltP.
symmetry.
apply/negP.
move/negP in Hlhs.
contradict Hlhs.
apply/RltP.
apply Rplus_lt_compat_r.
by apply/RltP.
Qed.

(* Rmult_le_compat_l
     : forall r r1 r2 : R, 0 <= r -> r1 <= r2 -> r * r1 <= r * r2 *)
(* Rmult_le_reg_l
     : forall r r1 r2 : R, 0 < r -> r * r1 <= r * r2 -> r1 <= r2 *)
Lemma Rle_pmul2l m n1 n2 : 0 <b m -> (m * n1 <b= m * n2)%R = (n1 <b= n2)%R.
Proof.
move=> Hm.
move Hlhs : (_ <b= _) => [].
  move/RleP : Hlhs.
  move/Rmult_le_reg_l.
  move/RltP in Hm.
  move/(_ Hm).
  by move/RleP.
symmetry.
apply/negP.
move/negP in Hlhs.
contradict Hlhs.
apply/RleP.
apply Rmult_le_compat_l.
  left.
  by apply/RltP.
by apply/RleP.
Qed.

(* Rmult_le_compat_r
     : forall r r1 r2 : R, 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r *)
(* Rmult_le_reg_r
     : forall r r1 r2 : R, 0 < r -> r1 * r <= r2 * r -> r1 <= r2 *)

Lemma Rle_pmul2r m n1 n2 : 0 <b m -> (n1 * m <b= n2 * m) = (n1 <b= n2).
Proof.
move=> Hm.
move Hlhs : (_ <b= _) => [].
  move/RleP : Hlhs.
  move/Rmult_le_reg_r.
  move/RltP in Hm.
  move/(_ Hm).
  by move/RleP.
symmetry.
apply/negP.
move/negP in Hlhs.
contradict Hlhs.
apply/RleP.
apply Rmult_le_compat_r.
  left.
  by apply/RltP.
by apply/RleP.
Qed.

(*
Ropp_mult_distr_r_reverse

Ropp_mult_distr_l_reverse

Rinv_l_sym*)