(* * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor. * *)
Declare Scope pred.
Delimit Scope pred with pred.
Local Open Scope pred.
(* A "pre-predicate" is hereditary iff whenever it is true at world a, it is also true at all worlds accessable from a via R. *)
Definition hereditary {A} (R:A->A->Prop) (p:A->Prop) :=
forall a a':A, R a a' -> p a -> p a'.
(* A predicate is a hereditary pre-predicate *)
Definition pred (A:Type) {AG:ageable A} :=
{ p:A -> Prop | hereditary age p }.
Bind Scope pred with pred.
(* Here is some junk that makes the definition of "pred" opaque to most tactics but still allows the "Program" extension to see it is a subset type.  The coercion is sugar that allows us to use predicates easily. *)
Definition app_pred {A} `{ageable A} (p:pred A) : A -> Prop := proj1_sig p.
Definition pred_hereditary `{ageable} (p:pred A) := proj2_sig p.
Coercion app_pred : pred >-> Funclass.
Global Opaque pred.
Hint Resolve @pred_hereditary : core.
Program Definition mkPred {A} `{ageable A} (p:A -> Prop) : pred A :=
fun x => forall x', necR x x' -> p x'.
Next Obligation.
repeat intro.
apply H1.
apply rt_trans with a'; auto.
apply rt_step; auto.
Qed.
(* The semantic notion of entailment. *)
Definition derives {A} `{ageable A} (P Q:pred A) := forall a:A, P a -> Q a.
Arguments derives [A] [H] _ _.
(* "valid" relations are those that commute with aging.  These relations are the ones that can be turned into modalities. *)
Definition valid_rel {A} `{ageable A} (R:relation A) : Prop :=
commut A age R /\ commut A R age.
(* A modaility is a valid relation *)
Definition modality {A} `{ageable A} := { R:relation A | valid_rel R }.
(* More black magic to make the definition of modaility mostly opaque. *)
Definition app_mode {A} `{ageable A} (m:modality) : A -> A -> Prop := proj1_sig m.
Definition mode_valid {A} `{ageable A} (m:modality) := proj2_sig m.
Global Opaque modality.
Coercion app_mode : modality >-> Funclass.
(* commutivity facts for the basic relations *)
(* Definitions of the basic modalities. *)
Definition ageM {A} `{ageable A} : modality
:= exist _ age valid_rel_age.
Definition laterM {A} `{ageable A} : modality
:= exist _ laterR valid_rel_later.
(* Definition necM {A} `{ageable A} : modality := exist _ necR valid_rel_nec. *)
Hint Resolve rt_refl rt_trans t_trans : core.
Hint Unfold necR : core.
Obligation Tactic := unfold hereditary; intuition;
first [eapply pred_hereditary; eauto; fail | eauto ].
(* Definitions of the basic propositional conectives. *)
(* Lifting pure mathematical facts to predicates *)
Program Definition prop {A} `{ageable A}  (P: Prop) : pred A := (fun _  => P).
Definition TT {A} `{ageable A}: pred A := prop True.
Definition FF  {A} `{ageable A}: pred A := prop False.
Program Definition imp {A} `{ageable A} (P Q:pred A) : pred A :=
fun a:A => forall a':A, necR a a' -> P a' -> Q a'.
Next Obligation.
apply H1; auto.
apply rt_trans with a'; auto.
apply rt_step; auto.
Qed.
Program Definition orp {A} `{ageable A} (P Q:pred A) : pred A :=
fun a:A => P a \/ Q a.
Next Obligation.
left; eapply pred_hereditary; eauto.
right; eapply pred_hereditary; eauto.
Qed.
Program Definition andp {A} `{ageable A} (P Q:pred A) : pred A :=
fun a:A => P a /\ Q a.
(* Universal and exp quantification *)
Program Definition allp {A} `{ageable A} {B: Type} (f: B -> pred A) : pred A
:= fun a => forall b, f b a.
Next Obligation.
apply pred_hereditary with a; auto.
apply H1.
Qed.
Program Definition exp {A} `{ageable A} {B: Type} (f: B -> pred A) : pred A
:= fun a => exists b, f b a.
Next Obligation.
destruct H1; exists x; eapply pred_hereditary; eauto.
Qed.
(* Definition of the "box" modal operator.  This operator turns modalities (relations) into a "necessarily" type operator. *)
Program Definition box {A} `{ageable A} (M:modality) (P:pred A) : pred A :=
fun a:A => forall a', M a a' -> P a'.
Next Obligation.
destruct M as [M [H3 H4]]; simpl in *.
destruct (H4 _ _ H2 _ H0).
apply pred_hereditary with x; auto.
apply H1; auto.
Qed.
(* Definition of the "diamond" modal operator.  This operator turns modalities into a "possibly" type operator.  _However_, note that this is NOT the boolean dual to "box", as usually found in accounts of modal logic. Instead, this is the "proof-theoretic" dual as found in Restall's "A Introduction to Substructural Logic" (2000). *)
Program Definition diamond {A} `{ageable A} (M:modality) (P:pred A) : pred A :=
fun a:A => exists a', M a' a /\ P a'.
Next Obligation.
destruct M as [M [H3 H4]]; simpl in *.
destruct H1 as [x [? ?]].
destruct (H3 _ _ H0 _ H1).
exists x0; split; auto.
apply pred_hereditary with x; auto.
Qed.
Definition boxy {A} `{ageable A} (m: modality) (p: pred A): Prop :=  box m p = p.
(* A pile of notations for the operators we have defined *)
Declare Scope pred_derives.
Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity) : pred_derives.
Open Scope pred_derives.
Notation "'EX' x .. y , P " :=
(exp (fun x => .. (exp (fun y => P%pred)) ..)) (at level 65, x binder, y binder, right associativity) : pred.
Notation "'ALL' x .. y , P " :=
(allp (fun x => .. (allp (fun y => P%pred)) ..)) (at level 65, x binder, y binder, right associativity) : pred.
Infix "||" := orp (at level 50, left associativity) : pred.
Infix "&&" := andp (at level 40, left associativity) : pred.
Notation "P '-->' Q" := (imp P Q) (at level 55, right associativity) : pred.
Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : pred.
(* Notation "'[]' e" := (box necM e) (at level 30, right associativity): pred. *)
Notation "'|>' e" := (box laterM e) (at level 30, right associativity): pred.
Notation "'!!' e" := (prop e) (at level 25) : pred.
(* Some facts about modalities *)
Arguments box_e0 [A] _ _ _ _ _ _.
(* Lemma necM_refl {A} `{ageable A}: reflexive _ necM.  Hint Resolve @necM_refl. *)
(* Box is a normal modal operator *)
(* Box and diamond are positive modal operators *)
(* Disribuitivity of box over various connectives *)
(* Distributivity of diamond over various operators *)
(* Lemmas about aging and the later operator *)
(* Lemma nec_useless {A} `{ageable A} : forall P, []P = P. intros. apply pred_ext; intros. hnf; intros; apply H0. simpl; apply necM_refl. hnf; intros. hnf; intros. apply pred_nec_hereditary with a; auto. Qed. *)
(* The "induction" rule for later *)
(* Later distributes over almost everything! *)
Hint Resolve @boxy_andp : core.
Hint Resolve @boxy_disjunction : core.
Hint Resolve @boxy_exp : core.
Hint Resolve @boxy_TT : core.
Hint Resolve @boxy_FF : core.
Hint Resolve @TT_i : core.
Hint Resolve @boxy_allp : core.
Hint Resolve @derives_refl : core.
Program Definition exactly {A} `{ageable A} (x: A) : pred A := necR x.
Next Obligation.
constructor 3 with a; auto.
constructor 1; auto.
Qed.
Hint Resolve @derives_TT : core.
Hint Immediate @FF_derives : core.
Ltac slurp :=
apply imp_lem0;
match goal with |-  app_pred (_ --> _)  ?st =>
repeat match goal with
| H: app_pred ?P st |- app_pred (?b --> ?c) st =>
(apply (@conjoin_hyp0 _ _ P c st H) ||
(apply (@conjoin_hyp1 _ _ P b c st H)));
clear H
end;
try (revert st; apply derives_e)
end.

Lemma test_slurp {A} `{agA : ageable A} :  forall  (P Q R S : pred A) w ,
(P && (Q && R) --> S) w -> P w -> Q w -> R w -> S w.