Require Export GeoCoq.Tarski_dev.Ch04_cong_bet.

Section T4_1.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma col_permutation_1 : forall A B C,Col A B C -> Col B C A.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_2 : forall A B C, Col A B C -> Col C A B.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_3 : forall A B C, Col A B C -> Col C B A.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_4 : forall A B C, Col A B C -> Col B A C.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

Lemma col_permutation_5 : forall A B C, Col A B C -> Col A C B.
Proof.
    unfold Col.
    intros.
    intuition.
Qed.

End T4_1.

Hint Resolve bet_col col_permutation_1 col_permutation_2
col_permutation_3 col_permutation_4 col_permutation_5 : col.

Ltac Col := auto 3 with col.
Ltac Col5 := auto with col.

Section T4_2.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma not_col_permutation_1 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col B C A.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_2 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col C A B.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_3 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col C B A.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_4 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col B A C.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

Lemma not_col_permutation_5 :
 forall (A B C : Tpoint), ~ Col A B C -> ~ Col A C B.
Proof.
    intros.
    intro.
    apply H.
    Col.
Qed.

End T4_2.

Hint Resolve not_col_permutation_1 not_col_permutation_2
not_col_permutation_3 not_col_permutation_4 not_col_permutation_5 : col.

Section T4_3.

