Commit 2f75a379 authored by charguer's avatar charguer

working

parent 7224defa
......@@ -53,7 +53,7 @@ Proof using.
applys rule_consequence.
{ hsimpl. }
{ applys rule_set. }
{ intros r. applys himpl_hprop_l. intros E. subst.
{ intros r. applys himpl_hpure_l. intros E. subst.
applys himpl_hprop_r. { auto. } { auto. } }
Qed.
......
......@@ -164,8 +164,8 @@ Proof using.
applys rule_consequence.
{ hsimpl. }
{ applys rule_set. }
{ intros r. applys himpl_hprop_l. intros E. subst.
applys himpl_hprop_r. { auto. } { auto. } }
{ intros r. applys himpl_hpure_l. intros E. subst.
applys himpl_hpure_r. { auto. } { auto. } }
Qed.
(** Same proof using [xapply], [xapplys] and [xpull] *)
......
......@@ -3687,4 +3687,90 @@ Proof using.
introv R W M. applys~ regular_frame_top H1 H2. { hchanges W. }
Qed.
*)
\ No newline at end of file
*)
(* LATER
Lemma hpull_hforall : forall A H1 H2 H' (J:A->hprop),
(exists x, H1 \* J x \* H2 ==> H') ->
H1 \* (hforall J \* H2) ==> H'.
Proof using.
introv (x&M). rewrite hstar_comm_assoc.
applys himpl_trans. applys hstar_hforall.
applys himpl_hforall_l. exists x.
rewrite~ <- hstar_comm_assoc.
Qed.
*)
(* partial support for hforall
Ltac hpull_step tt ::=
match goal with |- _ \* ?HN ==> _ =>
match HN with
| ?H \* _ =>
match H with
| \[] => apply hpull_empty
| \[_] => apply hpull_hprop; intros
| hexists _ => apply hpull_hexists; intros
| hforall _ => apply hpull_hforall
| _ \* _ => apply hpull_assoc
| _ => apply hpull_keep
end
| \[] => fail 1
| ?H => apply hpull_starify
end end.
*)
(* LATER
Lemma xpull_hforall : forall B (F:~~B) H1 H2 A (J:A->hprop) Q,
SepBasicSetup.is_local F ->
(exists x, F (H1 \* ((J x) \* H2)) Q) ->
F (H1 \* (hforall J \* H2)) Q.
Proof using.
intros. rewrite hstar_comm_assoc. apply~ local_extract_hexists.
intros. rewrite~ hstar_comm_assoc.
Qed.
*)
Lemma weaken_formula_trans : forall (F1 F2:formula),
(forall H' Q', (H' ==> F1 Q') -> (H' ==> F2 Q')) ->
F1 ===> F2.
Proof using. introv M. intros Q. applys~ M (F1 Q). Qed.
Definition sound_for (t:trm) (F:formula) :=
forall H Q, (H ==> F Q) -> triple t H Q.
Lemma sound_for_local : forall t (F:formula),
sound_for t F ->
sound_for t (local F).
Proof using.
unfold sound_for. introv SF. intros H Q M.
rewrite is_local_triple. unfold SepBasicSetup.local.
hchange M. unfold local. hpull ;=> Q'.
hsimpl (F Q') ((Q' \---* Q \*+ \Top)) Q'. split.
{ applys~ SF. }
{ hchanges qwand_cancel. }
Qed.
Definition sound_for' (t:trm) (F:formula) :=
forall Q, triple t (F Q) Q.
Lemma sound_for_eq_sound_for' :
sound_for = sound_for'.
Proof using.
applys pred_ext_2. intros t f.
unfold sound_for, sound_for'. intros. iff M.
{ intros Q. applys M. auto. }
{ intros H Q N. applys* rule_consequence N M. }
Qed.
Lemma sound_for'_local : forall t (F:formula),
sound_for' t F ->
sound_for' t (local F).
Proof using. introv. rewrite <- sound_for_eq_sound_for'. applys sound_for_local. Qed.
......@@ -464,6 +464,9 @@ Ltac xlocal_base tt ::=
(* ---------------------------------------------------------------------- *)
(* ** Structural rules *)
(** Note: all these rules could be derived directly from the fact that
[triple] satisfies [is_local], using lemmas from [SepFunctor] *)
Lemma rule_extract_hexists : forall t (A:Type) (J:A->hprop) Q,
(forall x, triple t (J x) Q) ->
triple t (hexists J) Q.
......@@ -472,6 +475,14 @@ Proof using.
destruct N as (x&N). applys* M.
Qed.
Lemma rule_extract_hforall : forall t (A:Type) (J:A->hprop) Q,
(exists x, triple t (J x) Q) ->
triple t (hforall J) Q.
Proof using.
introv (x&M). intros HF h N. lets N': hstar_hforall (rm N) x.
applys* M.
Qed.
Lemma rule_extract_hprop : forall t (P:Prop) H Q,
(P -> triple t H Q) ->
triple t (\[P] \* H) Q.
......@@ -480,6 +491,18 @@ Proof using.
applys rule_extract_hexists.
Qed.
Lemma rule_extract_hwand_hpure_l : forall t (P:Prop) H Q,
P ->
triple t H Q ->
triple t (\[P] \--* H) Q.
Proof using.
introv HP M. intros HF h N.
lets N': hstar_hwand (rm N).
lets U: (conj (rm HP) (rm N')). rewrite <- hstar_pure in U.
lets U': hwand_cancel (rm U).
applys* M.
Qed.
Lemma rule_consequence : forall t H' Q' H Q,
H ==> H' ->
triple t H' Q' ->
......@@ -515,6 +538,7 @@ Proof using.
introv M. applys rule_htop_post. applys~ rule_frame.
Qed.
(* ---------------------------------------------------------------------- *)
(* ** Term rules *)
......@@ -752,6 +776,61 @@ Proof using.
{ intros v Nv. hpull. } }
Qed.
(** Rules for for-loop not in normal form *)
Lemma rule_for_trm : forall (x:var) (t1 t2 t3:trm) H (Q:val->hprop) (Q1:val->hprop),
triple t1 H Q1 ->
(forall v1, exists Q2,
triple t2 (Q1 v1) Q2
/\ (forall v2, triple (trm_for x v1 v2 t3) (Q2 v2) Q)) ->
triple (trm_for x t1 t2 t3) H Q.
Proof using.
introv M1 M2. intros HF h Hf. forwards (h1'&v1&R1&K1): (rm M1) Hf.
lets (Q2&M2'&M3): ((rm M2) v1).
forwards* (h2'&v2&R2&K2): (rm M2') h1'.
rewrite <- (hstar_assoc \Top \Top) in K2. rewrite htop_hstar_htop in K2.
forwards* (h'&v'&R'&K'): ((rm M3) v2) h2'.
exists h' v'. splits~.
{ applys* red_for_arg. }
{ rewrite <- htop_hstar_htop. rew_heap~. }
Qed.
Definition is_val_int (v:val) :=
exists n, v = val_int n.
(* full rule, too complex *)
Lemma rule_for_trm_int : forall (x:var) (t1 t2 t3:trm) H (Q:val->hprop) (Q1:val->hprop),
triple t1 H Q1 ->
(forall v, ~ is_val_int v -> (Q1 v) ==> \[False]) ->
(forall (n1:int), exists Q2,
triple t2 (Q1 (val_int n1)) Q2
/\ (forall v, ~ is_val_int v -> (Q2 v) ==> \[False])
/\ (forall (n2:int), triple (trm_for x n1 n2 t3) (Q2 (val_int n2)) Q)) ->
triple (trm_for x t1 t2 t3) H Q.
Proof using. (* might be simplified using rule_for_trm *)
introv M1 nQ1 M2. intros HF h Hf. forwards (h1'&v1&R1&K1): (rm M1) Hf.
tests C1: (is_val_int v1).
{ destruct C1 as (n1&E). subst. lets (Q2&M2'&nQ2&M3): ((rm M2) n1).
forwards* (h2'&v2&R2&K2): (rm M2') h1'.
rewrite <- (hstar_assoc \Top \Top) in K2. rewrite htop_hstar_htop in K2.
tests C2: (is_val_int v2).
{ destruct C2 as (n2&E). subst.
forwards* (h'&v'&R'&K'): ((rm M3) n2) h2'.
exists h' v'. splits~.
{ applys* red_for_arg. }
{ rewrite <- htop_hstar_htop. rew_heap~. } }
{ specializes nQ2 C2.
asserts Z: ((\[False] \* \Top \* HF) h2').
{ applys himpl_trans K2. hchange nQ2. hsimpl. hsimpl. }
repeat rewrite hfalse_hstar_any in Z.
lets: hpure_inv Z. false*. } } (* LATER: shorten *)
{ specializes nQ1 C1.
asserts Z: ((\[False] \* \Top \* HF) h1').
{ applys himpl_trans K1. hchange nQ1. hsimpl. hsimpl. }
repeat rewrite hfalse_hstar_any in Z.
lets: hpure_inv Z. false*. } (* LATER: shorten *)
Qed.
(* ---------------------------------------------------------------------- *)
(** Primitive functions over the state *)
......@@ -770,7 +849,7 @@ Proof using.
exists (h1' \u h) (val_loc l). splits~.
{ applys~ red_ref. }
{ exists h1' h. split.
{ exists l. applys~ himpl_hprop_r. unfold h1'. hnfs~. }
{ exists l. applys~ himpl_hpure_r. unfold h1'. hnfs~. }
{ splits~. hhsimpl~. } }
Qed.
......@@ -818,7 +897,7 @@ Proof using. (* Note: [abs n] currently does not compute in Coq. *)
{ applys (red_alloc (abs n)); eauto.
rewrite~ abs_nonneg. }
{ exists h1' h. split.
{ exists l. applys~ himpl_hprop_r. applys~ Alloc_fmap_conseq. }
{ exists l. applys~ himpl_hpure_r. applys~ Alloc_fmap_conseq. }
{ splits~. hhsimpl~. } }
Qed.
......
This diff is collapsed.
......@@ -378,7 +378,18 @@ Proof using. intros. apply (Inhab_of_val hempty). Qed.
(* ---------------------------------------------------------------------- *)
(* ** Derived properties of [hempty], [hstar], [hpure], and [hexists] *)
(* ** Derived properties of operators *)
(** Properties of [himpl] *)
Lemma himpl_frame_r : forall H1 H2 H2',
H2 ==> H2' ->
(H1 \* H2) ==> (H1 \* H2').
Proof using.
introv M. do 2 rewrite (@hstar_comm H1). applys~ himpl_frame_l.
Qed.
(** Properties of [hempty] *)
Lemma hstar_hempty_r : forall H,
H \* \[] = H.
......@@ -388,6 +399,8 @@ Proof using.
applys~ hstar_hempty_l.
Qed.
(** Properties of [hpure] *)
Lemma hstar_pure : forall P H h,
(\[P] \* H) h = (P /\ H h).
Proof using.
......@@ -414,6 +427,21 @@ Proof using.
rewrite~ hstar_hempty_r.
Qed.
Lemma himpl_hpure_l : forall P H H',
(P -> H ==> H') ->
(\[P] \* H) ==> H'.
Proof using.
introv W Hh. rewrite hstar_pure in Hh. applys* W.
Qed.
Lemma himpl_hpure_r : forall P H H',
P ->
(H ==> H') ->
H ==> (\[P] \* H').
Proof using.
introv HP W. intros h Hh. rewrite~ hstar_pure.
Qed.
Lemma hempty_eq_hpure_true :
\[] = \[True].
Proof using.
......@@ -433,6 +461,8 @@ Lemma hpure_eq_hexists_empty : forall P,
\[P] = (Hexists (p:P), \[]).
Proof using. auto. Qed.
(** Properties of [hexists] *)
Lemma hexists_intro : forall A (x:A) (J:A->hprop) h,
J x h ->
(hexists J) h.
......@@ -443,32 +473,6 @@ Lemma hexists_inv : forall A (J:A->hprop) h,
exists x, J x h.
Proof using. intros. destruct H as [x H]. exists~ x. Qed.
(* ---------------------------------------------------------------------- *)
(* ** Derived properties of [himpl] *)
Lemma himpl_frame_r : forall H1 H2 H2',
H2 ==> H2' ->
(H1 \* H2) ==> (H1 \* H2').
Proof using.
introv M. do 2 rewrite (@hstar_comm H1). applys~ himpl_frame_l.
Qed.
Lemma himpl_hprop_l : forall P H H',
(P -> H ==> H') ->
(\[P] \* H) ==> H'.
Proof using.
introv W Hh. rewrite hstar_pure in Hh. applys* W.
Qed.
Lemma himpl_hprop_r : forall P H H',
P ->
(H ==> H') ->
H ==> (\[P] \* H').
Proof using.
introv HP W. intros h Hh. rewrite~ hstar_pure.
Qed.
Lemma himpl_hexists_l : forall A H (J:A->hprop),
(forall x, J x ==> H) ->
(hexists J) ==> H.
......@@ -484,6 +488,18 @@ Lemma himpl_hexists : forall A (J1 J2:A->hprop),
hexists J1 ==> hexists J2.
Proof using. introv W. intros h (x&M). exists x. applys~ W. Qed.
(** Properties of [hforall] *)
Lemma himpl_hforall_r : forall A (J:A->hprop) H,
(forall x, H ==> J x) ->
H ==> (hforall J).
Proof using. introv M. intros h Hh x. apply~ M. Qed.
Lemma himpl_hforall_l : forall A (J:A->hprop) H,
(exists x, J x ==> H) ->
(hforall J) ==> H.
Proof using. introv (x&M). intros h Hh. apply~ M. Qed.
Lemma himpl_hforall : forall A (J1 J2:A->hprop),
J1 ===> J2 ->
hforall J1 ==> hforall J2.
......@@ -785,7 +801,7 @@ Lemma hpull_hprop : forall H1 H2 H' P,
(P -> H1 \* H2 ==> H') ->
H1 \* (\[P] \* H2) ==> H'.
Proof using.
intros. rewrite hstar_comm_assoc. applys~ himpl_hprop_l.
intros. rewrite hstar_comm_assoc. applys~ himpl_hpure_l.
Qed.
Lemma hpull_empty : forall H1 H2 H',
......@@ -1050,7 +1066,7 @@ Lemma hcancel_hprop : forall H' H1 H2 P,
P ->
H' ==> H1 \* (\[P] \* H2).
Proof using.
intros. rewrite hstar_comm_assoc. applys~ himpl_hprop_r.
intros. rewrite hstar_comm_assoc. applys~ himpl_hpure_r.
Qed.
Lemma hcancel_hexists : forall A (x:A) H' H1 H2 (J:A->hprop),
......@@ -1732,7 +1748,6 @@ Tactic Notation "hchange" constr(E1) constr(E2) constr(E3) :=
(* ********************************************************************** *)
(* * Properties of the magic wand *)
......@@ -1759,6 +1774,8 @@ Proof using.
intros. unfold hwand. hsimpl ;=> H3 M. hchanges M.
Qed.
Arguments hwand_cancel : clear implicits.
Lemma hwand_move_r : forall H1 H2 H3,
H1 ==> (H2 \--* H3) ->
H1 \* H2 ==> H3.
......@@ -1778,6 +1795,8 @@ Proof using.
intros. unfold hwand. hsimpl ;=> H4 M. hchanges M.
Qed.
Arguments hwand_cancel_part : clear implicits.
Lemma hwand_move_part_r : forall H1 H2 H3 H4,
H2 ==> ((H1 \* H3) \--* H4) ->
H1 \* H2 ==> (H3 \--* H4).
......@@ -1793,9 +1812,6 @@ Proof using.
introv M. unfold hwand. hsimpl. hchanges (hwand_move_r M).
Qed.
Arguments hwand_cancel : clear implicits.
Arguments hwand_cancel_part : clear implicits.
Lemma hwand_of_himpl : forall (H1 H2:hprop),
H1 ==> H2 ->
\[] ==> (H1 \--* H2).
......@@ -1809,6 +1825,25 @@ Proof using.
intros. unfold hwand. hsimpl ;=> H4 M. hchanges M.
Qed.
Arguments hstar_hwand : clear implicits.
Lemma hstar_qwand : forall H A (Q1 Q2:A->hprop),
(Q1 \---* Q2) \* H ==> Q1 \---* (Q2 \*+ H).
Proof using.
intros. unfold qwand. hchanges hstar_hforall.
applys himpl_hforall. intros x.
hchanges hstar_hwand.
Qed.
Lemma hwand_hpure_himpl : forall (P:Prop) H1 H2,
P ->
H1 ==> H2 ->
\[P] \--* H1 ==> H2.
Proof using.
introv N M. intros h Hh. lets U: (conj N Hh).
rewrite <- hstar_pure in U. lets U': hwand_cancel U. applys* M.
Qed.
(* ---------------------------------------------------------------------- *)
(* ** Magic wand on [A->hprop] *)
......@@ -1975,6 +2010,18 @@ Proof using.
hchanges qwand_cancel.
Qed.
(** Ramified frame rule with top *)
Lemma local_ramified_frame_htop : forall Q1 H1 F H Q,
is_local F ->
F H1 Q1 ->
H ==> H1 \* (Q1 \---* Q \*+ \Top) ->
F H Q.
Proof using.
introv L M W. applys~ local_frame_htop (Q1 \---* Q \*+ \Top) M.
hchanges qwand_cancel.
Qed.
(** Weakening on pre and post from [local] *)
Lemma local_weaken : forall H' Q' F H Q,
......@@ -2096,6 +2143,18 @@ Proof using.
apply (himpl_hexists_r (J x \* H)). hsimpl. splits*. hsimpl.
Qed.
(** Extraction of forall below a star from [local] *)
Lemma local_extract_hforall : forall B (F:~~B) H A (J:A->hprop) Q,
is_local F ->
(exists x, F ((J x) \* H) Q) ->
F (hforall J \* H) Q.
Proof using.
introv L (x&M). rewrite L. unfold local.
hchange hstar_hforall. rew_heap. applys himpl_hforall_l.
exists x. hsimpl (J x \* H) Q. split~. hsimpl.
Qed.
(** Extraction of heap representation from [local] *)
Lemma local_name_heap : forall F H Q,
......@@ -2119,6 +2178,18 @@ Proof using.
applys~ local_extract_hprop.
Qed.
(** Extraction of proof obligations from the pre-condition under local *)
Lemma rule_extract_hwand_hpure_l : forall F (P:Prop) H Q,
is_local F ->
P ->
F H Q ->
F (\[P] \--* H) Q.
Proof using.
introv L N M. rewrite L. unfold local. applys~ hwand_hpure_himpl.
hsimpl H \[] Q. split~. hsimpl.
Qed.
(** Extraction of contradictions from the pre-condition under local *)
Lemma local_extract_false : forall F H Q,
......@@ -2470,6 +2541,16 @@ Proof using.
introv L. unfold weakestpre. hpull ;=> H1 M. hsimpl. xapplys M.
Qed.
Lemma weakestpre_pre : forall B (F:~~B) Q,
is_local F ->
F (weakestpre F Q) Q.
Proof using. intros. unfold weakestpre. xpull ;=> H'. auto. Qed.
Lemma himpl_weakestpre : forall B (F:~~B) H Q,
F H Q ->
H ==> weakestpre F Q.
Proof using. introv M. unfold weakestpre. hsimpl~ H. Qed.
(* ********************************************************************** *)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment