(* * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor. * *)
Definition compareR {A} {JA: Join A}{SA: Sep_alg A}{AG: ageable A} : relation A
:= comparable.
Definition extendR  {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A} : relation A := join_sub.
Definition compareM {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : modality
:= exist _ compareR valid_rel_compare.
Definition extendM {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : modality
:= exist _ extendR valid_rel_extend.
(* Definitions of the BI connectives. *)
Obligation Tactic := unfold hereditary; intros; try solve [intuition].
Program Definition emp {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : pred A := identity.
Next Obligation.
repeat intro.
destruct (unage_join _ H1 H) as [a0' [b' [? [? ?]]]].
apply H0 in H2. subst b'. unfold age in H3, H4. congruence.
Qed.
Program Definition sepcon {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (p q:pred A) : pred A := fun x:A =>
exists y:A, exists z:A, join y z x /\ p y /\ q z.
Next Obligation.
destruct H0 as [y [z [? [? ?]]]].
destruct (age1_join2 _ H0 H) as [w [v [? [? ?]]]].
exists w; exists v; split; auto.
split.
apply pred_hereditary with y; auto.
apply pred_hereditary with z; auto.
Qed.
Program Definition wand {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (p q:pred A) : pred A := fun x =>
forall x' y z, necR x x' -> join x' y z -> p y -> q z.
Next Obligation.
apply H0 with x' y; auto.
apply rt_trans with a'; auto.
apply rt_step; auto.
Qed.
Notation "P '*' Q" := (sepcon P Q) : pred.
Notation "P '-*' Q" := (wand P Q) (at level 60, right associativity) : pred.
Notation "'%' e"  := (box extendM e)(at level 30, right associativity): pred.
Hint Resolve @extendM_refl : core.
Hint Resolve @compareM_refl : core.
(* Rules for the BI connectives *)
(*Lemma emp_sepcon : forall {A} `{Age_alg A} (P:pred A), emp * P = P.  Lemma later_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall P Q, (|>(P * Q) = |>P * |>Q)%pred.  Lemma FF_sepcon : forall {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (P:pred A), (FF * P = FF)%pred.  Lemma sepcon_derives {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall p q p' q', (p |-- p') -> (q |-- q') -> (p * q |-- p' * q').  Lemma exp_sepcon1 {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall T (P: T ->  pred A) Q,  (exp P * Q = exp (fun x => P x * Q))%pred.  Lemma exp_sepcon2 {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall T (P: pred A) (Q: T -> pred A),  (P * exp Q = exp (fun x => P * Q x))%pred.  Lemma extend_later {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall P, (%|>P = |>%P)%pred.  Lemma extend_later' {A}{JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall P, boxy extendM P -> boxy extendM (|> P). Hint Resolve @extend_later' : core.  Lemma age_sepcon {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall P Q, (box ageM (P * Q) = box ageM P * box ageM Q)%pred.   Lemma age_twin {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall phi1 phi2 n phi1', comparable phi1 phi2 -> ageN n phi1 = Some phi1' -> exists phi2', ageN n phi2 = Some phi2' /\ comparable phi1' phi2'.  Lemma ageN_different {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall n phi phi', ageN (S n) phi = Some phi' -> ~ comparable phi phi'.  Lemma necR_comparable{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall w w', necR w w' -> comparable w w' -> w=w'.   Lemma sepcon_andp_prop {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall P Q R, (P * (!!Q && R) = !!Q && (P * R))%pred.  Lemma TT_sepcon_TT {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: (TT * TT = TT)%pred.   Lemma join_exactly {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall w1 w2 w3, join w1 w2 w3 ->  (exactly w1 * exactly w2 = exactly w3)%pred.  Lemma extend_sepcon_andp {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall P Q R, boxy extendM Q -> P * (Q && R) |-- Q && (P * R). Arguments extend_sepcon_andp : clear implicits.  Lemma distrib_sepcon_andp {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall P Q R, P * (Q && R) |-- (P * Q) && (P * R).  Lemma modus_wand {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall P Q,  P * (P -* Q) |-- Q.  Lemma extend_sepcon {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall {Q R: pred A}, boxy extendM Q ->  Q * R |-- Q.  Definition precise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} (P: pred A) : Prop := forall w w1 w2, P w1 -> P w2 -> join_sub w1 w -> join_sub w2 w -> w1=w2.  Definition precise2  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} (P: pred A) : Prop := forall Q R, (P * (Q && R) = (P * Q) && (P * R))%pred.  Lemma precise_eq {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{AG: ageable A}{XA: Age_alg A}: precise = fun P : pred A => forall Q R, (P * (Q && R) = (P * Q) && (P * R))%pred.  Lemma derives_precise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall P Q, (P |-- Q) -> precise Q -> precise P.  Lemma precise_emp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: precise emp.  Definition superprecise {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} (P: pred A) := forall w1 w2, P w1 -> P w2 -> comparable w1 w2 -> w1=w2.  Lemma superprecise_exactly {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall w, superprecise (exactly w). Hint Resolve @superprecise_exactly : core.  Lemma superprecise_precise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall (P: pred A) , superprecise P -> precise P.  (* EXistential Magic Wand *)
Program Definition ewand {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (P Q: pred A) : pred A :=
fun w => exists w1, exists w2, join w1 w w2 /\ P w1 /\ Q w2.
Next Obligation.
destruct H0 as [w1 [w2 [? [? ?]]]].
apply join_comm in H0; eapply age1_join in H0; eauto.
destruct H0 as [w1' [w3' [? [? ?]]]].
exists w1'; exists w3'; split; auto.
split;   eapply pred_nec_hereditary; try eassumption.
constructor 1; auto.
constructor 1; auto.
Qed.
(* Notation "P '-o' Q" := (ewand P Q) (at level 60, right associativity). *)
Definition wk_split {A} {JA: Join A} :=
forall a b c d e : A, join a b c -> join d e c -> joins a d -> join_sub d b.

Lemma wk_pry_apart {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA: Disj_alg A}{CrA: Cross_alg A}{AG: ageable A}{XA: Age_alg A}:
forall G P Q, wk_split -> superprecise G -> P = ewand G (G * P) ->
(P * Q) && (G * TT) |-- (P * G * (ewand G Q)).