Context `{Tn:Tarski_neutral_dimensionless}.

(** This lemma is used by tactics for trying several permutations. *)
Lemma Col_cases :
 forall A B C,
 Col A B C \/ Col A C B \/ Col B A C \/
 Col B C A \/ Col C A B \/ Col C B A ->
 Col A B C.
Proof.
    intros.
    decompose [or] H; Col.
Qed.

Lemma Col_perm :
 forall A B C,
 Col A B C ->
 Col A B C /\ Col A C B /\ Col B A C /\
 Col B C A /\ Col C A B /\ Col C B A.
Proof.
    intros.
    repeat split; Col.
Qed.

Lemma col_trivial_1 : forall A B, Col A A B.
Proof.
    unfold Col.
    intros.
    Between.
Qed.

Lemma col_trivial_2 : forall A B, Col A B B.
Proof.
    unfold Col.
    intros.
    Between.
Qed.

Lemma col_trivial_3 : forall A B, Col A B A.
Proof.
    unfold Col.
    intros.
    right;Between.
Qed.

End T4_3.

Hint Immediate col_trivial_1 col_trivial_2 col_trivial_3: col.

Section T4_4.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma l4_13 : forall A B C A' B' C',
 Col A B C -> Cong_3 A B C A' B' C' -> Col A' B' C'.
Proof.
    unfold Col.
    intros.
    decompose [or] H;
      eauto 6  using l4_6 with cong3.
Qed.

Lemma l4_14 : forall A B C A' B',
  Col A B C -> Cong A B A' B' -> exists C', Cong_3 A B C A' B' C'.
Proof.
    unfold Col.
    intros.
    intuition.
      prolong A' B' C' B C.
      exists C'.
      assert (Cong A C A' C') by (eapply l2_11;eCong).
      unfold Cong_3;intuition.
      assert (exists C', Bet A' C' B' /\ Cong_3 A C B A' C' B') by (eapply l4_5;Between).
      ex_and H1 C'.
      exists C'.
      auto with cong3.
    prolong B' A' C' A C.
    exists C'.
    assert (Cong B C B' C') by (eapply l2_11;eBetween;Cong).
    unfold Cong_3;intuition.
Qed.

Lemma l4_16 : forall A B C D A' B' C' D',
   FSC A B C D A' B' C' D' -> A<>B -> Cong C D C' D'.
Proof.
    unfold FSC.
    unfold Col.
    intros.
    decompose [or and] H; clear H.
      assert (Bet A' B' C') by (eapply l4_6;eauto).
      unfold Cong_3 in *; spliter.
      assert(OFSC A B C D A' B' C' D') by (unfold OFSC;repeat split; assumption).
      eapply five_segment_with_def; eauto.
      assert(Bet B' C' A') by (apply (l4_6 B C A B' C' A'); Cong;auto with cong3).
      apply (l4_2 B C A D B' C' A' D').
      unfold IFSC; unfold Cong_3 in *; spliter; repeat split;Between;Cong.
    assert (Bet C' A' B') by (eapply (l4_6 C A B C' A' B'); auto with cong3).
    eapply (five_segment_with_def B A C D B' A'); unfold OFSC; unfold Cong_3 in *; spliter; repeat split; Between; Cong.
Qed.

Lemma l4_17 : forall A B C P Q,
  A<>B -> Col A B C -> Cong A P A Q -> Cong B P B Q -> Cong C P C Q.
Proof.
    intros.
    assert (FSC A B C P A B C Q) by (unfold FSC; unfold Cong_3;repeat split; Cong).
    eapply l4_16; eauto.
Qed.

Lemma l4_18 : forall A B C C',
  A<>B -> Col A B C -> Cong A C A C' -> Cong B C B C' -> C=C'.
Proof.
    intros.
    apply cong_identity with C.
    apply (l4_17 A B); Cong.
Qed.

Lemma l4_19 : forall A B C C',
 Bet A C B -> Cong A C A C' -> Cong B C B C' -> C=C'.
Proof.
    intros.
    induction (eq_dec_points A B).
      treat_equalities; reflexivity.
    apply (l4_18 A B); Cong.
    auto using bet_col with col.
Qed.

Lemma not_col_distincts : forall A B C ,
 ~ Col A B C ->
 ~ Col A B C /\ A <> B /\ B <> C /\ A <> C.
Proof.
    intros.
    repeat split;(auto;intro); subst; apply H; Col.
Qed.

Lemma NCol_cases :
 forall A B C,
 ~ Col A B C \/ ~ Col A C B \/ ~ Col B A C \/
 ~ Col B C A \/ ~ Col C A B \/ ~ Col C B A ->
 ~ Col A B C.
Proof.
    intros.
    decompose [or] H; Col.
Qed.

Lemma NCol_perm :
 forall A B C,
 ~ Col A B C ->
 ~ Col A B C /\ ~ Col A C B /\ ~ Col B A C /\
 ~ Col B C A /\ ~ Col C A B /\ ~ Col C B A.
Proof.
    intros.
    repeat split; Col.
Qed.

Lemma col_cong_3_cong_3_eq : forall A B C A' B' C1 C2,
  A <>B -> Col A B C -> Cong_3 A B C A' B' C1 -> Cong_3 A B C A' B' C2 -> C1 = C2.
Proof.
intros A B C A' B' C1 C2 HAB HCol HCong1 HCong2.
apply l4_18 with A' B'; try apply l4_13 with A B C; Col;
unfold Cong_3 in *; spliter.
  intro; treat_equalities; intuition.
  apply cong_transitivity with A C; Cong.
  apply cong_transitivity with B C; Cong.
Qed.

End T4_4.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-06-17

general results on booleans
*)

Set Implicit Arguments.

From Coq Require Import Arith Omega.
From Coq Require Export Bool.
From Coq Require Setoid.

From CoLoR Require Import LogicUtil.

Arguments orb_false_elim [b1 b2] _.
Arguments orb_true_elim [b1 b2] _.

Hint Rewrite negb_orb negb_andb negb_involutive eqb_negb1 eqb_negb2
  orb_true_r orb_true_l orb_false_r orb_false_l orb_negb_r orb_assoc
  andb_false_r andb_false_l andb_true_r andb_true_l andb_negb_r andb_assoc
  absoption_andb absoption_orb
  xorb_false_r xorb_false_l xorb_nilpotent xorb_assoc_reverse
  : bool.

Ltac bool := autorewrite with bool.

(***********************************************************************)
(** equality *)

Lemma false_not_true : forall b, b = false <-> ~(b = true).

Proof. destruct b; intuition. Qed.

Lemma beq_true : forall b c, b = c <-> (b = true <-> c = true).

Proof.
  split; intro h. subst. tauto. destruct c.
  tauto. rewrite false_not_true. intuition.
Qed.

(***********************************************************************)
(** implication *)

Lemma implb1 : forall b, implb b b = true.

Proof. induction b; refl. Qed.

Lemma implb2 : forall b, implb b true = true.

Proof. induction b; refl. Qed.

(***********************************************************************)
(** conjunction *)

Lemma andb_elim : forall b c, b && c = true -> b = true /\ c = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_elim [b c] _.

Lemma andb_eliml : forall b c, b && c = true -> b = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_eliml [b c] _.

Lemma andb_elimr : forall b c, b && c = true -> c = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_elimr [b c] _.

Lemma andb_intro : forall b c, b = true -> c = true -> b && c = true.

Proof. intros. subst b. subst c. refl. Qed.

Lemma andb_eq : forall b c, b && c = true <-> b = true /\ c = true.

Proof. split. intro. apply andb_elim. hyp. intuition. Qed.

Lemma andb_eq_false : forall b c, b && c = false <-> b = false \/ c = false.

Proof. destruct b; destruct c; bool; intuition. Qed.

(***********************************************************************)
(** negation *)

Definition neg (A : Type) (f : A->A->bool) x y := negb (f x y).

Lemma negb_lr : forall b c, negb b = c <-> b = negb c.

Proof. destruct b; destruct c; intuition. Qed.

(***********************************************************************)
(** disjonction *)

Lemma orb_intror : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_introl : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_eq : forall b c, b || c = true <-> b = true \/ c = true.

Proof. intuition. destruct b; auto. Qed.

(***********************************************************************)
(** equality *)

Lemma eqb_equiv : forall b b', b = b' <-> (b = true <-> b' = true).

Proof.
  intros b b'. split; intro H. subst b'. refl.
  destruct b. sym. rewrite <- H. refl.
  destruct b'. rewrite H. refl. refl.
Qed.

(***********************************************************************)
(** decidability *)

Section dec.

  Variables (A : Type) (P : A -> Prop)
    (f : A -> bool) (f_ok : forall x, f x = true <-> P x).

  Lemma ko : forall x, f x = false <-> ~P x.

  Proof. intro x. rewrite <- f_ok. destruct (f x); intuition; discr. Qed.

  Lemma dec : forall x, {P x}+{~P x}.

  Proof.
    intro x. case_eq (f x); intros.
    left. rewrite <- f_ok. hyp. right. rewrite <- ko. hyp.
  Defined.

End dec.

Arguments ko [A P f] _ x.
Arguments dec [A P f] _ x.

(***********************************************************************)
(** correspondance between boolean functions and logical connectors *)

Section bool_ok.

  Variables (A : Type) (P Q : A->Prop) (bP bQ : A-> bool)
    (bP_ok : forall x, bP x = true <-> P x)
    (bQ_ok : forall x, bQ x = true <-> Q x).

  Lemma negb_ok : forall x, negb (bP x) = true <-> ~P x.

  Proof. intro. rewrite <- (ko bP_ok). destruct (bP x); simpl; intuition. Qed.

  Lemma andb_ok : forall x, bP x && bQ x = true <-> P x /\ Q x.

  Proof. intro. rewrite andb_eq, bP_ok, bQ_ok. refl. Qed.

  Lemma orb_ok : forall x, bP x || bQ x = true <-> P x \/ Q x.

  Proof. intro. rewrite orb_eq, bP_ok, bQ_ok. refl. Qed.

  Lemma implb_ok : forall x, implb (bP x) (bQ x) = true <-> (P x -> Q x).

  Proof.
    intro x. unfold implb. case_eq (bP x).
    rewrite bP_ok, bQ_ok. tauto.
    rewrite (ko bP_ok). tauto.
  Qed.

End bool_ok.

(***********************************************************************)
(** checking a property (P i) for all i<n *)

Section bforall_lt.

  Variables (P : nat->Prop) (bP : nat->bool)
    (bP_ok : forall x, bP x = true <-> P x).

  Definition forall_lt n := forall i, i < n -> P i.

  Fixpoint bforall_lt_aux b n := b &&
    match n with
      | 0 => true
      | S n' => bforall_lt_aux (bP n') n'
    end.

  Lemma bforall_lt_aux_ok : forall n b,
    bforall_lt_aux b n = true <-> b = true /\ forall_lt n.

  Proof.
    unfold forall_lt. induction n; simpl; intros. bool. fo.
    rewrite andb_eq, IHn, bP_ok. intuition.
    destruct (Nat.eq_dec i n). subst. hyp. apply H2. omega.
  Qed.

  Definition bforall_lt := bforall_lt_aux true.

  Lemma bforall_lt_ok : forall n, bforall_lt n = true <-> forall_lt n.

  Proof. intro. unfold bforall_lt. rewrite bforall_lt_aux_ok. tauto. Qed.

End bforall_lt.


Require Import EqNat.
Require Import PeanoNat.
Require Import String.
Require Import BinNums.
Require Import List.
Require Import Compare_dec.
Require Import Omega.
Require Import Bool.
Set Implicit Arguments.

Section PREFIX.

Variable X: Type.

Hypothesis x_eq_dec: forall (x y: X), {x = y} + {x <> y}.

Definition eqx (x y: X): bool :=
  match x_eq_dec x y with
  | left _ => true
  | right _ => false
  end.

Lemma eqx_prop: forall x y, eqx x y = true <-> x = y.
Proof.
intros.
unfold eqx.
destruct x_eq_dec. split; trivial.
split. intro. discriminate.
intro. apply n in H. contradiction.
Qed.

Lemma eqx_reflx: forall x, eqx x x = true.
Proof.
unfold eqx. intro.
destruct (x_eq_dec x x). reflexivity. contradiction.
Qed.

(* can think of X as a bool and B as a bitstring, but everything
in this file is general to any type with decidable equality.
*)
Definition B: Type := list X.

(* is b1 a prefix of b2 *)
Fixpoint is_prefix_bool (b1 b2: B): bool :=
  match b1 with
  | nil => true
  | f1::r1 => match b2 with
    | nil => false
    | f2::r2 => (eqx f1 f2 && is_prefix_bool r1 r2)
    end
  end.

Definition is_prefix (b1 b2: B): Prop :=
  is_prefix_bool b1 b2 = true.
Hint Unfold is_prefix.

Lemma is_prefix_spec: forall (b1 b2: B),
  is_prefix b1 b2 <-> b1 = firstn (length b1) b2.
Proof.
autounfold. induction b1; simpl; intros;
split; intros; try trivial.
- (* prefix implies firstn *)
destruct b2. discriminate.
apply andb_true_iff in H. destruct H.
apply eqx_prop in H.
apply IHb1 in H0.
subst a. rewrite <- H0. trivial.
- (* firstn implies prefix *)
destruct b2. discriminate.
injection H; intros.
apply IHb1 in H0.
subst a. rewrite H0.
rewrite eqx_reflx. simpl. trivial.
Qed.

Lemma is_prefix_app: forall (b1 b2: B),
  is_prefix b1 b2
  <-> exists b3, b1 ++ b3 = b2.
Proof.
intros; split; intros.
-
apply is_prefix_spec in H.
exists (skipn (length b1) b2).
remember (length b1) as n.
rewrite H.
apply firstn_skipn.
-
destruct H.
apply is_prefix_spec.
subst b2.
rewrite firstn_app.
rewrite firstn_all.
cut (length b1 - length b1 = O).
intro. rewrite H. rewrite firstn_O. rewrite app_nil_r. trivial.
omega.
Qed.

Lemma is_prefix_refl: forall b, is_prefix b b.
Proof.
intros. apply is_prefix_app. exists nil. apply app_nil_r.
Qed.

Lemma is_prefix_nil: forall b, is_prefix nil b.
Proof.
intros. autounfold. simpl. easy.
Qed.

Lemma is_nil_prefix: forall b, is_prefix b nil -> b = nil.
Proof.
induction b; autounfold; simpl; intros; trivial.
discriminate.
Qed.

Lemma list_induction_append: forall T (P: list T->Prop),
  P nil ->
  (forall l (v: T), P l -> P (l ++ (v::nil))) ->
  (forall l, P l).
Proof.
intros.
apply rev_ind.
assumption. intros. apply H0. assumption.
Qed.

(*
Lemma nonempty_append: forall T l (v: T),
  exists s, cons v l = (firstn (length l) (cons v l)) ++ s::nil.
Proof.
induction l; simpl; intros.
- exists v. reflexivity.
-

Qed.*)

Lemma nonzero_length: forall T (l: list T),
  l <> nil <-> 1 <= length l.
Proof.
destruct l; simpl.
- split; intro. contradiction. omega.
- split; intro. omega. intro. discriminate.
Qed.

Lemma apply_both_sides: forall T U (f: T->U) a b,
  a = b -> f a = f b.
Proof.
intros. rewrite H. reflexivity.
Qed.

Lemma removelast_both_sides: forall T (a: list T) b,
  a = b -> removelast a = removelast b.
Proof.
intros. apply apply_both_sides. assumption.
Qed.

Lemma length_both_sides: forall T (a: list T) b,
  a = b -> length a = length b.
Proof.
intros. apply apply_both_sides. assumption.
Qed.

(* docs say this is in the List library, but it's not there.
so we prove it.
*)
Lemma removelast_last:
  forall T l (a: T), removelast (l ++ a::nil) = l.
Proof.
induction l; simpl; intros.
reflexivity.
remember (l ++ a0::nil) as l0. destruct l0.
- apply length_both_sides in Heql0.
rewrite app_length in Heql0. simpl in Heql0. omega.
-
apply removelast_both_sides in Heql0.
rewrite IHl in Heql0. rewrite Heql0. reflexivity.
Qed.

Lemma append_nonempty_prefix: forall p b x f,
  p ++ x = b ++ (f::nil) ->
  1 <= length x ->
  is_prefix p b.
Proof.
intros. apply is_prefix_app.
apply nonzero_length in H0.
destruct (exists_last H0). destruct s.
subst x.
exists x0.
apply removelast_both_sides in H.
rewrite app_assoc in H.
repeat rewrite removelast_last in H.
assumption.
Qed.

Lemma is_prefix_append: forall p b f,
  is_prefix p (b ++ (f::nil)) ->
  is_prefix p b \/ p = b ++ (f::nil).
Proof.
intros. apply is_prefix_app in H.
destruct H.
rewrite <- H. destruct x.
- right. rewrite app_nil_r. reflexivity.
- left. apply append_nonempty_prefix in H. assumption.
simpl. omega.
Qed.

Lemma nat_cmp: forall (x y: nat), x > y \/ x = y \/ y > x.
Proof.
intros. omega.
Qed.

Lemma prefix_app_helper: forall p b x,
  p ++ x = b -> is_prefix p b.
Proof.
intros. apply is_prefix_app. exists x. assumption.
Qed.

Lemma prefix_removelast: forall (p: B) b f g,
  p ++ (f::nil) = b ++ (g::nil) ->
  p = b.
Proof.
intros.
apply removelast_both_sides in H. repeat rewrite removelast_last in H.
assumption.
Qed.

Lemma rev_destruct: forall (x: B) d,
  x = nil \/ x = (removelast x)++(last x d)::nil.
Proof.
destruct x. left. reflexivity.
right.
eapply app_removelast_last. intro. discriminate.
Qed.

Lemma last_last: forall (x: B) x0 d, last (x++x0::nil) d = x0.
Proof.
induction x; simpl; intros.
reflexivity.
rewrite IHx.
remember (x++x0::nil) as xs. destruct xs.
apply length_both_sides in Heqxs.
rewrite app_length in Heqxs. simpl in Heqxs. omega.
reflexivity.
Qed.

Lemma rev_injection: forall (x: B) y x0 y0,
  x++x0::nil = y++y0::nil -> x = y /\ x0 = y0.
Proof.
intros. split.
- apply removelast_both_sides in H.
  repeat rewrite removelast_last in H.
  assumption.
- apply (apply_both_sides (fun k => @last X k x0)) in H.
  repeat rewrite last_last in H. assumption.
Qed.

Lemma length_removelast: forall (x: B),
  length (removelast x) <= length x.
Proof.
induction x; simpl; intros.
omega.
destruct x. simpl. omega.
remember (removelast (x::x0)) as y. simpl. simpl in IHx.
omega.
Qed.

Lemma prefix_app_length: forall y x p b,
  p ++ x = b ++ y ->
  length x > length y ->
  is_prefix p b.
Proof.
apply (rev_ind (fun y => forall x p b,
  p ++ x = b ++ y ->
  length x > length y ->
  is_prefix p b)).
- simpl. intros. rewrite app_nil_r in H.
  apply is_prefix_app. exists x. assumption.
- intro y0. intro y. (* inductive case y = y++y0::nil *)
  intros.
  destruct (rev_destruct x y0).
  subst x. simpl in H1. omega.
  rewrite H2 in H0.
  repeat rewrite <- app_ass in H0.
  apply H with (removelast x).
  apply rev_injection in H0. destruct H0. assumption.
  rewrite app_length in H1. simpl in H1.
  apply length_both_sides in H2. rewrite app_length in H2. simpl in H2.
  omega.
Qed.

Lemma firstn_length: forall (x: B), firstn (length x) x = x.
Proof.
induction x; simpl; intros.
reflexivity. rewrite IHx. reflexivity.
Qed.

Lemma firstn_app: forall (x: B) y, firstn (length x) (x++y) = x.
Proof.
induction x; simpl; intros.
reflexivity.
rewrite IHx. reflexivity.
Qed.

Lemma prefix_app_length_eq: forall (y: B) x p b,
  p ++ x = b ++ y ->
  length x = length y ->
  p = b.
Proof.
intros.
cut (length p = length b).
- intro.
  apply (apply_both_sides (firstn (length p))) in H.
  rewrite firstn_app in H.
  rewrite H1 in H. rewrite firstn_app in H. assumption.
- apply length_both_sides in H. repeat rewrite app_length in H. omega.
Qed.

Theorem equal_prefix: forall p1 p2 b1 b2,
  p1 ++ b1 = p2 ++ b2 ->
  is_prefix p1 p2 \/ is_prefix p2 p1.
Proof.
intros.
assert (CMP := nat_cmp (length b1) (length b2)).
destruct CMP.
left. eapply prefix_app_length; eauto.
destruct H0.
left. cut (p1 = p2). intro. subst. apply is_prefix_refl.
eapply prefix_app_length_eq; eauto.
right. eapply prefix_app_length; eauto.
Qed.

End PREFIX.


Require Export CaseLtac Arith Omega Coq.Program.Equality.

Module Id.

(** We define a new inductive datatype [Id] so that we won't confuse
    identifiers and numbers.  We use [sumbool] to define a computable
    equality operator on [Id]. *)

Inductive t : Type :=
  T : string -> t.

Theorem eq_id_dec : forall id1 id2 : t, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (string_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x).
  Case "x = x".
    reflexivity.
  Case "x <> x (impossible)".
    destruct n. reflexivity. Qed.

End Id.

Definition id := Id.t.

Definition state := id -> nat.

Definition effect := state -> state.

Definition empty_state : state :=
  fun _ => 0.

Definition id_eff : effect := fun st => st.

Definition update (st : state) (x : id) (n : nat) : state :=
  fun x' => if Id.eq_id_dec x x' then n else st x'.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp.

Fixpoint aeval (st: state)(a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  end.

Fixpoint beval (st : state)(b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2 => leb (aeval st a1) (aeval st a2)
  end.
(** ** Syntax *)

(**  c ::= SKIP
         | x ::= a
         | c ;; c
         | WHILE b DO c END       <-- Removed
         | IFB b THEN c ELSE c FI
]]
*)
Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  (*| CIf : bexp -> com -> com -> com*)
  | CPar : com -> com -> com
  | CTxn : (effect * com) -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
(*
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
*)
Notation "c1 ||| c2" :=
  (CPar c1 c2) (at level 100, right associativity).
Notation "'TXN' { c }" :=
  (CTxn (id_eff,c)) (at level 60, right associativity).
Notation "'TXNF' { F [ c ] }" :=
  (CTxn (F,c)) (at level 70, right associativity).

Module Test1.

Definition X := Id.T "x".
Definition Y := Id.T "y".
Definition Z := Id.T "z".

(* X := X + 2 *)
Definition par_plus : com :=
  TXN {X ::= (APlus (AId X) (ANum 1))} ||| TXN {X ::= (APlus (AId X) (ANum 2))}.

End Test1.

Print option.

Reserved Notation "x '-t->' y" (at level 40).

Inductive txn_step : (com * state * effect) -> ((option com) * effect) -> Prop :=
  | TS_Skip : forall (st : state)(F : effect),
               (SKIP, st, F) -t-> (None, F)
  | TS_Ass : forall (st : state)(F: effect)(a : aexp)(n : nat)(x : id),
              aeval st a = n ->
              (x ::= a, st, F) -t->
                   (None, fun st => update (F st) x n)
  | TS_Seq1 : forall c1 c1' c2 st F F',
               (c1, st, F) -t-> (Some c1', F') ->
               (c1;;c2, st, F) -t-> (Some (c1';;c2), F')
  | TS_Seq2 : forall c1 c2 st F F',
               (c1, st, F) -t-> (None, F') ->
               (c1;;c2, st, F) -t-> (Some c2, F')
  where "x '-t->' y" := (txn_step x y).

Reserved Notation "x '--->' y" (at level 50).

Definition com_step_relation := (com * state) -> ((option com) * state) -> Prop.

Inductive step : com_step_relation :=
  | S_Skip : forall (st : state)(F : effect),
               (SKIP, st) ---> (None, st)
  | S_Ass : forall (st : state)(F: effect)(a : aexp)(n : nat)(x : id),
              aeval st a = n ->
              (x ::= a, st) ---> (None, update st x n)
  | S_Seq1 : forall c1 c1' c2 st st',
               (c1, st) ---> (Some c1', st') ->
               (c1;;c2, st) ---> (Some (c1';;c2), st')
  | S_Seq2 : forall c1 c2 st st',
               (c1, st) ---> (None, st') ->
               (c1;;c2, st) ---> (Some c2, st')
  | S_Par1 : forall c1 c1' c2 st st',
               (c1, st) ---> (Some c1', st') ->
               (c1 ||| c2, st) ---> (Some (c1' ||| c2), st')
  | S_Par2 : forall c1 c2 c2' st st',
               (c2, st) ---> (Some c2', st') ->
               (c1 ||| c2, st) ---> (Some (c1 ||| c2'), st')
  | S_Par3 : forall c1 c2 st st',
               (c1, st) ---> (None, st') ->
               (c1 ||| c2, st) ---> (Some c2, st')
  | S_Par4 : forall c1 c2 st st',
               (c2, st) ---> (None, st') ->
               (c1 ||| c2, st) ---> (Some c1, st')
  (*| S_Txn1 : forall c c' st F,
               (c,st,id_eff) -t-> (Some c',F) ->
               (TXN {c}, st) ---> (Some (TXNF {F[c']}), st)
  | S_Txn2 : forall c st F,
               (c,st,id_eff) -t-> (None,F) ->
               (TXN {c}, st) ---> (None, st)*)
  | S_TxnF1 : forall c c' st F F',
                (c,st,F) -t-> (Some c',F') ->
                (TXNF {F[c]}, st) ---> (Some (TXNF {F[c']}), st)
  | S_TxnF2 : forall c st F F',
                (c,st,F) -t-> (None,F') ->
                (TXNF {F[c]}, st) ---> (None, F' st)
  where "x '--->' y" := (step x y).

(** Multi-step reduction *)

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

Inductive multi_step : (com * state) -> ((option com) * state) -> Prop :=
  | base_step  : forall c opc' st st',
                    (c,st) ---> (opc',st') ->
                    (c,st) --->* (opc',st')
  | trans_step : forall c c' opc'' st st' st'',
                    (c,st) ---> (Some c',st') ->
                    (c',st') --->* (opc'',st'')  ->
                    (c,st) --->* (opc'',st'')
  where "t '--->*' t' " := (multi_step t t').

Notation "c1 '/' st '||' st'" := ((c1,st) --->* (None,st'))
(at level 40, st at level 39).

(** ** Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
    c / st || st'  ->
    P st ->
    Q st'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Module Test2.

Include Test1.

(* Let us sanity-check our small-step semantics *)
Theorem par_plus_inv :
  {{fun st => st X = 0 }}
    par_plus
  {{fun st => st X = 3 }}.
Proof.
  unfold hoare_triple.
  intros.
  inversion H.
  + Case "base_step".
    clear H1 c H3 st0 H5 st'0 H4 opc'.
    unfold par_plus in H2.
    inversion H2.
  + Case "base_multi".
    clear H1 c H3 opc'' H2 st0 H5 st''.
    unfold par_plus in H4.
    inversion H4.
    - SCase "ParTxnF1".
      inversion H2.
      inversion H10.
    - SCase "ParTxnF2".
      inversion H2.
      inversion H10.
    - SCase "ParTxnF3".
      inversion H2.
      inversion H10.
      rewrite <- H7 in H6.
      inversion H6.
      * inversion H21.
        inversion H26.
        clear H1 H3 H6 H21 H26.
        inversion H2. inversion H3. rewrite <- H37. rewrite <- H31.
        unfold id_eff. simpl. rewrite H0. simpl. unfold id_eff. simpl.
        rewrite <- H19 in H13. rewrite <- H13. unfold id_eff.
        unfold update. simpl. rewrite <- H15. simpl. intuition.
      * inversion H23.
        inversion H27.
    - SCase "ParTxnF4".
      rewrite <- H7 in H6.
      inversion H6.
      * inversion H10.
        inversion H15.
        inversion H2.
        inversion H26.
        unfold id_eff. rewrite <- H31. rewrite <- H20.
        unfold update. simpl. rewrite <- H35 in H29; rewrite <- H29.
        unfold id_eff. unfold update. simpl. rewrite <- H31. simpl.
        rewrite H0. reflexivity.
      * inversion H12.
        inversion H16.
Qed.

End Test2.

Definition relation (X: Type) := X->X->Prop.

Definition ssrelation := relation state.

Inductive rstar {X:Type} (R: relation X) : relation X :=
  | rstar_refl  : forall (x : X), rstar R x x
  | rstar_trans : forall (x y z : X),
                    R x y ->
                    rstar R y z ->
                    rstar R x z.
Notation "R '^*'" := (rstar R) (at level 60).

Inductive refl_closure {X:Type} (R : relation X) : relation X :=
  | rclos_refl : forall (x : X), refl_closure R x x.

Notation "'ID+' R" := (refl_closure R) (at level 60).

SearchPattern (_*_ -> _).

Print fst.

Definition foo : (nat*nat) -> nat := fun p => let (x,_) := p in x.

Check (fun x y => x).

Definition interleaved_step (R : ssrelation) (c:com) (st:state)
        (opc:option com) (st':state) : Prop :=
                 (c,st) ---> (opc,st') \/ (opc = Some c /\ R st st').

Notation " 'RSTEP' '(' c ',' st ')' '-(' R ')->' '(' opc ',' st' ')'" :=
  (interleaved_step R c st opc st') (at level 40, c at level 39).

Inductive interleaved_multi_step (R : ssrelation) (c : com) (st : state)
          (opc' : option com) (st' : state) : Prop :=
 | interleaved_base : RSTEP (c,st) -(R)-> (opc',st') ->
                      interleaved_multi_step R c st opc' st'
 | interleaved_trans : forall c1 st1,
                        (c,st) ---> (Some c1,st1) ->
                        interleaved_multi_step R c1 st1 opc' st' ->
                        interleaved_multi_step R c st opc' st'.

Check interleaved_multi_step_ind.
Check list_ind.

Notation " 'R*STEP' '(' c , st ')' '-(' R ')->*' '(' opc ',' st' ')'" :=
  (interleaved_multi_step R c st opc st')(at level 40).

Definition step_guaranteed (R G :ssrelation) (c :com) (st : state) :=
  (forall st', (c,st) ---> (None,st') -> G st st')
    /\
  (forall c' opc'' st' st'',  R*STEP (c,st) -(R)->* (Some c',st') ->
                              (c',st') ---> (opc'',st'') ->
                              G st' st'').

Definition RG_quintuple (R G : ssrelation)(P : Assertion) (c:com)
           (Q : Assertion): Prop :=
  forall st st',
    P st ->
    R*STEP (c,st) -(R)->* (None,st')  ->
    Q st' /\ (step_guaranteed R G c st).

Notation "{{ R ',' P }} c {{ G ',' Q }}" :=
  (RG_quintuple R G P c Q) (at level 90, c at next level).

Definition stable (P : Assertion) (R : ssrelation) :=
  forall st st', P st /\ R st st'-> P st'.

Definition subsumes_states (P Q : Assertion) (G : ssrelation) :=
  forall st st', P st -> Q st' -> G st st'.

Lemma star_stability_weakening : forall P R,
  stable P (R^*) -> stable P R.
Proof.
  intros.
  unfold stable; unfold stable in H.
  intros.
  apply H with (st:=st).
  split. intuition.
  apply rstar_trans with (y:=st').
  intuition.
  apply rstar_refl.
Qed.

Lemma rg_asgn_helper : forall X a st R c st',
   R*STEP (X::=a,st) -(R)->* (Some c, st') -> c = X::=a /\ R st st'.
Proof.
  intros X a st R c st' H.
  inversion H.
  inversion H0.
  inversion H1.
  inversion H1. inversion H2.
  intuition.
  inversion H0.
Qed.

Lemma rg_seq_intermediary: forall R c1 c2 st st'',
   R*STEP (c1;; c2, st) -(R)->* (None, st'') ->
   exists st',
     R*STEP (c1,st) -(R)->* (None,st') /\ R*STEP (c2,st') -(R)->* (None,st'').
Proof.
  intros.
  dependent induction H.
  + Case "interleaved_base".
    inversion H. inversion H0. inversion H0. inversion H1.
  + Case "interleaved_trans".
    inversion H.
    - SCase "S_Seq1".
      assert(exists st'0, R*STEP  (c1', st1)-( R )->*  (None, st'0) /\
                          R*STEP  (c2, st'0)-( R )->*  (None, st')).
        apply IHinterleaved_multi_step with (c1:=c1')(c2:=c2).
        congruence. reflexivity.
      inversion H7.
      assert (RSTEP (c1, st) -(R)-> (Some c1', st1)).
        unfold interleaved_step.
        left. assumption.
      assert (R*STEP  (c1, st)-( R )->*  (None, x)).
        apply interleaved_trans with (c1:=c1')(st1:=st1).
        assumption. intuition.
      exists x. intuition.
    - SCase "S_Seq2".
      subst c0.
      assert (RSTEP (c1, st) -(R)-> (None, st1)).
        unfold interleaved_step.
        left. assumption.
      assert (R*STEP  (c1, st)-( R )->*  (None, st1)).
        apply interleaved_base.
        assumption.
      exists st1.
      intuition.
Qed.

Notation "'(' P ',' Q ')' '∈' G" := (subsumes_states P Q G) (at level 90) : subsumes_states_scope.

Open Scope subsumes_states_scope.

Theorem rg_asgn: forall R P G Q X a,
    stable P (R^*) ->
    {{P}} X::=a {{Q}} ->
    stable Q (R^*) ->
    (P,Q) ∈ G ->
    {{R,P}} X::=a {{G,Q}}.
Proof.
  unfold RG_quintuple.
  intros R P G Q X a H H0 H1 H2 st st' H3 H4.
  inversion H4 as [H6|H6].
  + Case "interleaved_base".
    split.
    - SCase "PostCondition".
      unfold interleaved_step in H6.
      inversion H6 as [H10|H10].
      unfold hoare_triple in H0.
      apply H0 with (st:=st).
      constructor. assumption.
      assumption.
      inversion H10 as (H11,H12). inversion H11.
    - SCase "Guarantee".
      unfold step_guaranteed.
      split.
      * SSCase "SingleStep".
        intros.
        unfold subsumes_states in H2.
        apply H2 with (st:=st)(st':=st'0).
        assumption.
        (* From here, the proof is same as the previous case. *)
        (* How do I say that in coq? *)
        unfold hoare_triple in H0.
        apply H0 with (st:=st).
        constructor. assumption.
        assumption.
      * SSCase "Multistep".
        intros.
        assert (c'=X::=a /\ R st st'0).
          apply rg_asgn_helper with (st:=st)(st':=st'0).
          assumption.
        unfold subsumes_states in H2.
        apply H2 with (st:=st'0)(st':=st'').
        (*P st'0*)
        assert (stable P R).
          apply star_stability_weakening.
          assumption.
        unfold stable in H9.
        apply H9 with (st:=st)(st':=st'0).
        intuition.
        (*Q st''*)
        unfold hoare_triple in H0.
        apply H0 with (st:=st'0).
        constructor.
        inversion H8; clear H8.
        rewrite H9 in H7.
        assert (opc'' = None).
          inversion H7. reflexivity.
        rewrite H8 in H7. assumption.
        (*P st'0*)
        assert (stable P R).
          apply star_stability_weakening.
          assumption.
        unfold stable in H9.
        apply H9 with (st:=st)(st':=st'0).
        intuition.
  + Case "interleaved_trans".
    inversion H5.
Qed.

Theorem rg_seq: forall R G P c1 Q' c2 Q,
  {{R,P}} c1 {{G,Q'}} ->
  {{R,Q'}} c2 {{G,Q}} ->
  {{R,P}} c1 ;; c2 {{G,Q}}.
Proof.
  unfold RG_quintuple.
  intros.
  inversion H2.
  + inversion H4. inversion H8. inversion H8. inversion H9.
  +.


Require Import common.

Module Type MapSpec.

Parameter domain : Set.
Parameter image : Type.
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 : Type := 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 := @ext_eq 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 a x).
  unfold not_in_dom in H.
  rewrite <- a0 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 a x).
  auto.
  unfold put.
  induction (beq_A a  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 a x).
  induction (beq_A a x').
  rewrite a0 in a1. contradiction. auto.
  induction (beq_A a 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.
destruct (M1 a);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 a x). auto. induction (M1 a); 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 a x).
  rewrite <- a0 in H. unfold not_in_dom in H.
  rewrite H. auto.
  induction (M1 a); 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 a x).
  rewrite a0. 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.
destruct (disj a).
rewrite H.
destruct (M2 a);auto.
rewrite H.
destruct (M1 a);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 a).
  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 a = merge M3 M4 a).
  rewrite <- eqMerge. auto.
  unfold merge in H.
  assert (in_dom a M3 \/ not_in_dom a M3).
  apply in_or_notin.
  inversion_clear H0.
  rewrite eq13 in disj1.
  unfold disjoint in disj1.
  unfold disjoint in disj2.
  assert (not_in_dom a M3 \/ not_in_dom a M4); auto.
  assert (not_in_dom a M3 \/ not_in_dom a 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.

Ltac InvertAll :=
  repeat
    match goal with
      | H: _ /\ _ |- _ => inversion_clear H
      | H: ex _   |- _ => inversion_clear H
    end.

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 a M1 \/ not_in_dom a M1).
  apply in_or_notin.
  inversion_clear H1.
  assert (in_dom a M3). apply H. auto.
  unfold in_dom in H2. inversion_clear H2.
  unfold in_dom in H1. inversion_clear H1.
  assert (merge M1 M2 a = merge M3 M4 a). rewrite MG. auto.
  unfold merge in H1.
  rewrite H3 in H1. rewrite H2 in H1.
  rewrite H2. rewrite H3. auto.
  assert (in_dom a M3 \/ not_in_dom a M3).
  apply in_or_notin.
  inversion_clear H1.
  assert (in_dom a 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 a x).
  unfold maps_to in H.
  rewrite <- a0 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' a = None \/ exists y, M' a = Some y).
  induction (M' a). right. eauto. left. auto.
  inversion_clear H0.
  rewrite H1. auto.
  inversion_clear H1.
  rewrite H0.
  unfold subseteq in H.
  rewrite <- H0.
  assert (M' a = M a).
  apply H. unfold in_dom. exists x. 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 a x').
  induction (beq_A a x).
  rewrite a1 in a0.
  destruct(H a0).
  auto.
  induction (beq_A a 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 a 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.

Require Import ZArith.

Module HSpec <: MapSpec.
  Definition domain := Z.
  Definition image  := Z.
  Definition beq_Domain := Z_eq_dec.
End HSpec.

Module HMod := MapFun (HSpec).

Definition Heap := HMod.Map.


Require Import String.

(*
data PTyp a = Var a | Forall (a -> PSigma a) | Fun (PSigma a) (PSigma a) | PInt

data PSigma a = And (PSigma a) (PSigma a) | Typ (PTyp a)
*)

Inductive S := Base | Inter.

Inductive PTyp : S -> Type :=
  | PInt : PTyp Base
  | Fun : PTyp Inter -> PTyp Inter -> PTyp Base
  | And : PTyp Inter -> PTyp Inter -> PTyp Inter
  | Lift : PTyp Base -> PTyp Inter.

Check PTyp_ind.

Definition PTyp_ind2 : forall (s : S) (p : PTyp s)  (P : forall s : S, PTyp s -> Prop),
       P Base PInt ->
       (forall p : PTyp Inter,
        P Inter p -> forall p0 : PTyp Inter, P Inter p0 -> P Base (Fun p p0)) ->
       (forall p : PTyp Inter,
        P Inter p -> forall p0 : PTyp Inter, P Inter p0 -> P Inter (And p p0)) ->
       (forall p : PTyp Base, P Base p -> P Inter (Lift p)) ->
       P s p.
Proof.
intros.
apply PTyp_ind. auto. auto. auto. auto.
Defined.

Definition T (P : PTyp Inter -> Prop) : forall s, PTyp s -> Prop.
intros.
destruct s.
exact True.
exact (P H).
Defined.

Check (PTyp_ind2 Inter _ (T _)).

Definition PTyp_ind3 (p : PTyp Inter) (P : PTyp Inter -> Prop) := PTyp_ind2 Inter p (T P).

Check PTyp_ind3.

Definition PTyp_ind4 :
       forall (p : PTyp Inter) (P : PTyp Inter -> Prop),
       (forall p0 : PTyp Inter,
        P p0 ->
        forall p1 : PTyp Inter, P p1 -> P (And p0 p1)) ->
       (forall p0 : PTyp Base, P (Lift p0)) ->
       P p.
Proof.
intros.
apply (PTyp_ind3 p).
unfold T. auto.
intros. unfold T. auto.
auto.
unfold T.
intros.
apply H0.
Defined.

Require Import Arith.
Require Import Setoid.

(* Subtyping relation *)

Inductive sub : forall (s : S), PTyp s -> PTyp s -> Prop :=
  | SInt : sub Base (PInt) (PInt)
  | SFun : forall o1 o2 o3 o4, sub Inter o3 o1 -> sub Inter o2 o4 -> sub Base (Fun  o1 o2) (Fun  o3 o4)
  | SAnd1 : forall t t1 t2, sub Inter t t1 -> sub Inter t t2 -> sub Inter t (And  t1 t2)
  | SAnd2 : forall t t1 t2, sub Inter t1 t -> sub Inter (And  t1 t2) t
  | SAnd3 : forall t t1 t2, sub Inter t2 t -> sub Inter (And  t1 t2) t
  | SLift : forall t1 t2, sub Base t1 t2 -> sub Inter (Lift  t1) (Lift  t2).

(* Orthogonality: Implementation *)

Inductive Ortho : forall s, PTyp s -> PTyp s -> Prop :=
  | OAnd1 : forall t1 t2 t3, Ortho Inter t1 t3 -> Ortho Inter t2 t3 -> Ortho Inter (And t1 t2) t3
  | OAnd2 : forall t1 t2 t3, Ortho Inter t1 t2 -> Ortho Inter t1 t3 -> Ortho Inter t1 (And t2 t3)
  | OLift : forall t1 t2, not (sub Base t1 t2) -> not (sub Base t2 t1) -> Ortho Inter (Lift t1) (Lift t2).

(* Well-formed types *)

Inductive WFType : forall s, PTyp s -> Prop :=
  | WFPInt : WFType Base PInt
  | WFFun  : forall t1 t2, WFType Inter t1 -> WFType Inter t2 -> WFType Base (Fun t1 t2)
  | WFAnd  : forall t1 t2, Ortho Inter t1 t2 -> WFType Inter t1 -> WFType Inter t2 -> WFType Inter (And t1 t2).

(* Orthogonality: Specification *)

Hint Resolve SInt SFun SAnd1 SAnd2 SAnd3 SLift.

Lemma reflex : forall s (t1 : PTyp s) , sub s t1 t1.
Proof.
induction t1; intros; auto.
Defined.

Definition OrthoS (s:S) (A B : PTyp s) := not (exists C, sub s A C /\ sub s B C).

Lemma ortho_completness : forall s (t1 t2 : PTyp s), (s = Inter) -> OrthoS s t1 t2 -> Ortho s t1 t2.
Proof.
induction t1; intros; unfold OrthoS in H.
(* Dummy cases *)
discriminate H.
discriminate H.
(* Case (t11 & t12) _|_ t2 *)
apply OAnd1.
apply IHt1_1.
exact H.
unfold OrthoS in H0.
unfold OrthoS.
unfold not.
intro.
apply H0.
clear H0.
destruct H1. destruct H0.
exists x.
split.
apply SAnd2. exact H0.
exact H1.
apply IHt1_2.
exact H.
unfold OrthoS; unfold not; intro.
apply H0. clear H0.
destruct H1.
destruct H0.
exists x.
split.
apply SAnd3.
exact H0.
exact H1.
clear H.
clear IHt1.
(* Make a separate Lemma ? *)
generalize H0. clear H0.
apply (PTyp_ind4 t2).
intros.
apply OAnd2.
apply H.
unfold OrthoS. unfold not. intro.
apply H1.
destruct H2. destruct H2.
exists x.
split.
exact H2.
apply SAnd2.
exact H3.
apply H0.
unfold OrthoS. unfold not. intro.
apply H1.
destruct H2. destruct H2.
exists x.
split.
exact H2.
apply SAnd3.
exact H3.
(* Last case *)
intros.
apply OLift.
unfold not. intros.
apply H0.
exists (Lift p0).
split.
apply SLift.
apply H.
(*case 2*)
apply SLift.
apply reflex.
(*case 3*)
unfold not. intros.
apply H0.
exists (Lift t1).
split.
apply reflex.
apply SLift.
exact H.
Defined.

Definition SubEither s t1 t2 := sub s t1 t2 \/ sub s t2 t1.

Lemma ortho_aux : forall s (t1 t2 : PTyp s), (s = Base) -> not (sub s t1 t2 /\ sub s t2 t1) -> OrthoS s t1 t2.
intros.
unfold not in H0.
unfold OrthoS. unfold not.
intros.
apply H0. clear H0.
induction t1; split; try (discriminate H); intros.
destruct H1.
destruct H0.
inversion H0.
assert (PInt = x). admit. rewrite <- H3 in H0. rewrite <- H3 in H1. clear H2.
inversion H1.
assert (PInt = t2). admit. rewrite <- H4 in H1. rewrite <- H4. apply reflex.
admit. (* Similar to previous one *)
clear IHt1_1. clear IHt1_2.
destruct H1. destruct H0.
inversion H0.
assert (Fun o3 o4 = x). admit. rewrite <- H7 in H0. rewrite <- H7 in H1. clear H4. clear H7.
inversion H1.
assert (Fun o0 o5 = t2). admit. rewrite <- H7 in H0. rewrite <- H7 in H1. clear H4. clear H7.

Lemma ortho_soundness : forall s (t1 t2 : PTyp s), (s = Inter) -> Ortho s t1 t2 -> OrthoS s t1 t2.
induction t1; intros. discriminate H. discriminate H. admit.
clear IHt1. generalize H0. clear H0. intros. unfold OrthoS. unfold not. intros.

 apply (PTyp_ind4 t2); intros.
unfold OrthoS. unfold not. intros.
destruct H3. destruct H3.
unfold OrthoS in H0. unfold not in H1.
unfold OrthoS in H1. unfold not in H1.
admit.
unfold OrthoS. unfold not. intros.
destruct H1.
destruct H1.
inversion H0.
inversion H1.

Lemma ortho_soundness : forall s (t1 t2 : PTyp s), (s = Inter) -> OrthoS s t1 t2 -> Ortho s t1 t2.
Proof.
induction t1; intros; unfold OrthoS in H.
(* Dummy cases *)
discriminate H.
discriminate H.
(* Case (t11 & t12) _|_ t2 *)
apply OAnd1.
apply IHt1_1.
exact H.
unfold OrthoS in H0.
unfold OrthoS.
unfold not.
intro.
apply H0.
clear H0.
destruct H1. destruct H0.
exists x.
split.
apply SAnd2. exact H0.
exact H1.
apply IHt1_2.
exact H.
unfold OrthoS; unfold not; intro.
apply H0. clear H0.
destruct H1.
destruct H0.
exists x.
split.
apply SAnd3.
exact H0.
exact H1.
clear H.
clear IHt1.
(* Make a separate Lemma ? *)
unfold OrthoS in H0. unfold not in H0.
assert ((exists t3 : PTyp Base, t2 = Lift t3) \/ (exists t3 t4 : PTyp Inter, t2 = And t3 t4)).
apply invInter.
destruct H. destruct H.
rewrite H.
apply OLift.
unfold not; intros.
apply H0.
exists (Lift x).
rewrite H.
split.
apply SLift.
apply H1.
apply reflex.
(*case 2*)
unfold not; intros.
apply H0.
exists (Lift t1).
rewrite H.
split.
apply reflex.
apply SLift.
exact H1.
(* Part 2 *)
destruct H. destruct H.
rewrite H.
apply OAnd2.
rewrite H in H0.
admit.
admit.
Defined.

Lemma ortho_soundness : forall s (t1 t2 : PTyp s), (s = Inter) -> OrthoS s t1 t2 -> Ortho s t1 t2.
Proof.
induction t1; intros; unfold OrthoS in H.
(* Dummy cases *)
discriminate H.
discriminate H.
(* Case (t11 & t12) _|_ t2 *)
apply OAnd1.
apply IHt1_1.
exact H.
unfold OrthoS in H0.
unfold OrthoS.
unfold not.
intro.
apply H0.
clear H0.
destruct H1. destruct H0.
exists x.
split.
apply SAnd2. exact H0.
exact H1.
apply IHt1_2.
exact H.
unfold OrthoS; unfold not; intro.
apply H0. clear H0.
destruct H1.
destruct H0.
exists x.
split.
apply SAnd3.
exact H0.
exact H1.
clear H.
clear IHt1.
(* Make a separate Lemma ? *)
unfold OrthoS in H0. unfold not in H0.
(*
assert ((exists t3 : PTyp Base, t2 = Lift t3) \/ (exists t3 t4 : PTyp Inter, t2 = And t3 t4)).
apply invInter.*)
assert (exists t3, t2 = Lift t3).
admit. (* How to do this? *)
destruct H.
rewrite H.
apply OLift.
unfold not; intros.
apply H0.
exists (Lift x).
rewrite H.
split.
apply SLift.
apply H1.
apply reflex.
(*case 2*)
unfold not; intros.
apply H0.
exists (Lift t1).
rewrite H.
split.
apply reflex.
apply SLift.
exact H1.
Defined.

Lemma invAndS1 : forall t t1 t2 i, sub i t (And nat t1 t2) -> sub i t t1 /\ sub i t t2.
Proof.
(*
induction t; intros; split; try (inversion H); auto.
*)
induction t; intros.
(* Case Var *)
inversion H.
split.
exact H4.
exact H5.
(* Case Int *)
inversion H.
split.
exact H4.
exact H5.
(* Case Forall *)
inversion H0.
split.
exact H5.
exact H6.
(* Case Fun *)
inversion H.
split.
exact H4.
exact H5.
(* Case And *)
inversion H.
split.
exact H4.
exact H5.
assert (sub i t1 t0 /\ sub i t1 t3).
apply IHt1.
exact H4.
destruct H5.
split.
apply SAnd2.
exact H5.
apply SAnd2.
exact H6.
assert (sub i t2 t0 /\ sub i t2 t3).
apply IHt2.
exact H4.
destruct H5.
split.
apply SAnd3.
exact H5.
apply SAnd3.
exact H6.
Defined.

Definition transitivity_sub S Q T := forall i, sub i S Q -> sub i Q T -> sub i S T.

Lemma trans : forall Q T S, transitivity_sub S Q T.
induction Q.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
rewrite H4 in H. auto.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
(* Case Forall *)
unfold transitivity_sub. intros.
generalize H1 H0. clear H0. clear H1.
generalize S. clear S.
induction T; intro; intro; try (inversion H1); auto.
induction S; intro; try (inversion H6); intros; auto.
apply SForall.
inversion H7.
apply (H i); auto.
(* Case Fun *)
unfold transitivity_sub; intros.
generalize H0 H. clear H0. clear H.
generalize S. clear S.
induction T; intro; intro; try (inversion H0); auto.
induction S; intro; try (inversion H7); auto.
inversion H8.
apply SFun.
apply IHQ1; auto.
apply IHQ2; auto.
(* Case And *)
unfold transitivity_sub; intros.
assert (sub i S Q1 /\ sub i S Q2).
apply invAndS1; auto.
destruct H1.
generalize H1 H2.
induction T; intros.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply SAnd1.
apply IHT1; auto.
apply IHT2; auto.
apply IHQ1; auto.
apply IHQ2; auto.
Defined.

Definition Ortho A B := forall n, not (exists C, sub n A C /\ sub n B C).

Lemma p1 : forall (A B C : Prop), (A \/ B -> C) -> ((A -> C) /\ (B -> C)).
Proof.
intros.
split; intros.
apply H.
left.
exact H0.
apply H.
right.
exact H0.
Defined.

Definition equiv i t1 t2 := sub i t1 t2 /\ sub i t2 t1.

Definition contextEq i t1 t2 := (forall t, sub i t1 t -> sub i t2 t) /\ (forall t, sub i t t1 -> sub i t t2).

Definition narrowing_sub P Q X S T := forall i, sub i P Q -> (sub i X Q -> sub i S T) -> sub i X P -> sub i S T.

Lemma narrowing : forall X P Q S T, transitivity_sub X P Q -> narrowing_sub P Q X S T.
unfold narrowing_sub; intros.
apply H1.
apply H.
exact H2.
exact H0.
Defined.

Definition prog s (t2 : PTyp s) : Prop.
intros.
destruct s.
exact True.
exact ((exists t3, t2 = Lift t3) \/ (exists t3 t4, t2 = And t3 t4)).
Defined.

Print prog.

Lemma inv :
  forall s (t2 : PTyp s), prog s t2.
intros; unfold prog.
destruct t2.
auto.
auto.
right.
exists t2_1.
exists t2_2.
reflexivity.
left.
exists t2.
reflexivity.
Defined.

Lemma invInter (t2 : PTyp Inter) : (exists t3 : PTyp Base, t2 = Lift t3) \/ (exists t3 t4 : PTyp Inter, t2 = And t3 t4).
unfold prog.
apply (inv Inter).
Defined.

Definition substitutability :
  forall t1 t2 i, equiv i t2 t1 -> contextEq i t2 t1 /\ contextEq i t1 t2.
intro. intro. intro. intro.
destruct H.
induction H; split; try split; intros.
(* Case Int *)
exact H.
exact H.
exact H.
exact H.
(* Case Var *)
exact H.
exact H.
exact H.
exact H.
(* Case Forall *)
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
(* Case Fun *)
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
(* Case And1 *)
(*
generalize i, t1, t2, H, H1, H0, IHsub1, IHsub2, t0, H2.
clear H2. clear t0. clear IHsub2. clear IHsub1. clear H0. clear H1. clear H. clear t2. clear t1. clear i. *)
induction t; intros.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0. (*H2*)
apply SAnd2.
apply IHsub1.
exact H8.
exact H2. (*H3*)
apply SAnd3.
apply IHsub2.
exact H8.
exact H2. (*H3*)
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

Lemma ForallInv : forall t p g i, (forall t : PTyp nat, sub i (Forall nat p) t -> sub i (Forall nat g) t) ->
                  sub (i + 1) (p i) t -> sub (i + 1) (g i) t.
intros.
assert (sub i (Forall nat g) (Forall nat (fun i => t))).
apply H.
apply SForall.
exact H0.
inversion H1.
exact H5.
Defined.

Lemma FunInv1 : forall o t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t1 t -> sub i o t.
intros.
(* assert (sub i (Fun nat t3 t4) (Fun )). *)
admit.
Defined.

Lemma FunInv2 : forall t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t2 t -> sub i t4 t.
intros.
assert (exists t10, sub i (Fun nat t3 t4) (Fun nat t10 t)).
exists t1.
apply H.
apply SFun.
apply reflex.
exact H0.
destruct H1.
inversion H1.
exact H8.
Defined.

Lemma funnyLemma : forall t1 t3 i (s : sub i t1 t3) t2, (forall t, sub i t2 t -> sub i t3 t) -> sub i t1 t2.
intro. intro. intro. intro.
induction s; intros.
(* Case PInt *)
apply H.
apply reflex.
(* Case Var *)
apply H.
apply reflex.
(* Case Forall *)
assert (sub i (Forall nat g) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
assert (sub (i+1) (f i) (p i)).
apply IHs. intro.
apply (ForallInv _ _ _ _ H).
apply SForall.
exact H6.
apply SAnd1.
apply IHt2_1.
intros.
apply H.
apply SAnd2.
exact H7.
exact H5.
apply IHt2_2.
intros.
apply H.
apply SAnd3.
exact H7.
exact H6.
(* Case Fun *)
(*
generalize i, o1, o2, o3, o4 , s1, s2, IHs1, IHs2, H.
clear H. clear IHs2. clear IHs1. clear s2. clear s1. clear o4. clear o3. clear o2. clear o1. clear i.
induction t2; intros.
assert (sub i (Fun nat o3 o4) (Var nat a)).
apply H. apply reflex.
inversion H0.
admit.
admit.
apply SFun.
*)

assert (sub i (Fun nat o3 o4) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
apply SFun.
assert (sub i o3 t2_1).
apply IHs1.
intros.
assert (sub i (Fun nat o3 o4) (Fun nat (Fun nat o1 o2) t2_1)).
apply H.
apply SFun.
apply IHt2_1.
intros.
apply H.

(* Using H! *)
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

(* A functional definition : algorithm *)

Fixpoint size (t : PTyp nat) (i : nat) : nat :=
  match t with
      | PInt => 1
      | Var x => 1
      | Forall f => 1 + size (f i) (i+1)
      | And o1 o2 => 1 + max (size o1 i) (size o2 i)
      | Fun o1 o2 => 1 + max (size o1 i) (size o2 i)
  end.

Fixpoint subTyp (n : nat) (t1 : PTyp nat) (t2 : PTyp nat) (i : nat) : Prop  :=
  match n with
      | 0 => False
      | S m =>
          match (t1,t2) with
            | (PInt,PInt) => True
            | (Var x, Var y) => if (eq_nat_dec x y) then True else False
            | (Forall f, Forall g) => subTyp m (f i) (g i) (i+1)
            | (And o1 o2, And o3 o4) => and (subTyp m o1 o3 i) (subTyp m o2 o4 i)
            | (Fun o1 o2, Fun o3 o4) => and (subTyp m o3 o1 i) (subTyp m o2 o4 i)
            | (_,_) => False
          end
  end.

Lemma implements : forall t1 t2 n i, subTyp (size t1 n) t1 t2 i -> sub i t1 t2.
Proof.
induction t1; intros.
simpl in H.
destruct t2; try destruct H.
destruct (eq_nat_dec a n0).
rewrite e.
apply SVar. reflexivity.
destruct H.
destruct t2; try destruct H.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defrightangle_1 : (forall A B C : Universe, (exists X : Universe, (per_ A B C -> (betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C)))))).
Variable defrightangle2_2 : (forall A B C X : Universe, ((betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C))) -> per_ A B C)).
Variable cn_congruencereflexive_3 : (forall A B : Universe, cong_ A B A B).
Variable lemma_congruenceflip_4 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_ray1_5 : (forall A B P : Universe, (out_ A B P -> (betS_ A P B \/ (B = P \/ betS_ A B P)))).
Variable lemma_interior5_6 : (forall A B C D Xa Xb Xc Xd : Universe, ((betS_ A B C /\ (betS_ Xa Xb Xc /\ (cong_ A B Xa Xb /\ (cong_ B C Xb Xc /\ (cong_ A D Xa Xd /\ cong_ C D Xc Xd))))) -> cong_ B D Xb Xd)).
Variable lemma_betweennotequal_7 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable axiom_5_line_8 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).

Theorem lemma_8_3_9 : (forall A B C D : Universe, ((per_ A B C /\ out_ B C D) -> per_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.