Commit b2711d60 authored by Ralf Jung's avatar Ralf Jung

Add support for ElimInv to introduce a binder from the accessor

If the accessor introduces a binder, the first Coq-level intro pattern of `iInv`
is used for that binder unless the type of the binder is unit, in which case
`iInv` removes it completely.  Binders on the closing view shift are not (yet)
supported as they are harder to smoothly eliminate in the unit case.
parent b71c6f44
......@@ -92,7 +92,7 @@ Section proofs.
Global Instance into_inv_cinv N γ P : IntoInv (cinv N γ P) N.
Global Instance elim_inv_cinv E N γ P p :
Global Instance into_acc_cinv E N γ P p :
IntoAcc (X:=unit) (cinv N γ P)
(N E) (cinv_own γ p) E (E∖↑N)
(λ _, P cinv_own γ p)%I (λ _, P)%I (λ _, None)%I.
......
......@@ -109,7 +109,7 @@ Qed.
Global Instance into_inv_inv N P : IntoInv (inv N P) N.
Global Instance elim_inv_inv E N P :
Global Instance into_acc_inv E N P :
IntoAcc (X:=unit) (inv N P)
(N E) True E (E∖↑N) (λ _, P)%I (λ _, P)%I (λ _, None)%I.
Proof.
......
......@@ -113,7 +113,7 @@ Section proofs.
Global Instance into_inv_na p N P : IntoInv (na_inv p N P) N.
Global Instance elim_inv_na p F E N P :
Global Instance into_acc_na p F E N P :
IntoAcc (X:=unit) (na_inv p N P)
(N E N F) (na_own p F) E E
(λ _, P na_own p (F∖↑N))%I (λ _, P na_own p (F∖↑N))%I
......
......@@ -569,28 +569,31 @@ Qed.
the first binder. *)
(* ElimInv *)
Global Instance elim_inv_acc_without_close `{BiFUpd PROP} φ Pinv Pin
E1 E2 α β γ Q (Q' : () PROP) :
IntoAcc (X:=unit) Pinv φ Pin E1 E2 α β γ
AccElim (X:=unit) E1 E2 α β γ Q Q'
ElimInv φ Pinv Pin (α ()) None Q (Q' ()).
Global Instance elim_inv_acc_without_close `{BiFUpd PROP} {X : Type}
φ Pinv Pin
E1 E2 α β γ Q (Q' : X PROP) :
IntoAcc (X:=X) Pinv φ Pin E1 E2 α β γ
AccElim (X:=X) E1 E2 α β γ Q Q'
ElimInv φ Pinv Pin α None Q Q'.
Proof.
rewrite /AccElim /IntoAcc /ElimInv.
iIntros (Hacc Helim Hφ) "(Hinv & Hin & Hcont)".
iApply (Helim with "[Hcont]").
- rewrite right_id. iIntros ([]). done.
- iIntros (x) "Hα". iApply "Hcont". iSplitL; done.
- iApply (Hacc with "Hinv Hin"). done.
Qed.
Global Instance elim_inv_acc_with_close `{BiFUpd PROP} φ Pinv Pin
Global Instance elim_inv_acc_with_close `{BiFUpd PROP} {X : Type}
φ Pinv Pin
E1 E2 α β γ Q Q' :
IntoAcc (X:=unit) Pinv φ Pin E1 E2 α β γ
IntoAcc Pinv φ Pin E1 E2 α β γ
( R, ElimModal True false false (|={E1,E2}=> R) R Q Q')
ElimInv φ Pinv Pin (α ()) (Some (β () ={E2,E1}= default emp (γ ()) id))%I Q Q'.
ElimInv (X:=X) φ Pinv Pin α (Some (λ x, β x ={E2,E1}= default emp (γ x) id))%I
Q (λ _, Q').
Proof.
rewrite /AccElim /IntoAcc /ElimInv.
iIntros (Hacc Helim Hφ) "(Hinv & Hin & Hcont)".
iMod (Hacc with "Hinv Hin") as ([]) "[Hα Hclose]"; first done.
iMod (Hacc with "Hinv Hin") as (x) "[Hα Hclose]"; first done.
iApply "Hcont". simpl. iSplitL "Hα"; done.
Qed.
......
......@@ -573,14 +573,15 @@ Hint Mode IntoAcc + - ! - - - - - - - - : typeclass_instances.
TODO: Add support for a binder (like accessors have it).
This is defined on sbi instead of bi as typeclass search otherwise
fails (e.g. in the iInv as used in cancelable_invariants.v)
fails (e.g. in the iInv as used in cancelable_invariants.v).
*)
Class ElimInv {PROP : sbi} (φ : Prop)
(Pinv Pin : PROP) (Pout : PROP) (Pclose : option PROP) (Q Q' : PROP) :=
elim_inv : φ Pinv Pin (Pout default emp Pclose id - Q') Q.
Arguments ElimInv {_} _ _%I _%I _%I _%I _%I _%I : simpl never.
Arguments elim_inv {_} _ _%I _%I _%I _%I _%I _%I {_}.
Hint Mode ElimInv + - ! - - ! ! - : typeclass_instances.
Class ElimInv {PROP : sbi} {X : Type} (φ : Prop)
(Pinv Pin : PROP) (Pout : X PROP) (Pclose : option (X PROP))
(Q : PROP) (Q' : X PROP) :=
elim_inv : φ Pinv Pin ( x, Pout x (default (λ _, emp) Pclose id) x - Q' x) Q.
Arguments ElimInv {_} {_} _ _%I _%I _%I _%I _%I _%I : simpl never.
Arguments elim_inv {_} {_} _ _%I _%I _%I _%I _%I _%I {_}.
Hint Mode ElimInv + - - ! - - ! ! - : typeclass_instances.
(* We make sure that tactics that perform actions on *specific* hypotheses or
parts of the goal look through the [tc_opaque] connective, which is used to make
......@@ -628,6 +629,6 @@ Instance elim_modal_tc_opaque {PROP : bi} φ p p' (P P' Q Q' : PROP) :
ElimModal φ p p' P P' Q Q' ElimModal φ p p' (tc_opaque P) P' Q Q' := id.
Instance into_inv_tc_opaque {PROP : bi} (P : PROP) N :
IntoInv P N IntoInv (tc_opaque P) N := id.
Instance elim_inv_tc_opaque {PROP : sbi} φ Pinv Pin Pout Pclose Q Q' :
ElimInv (PROP:=PROP) φ Pinv Pin Pout Pclose Q Q'
Instance elim_inv_tc_opaque {PROP : sbi} {X} φ Pinv Pin Pout Pclose Q Q' :
ElimInv (PROP:=PROP) (X:=X) φ Pinv Pin Pout Pclose Q Q'
ElimInv φ (tc_opaque Pinv) Pin Pout Pclose Q Q' := id.
......@@ -1325,19 +1325,24 @@ Implicit Types Δ : envs PROP.
Implicit Types P Q : PROP.
(** * Invariants *)
Lemma tac_inv_elim Δ Δ' i j φ p Pinv Pin Pout (Pclose : option PROP) Q Q' :
Lemma tac_inv_elim {X : Type} Δ Δ' i j φ p Pinv Pin Pout (Pclose : option (X PROP))
Q (Q' : X PROP) :
envs_lookup_delete false i Δ = Some (p, Pinv, Δ')
ElimInv φ Pinv Pin Pout Pclose Q Q'
φ
( R, Δ'',
envs_app false (Esnoc Enil j (Pin - (Pout - maybe_wand Pclose Q') - R)%I) Δ' = Some Δ''
envs_app false (Esnoc Enil j
(Pin - ( x, Pout x - default (Q' x) Pclose (λ Pclose, Pclose x - Q' x)) - R)%I) Δ'
= Some Δ''
envs_entails Δ'' R)
envs_entails Δ Q.
Proof.
rewrite envs_entails_eq=> /envs_lookup_delete_Some [? ->] ?? /(_ Q) [Δ'' [? <-]].
rewrite envs_entails_eq=> /envs_lookup_delete_Some [? ->] Hinv ? /(_ Q) [Δ'' [? <-]].
rewrite (envs_lookup_sound' _ false) // envs_app_singleton_sound //; simpl.
apply wand_elim_r', wand_mono; last done. apply wand_intro_r, wand_intro_r.
rewrite intuitionistically_if_elim maybe_wand_sound -assoc wand_curry. auto.
rewrite intuitionistically_if_elim -assoc. destruct Pclose; simpl in *.
- setoid_rewrite wand_curry. auto.
- setoid_rewrite <-(right_id emp%I _ (Pout _)). auto.
Qed.
(** * Rewriting *)
......
This diff is collapsed.
......@@ -486,21 +486,28 @@ Global Instance add_modal_at_fupd_goal `{BiFUpd PROP} E1 E2 𝓟 𝓟' Q i :
AddModal 𝓟 𝓟' (|={E1,E2}=> Q i) AddModal 𝓟 𝓟' ((|={E1,E2}=> Q) i).
Proof. by rewrite /AddModal !monPred_at_fupd. Qed.
Global Instance elim_inv_embed_with_close φ 𝓟inv 𝓟in 𝓟out 𝓟close Pin Pout Pclose Q Q' :
( i, ElimInv φ 𝓟inv 𝓟in 𝓟out (Some 𝓟close) (Q i) (Q' i))
MakeEmbed 𝓟in Pin MakeEmbed 𝓟out Pout MakeEmbed 𝓟close Pclose
ElimInv φ ⎡𝓟inv Pin Pout (Some Pclose) Q Q'.
Proof.
rewrite /MakeEmbed /ElimInv=>H <- <- <- ?. iStartProof PROP.
iIntros (?) "(?&?&HQ')". iApply H; [done|]. iFrame. iIntros "?". by iApply "HQ'".
Qed.
Global Instance elim_inv_embed_without_close φ 𝓟inv 𝓟in 𝓟out Pin Pout Q Q' :
( i, ElimInv φ 𝓟inv 𝓟in 𝓟out None (Q i) (Q' i))
MakeEmbed 𝓟in Pin MakeEmbed 𝓟out Pout
ElimInv φ ⎡𝓟inv Pin Pout None Q Q'.
Proof.
rewrite /MakeEmbed /ElimInv=>H <- <- ?. iStartProof PROP.
iIntros (?) "(?&?&HQ')". iApply H; [done|]. iFrame. iIntros "?". by iApply "HQ'".
Global Instance elim_inv_embed_with_close {X : Type} φ
𝓟inv 𝓟in (𝓟out 𝓟close : X PROP)
Pin (Pout Pclose : X monPred)
Q (Q' : X monPred) :
( i, ElimInv φ 𝓟inv 𝓟in 𝓟out (Some 𝓟close) (Q i) (λ x, Q' x i))
MakeEmbed 𝓟in Pin ( x, MakeEmbed (𝓟out x) (Pout x))
( x, MakeEmbed (𝓟close x) (Pclose x))
ElimInv (X:=X) φ ⎡𝓟inv Pin Pout (Some Pclose) Q Q'.
Proof.
rewrite /MakeEmbed /ElimInv=>H <- Hout Hclose ?. iStartProof PROP.
setoid_rewrite <-Hout. setoid_rewrite <-Hclose.
iIntros (?) "(?&?&HQ')". iApply H; [done|]. iFrame. iIntros (x) "?". by iApply "HQ'".
Qed.
Global Instance elim_inv_embed_without_close {X : Type}
φ 𝓟inv 𝓟in (𝓟out : X PROP) Pin (Pout : X monPred) Q (Q' : X monPred) :
( i, ElimInv φ 𝓟inv 𝓟in 𝓟out None (Q i) (λ x, Q' x i))
MakeEmbed 𝓟in Pin ( x, MakeEmbed (𝓟out x) (Pout x))
ElimInv (X:=X) φ ⎡𝓟inv Pin Pout None Q Q'.
Proof.
rewrite /MakeEmbed /ElimInv=>H <-Hout ?. iStartProof PROP.
setoid_rewrite <-Hout.
iIntros (?) "(?&?&HQ')". iApply H; [done|]. iFrame. iIntros (x) "?". by iApply "HQ'".
Qed.
End sbi.
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