RunST.IC

From iris.base_logic.lib Require Export fancy_updates.
From iris.program_logic Require Export language.
From iris.base_logic Require Import auth big_op.
From iris.proofmode Require Import tactics classes.
From iris.algebra Require Import auth.
From RunST Require Import future reduction.
Import uPred.

Class ICState' (Λstate : Type) : Type := Build_ICState{
  IC_stateR : ucmraT;
  IC_stateR_discrete : CMRADiscrete IC_stateR;
  IC_to_stateR : Λstate IC_stateR;
}.

Section ICG.
  Local Set Primitive Projections.

  Class ICG' (Λstate : Type) `{ICState' Λstate} (Σ : gFunctors) := Build_ICG {
    IC_invG :> invG Σ;
    ICstate_inG :> authG Σ IC_stateR;
  }.
End ICG.

Notation ICG Λ Σ := (ICG' (state Λ) Σ).
Notation ICState Λ := (ICState' (state Λ)).

Definition ownP_full `{ICG' Λstate Σ} γ (σ : Λstate) : iProp Σ :=
  own γ ( (IC_to_stateR σ)).
Typeclasses Opaque ownP_full.
Instance: Params (@ownP_full) 5.

Definition ic_def {Λ Σ} `{ICState Λ, ICG Λ Σ} γ E e Φ : iProp Σ :=
  ( σ1 σ2 v n,
      (( nsteps pstep n (e, σ1) (of_val v, σ2)) ownP_full γ σ1)
      -★ |≫{E}=[n]=> Φ v n ownP_full γ σ2)%I.
Definition ic_aux : { x | x = @ic_def }. by eexists. Qed.
Definition ic := proj1_sig ic_aux.
Definition ic_eq : @ic = @ic_def := proj2_sig ic_aux.

Arguments ic {_ _ _ _} _ _ _%E _.
Instance: Params (@ic) 7.

Notation "'IC' e @ E {{ Φ } }[ γ ]" := (ic γ E e%E Φ)
  (at level 20, e, Φ at level 200,
   format "'IC' e @ E {{ Φ } }[ γ ]") : uPred_scope.
Notation "'IC' e {{ Φ } }[ γ ]" := (ic γ e%E Φ)
  (at level 20, e, Φ at level 200,
   format "'IC' e {{ Φ } }[ γ ]") : uPred_scope.

Notation "'IC' e @ E {{ v ; n , Q } }[ γ ]" := (ic γ E e%E (λ v n, Q))
  (at level 20, e, Q at level 200,
   format "'IC' e @ E {{ v ; n , Q } }[ γ ]") : uPred_scope.
Notation "'IC' e @ E {{ v , Q } }[ γ ]" := (ic γ E e%E (λ v _, Q))
  (at level 20, e, Q at level 200,
   format "'IC' e @ E {{ v , Q } }[ γ ]") : uPred_scope.
Notation "'IC' e {{ v ; n , Q } }[ γ ]" := (ic γ e%E (λ v n, Q))
  (at level 20, e, Q at level 200,
   format "'IC' e {{ v ; n , Q } }[ γ ]") : uPred_scope.
Notation "'IC' e {{ v , Q } }[ γ ]" := (ic γ e%E (λ v _, Q))
  (at level 20, e, Q at level 200,
   format "'IC' e {{ v , Q } }[ γ ]") : uPred_scope.

(* Texan IC triples *)
Notation "'{{{|' P |} } } e {{{| x .. y ; pat , Q |} } }[ γ ]" :=
  ( Φ,
      P ( x, .. ( y, Q -★ Φ pat%V) .. ) -★ IC e {{ Φ }}[γ])%I
    (at level 20, x closed binder, y closed binder,
     format "{{{| P |} } } e {{{| x .. y ; pat , Q |} } }[ γ ]") : uPred_scope.
Notation "'{{{|' P |} } } e @ E {{{| x .. y ; pat , Q |} } }[ γ ]" :=
  ( Φ,
      P ( x, .. ( y, Q -★ Φ pat%V) .. ) -★ IC e @ E {{ Φ }}[γ])%I
    (at level 20, x closed binder, y closed binder,
     format "{{{| P |} } } e @ E {{{| x .. y ; pat , Q |} } }[ γ ]") : uPred_scope.
Notation "'{{{|' P |} } } e {{{| ; pat , Q |} } }[ γ ]" :=
  ( Φ, P (Q -★ Φ pat%V) -★ IC e {{ Φ }}[γ])%I
        (at level 20,
     format "{{{| P |} } } e {{{| ; pat , Q |} } }[ γ ]") : uPred_scope.
Notation "'{{{|' P |} } } e @ E {{{| ; pat , Q |} } }[ γ ]" :=
  ( Φ, P (Q -★ Φ pat%V) -★ IC e @ E {{ Φ }}[γ])%I
    (at level 20,
     format "{{{| P |} } } e @ E {{{| ; pat , Q |} } }[ γ ]") : uPred_scope.

Notation "'{{{|' P |} } } e {{{| x .. y ; pat , Q |} } }[ γ ]" :=
  ( Φ : _ uPred _,
      P ( x, .. ( y, Q -★ Φ pat%V) .. ) IC e {{ Φ }}[γ])
    (at level 20, x closed binder, y closed binder,
     format "{{{| P |} } } e {{{| x .. y ; pat , Q |} } }[ γ ]") : C_scope.
Notation "'{{{|' P |} } } e @ E {{{| x .. y ; pat , Q |} } }[ γ ]" :=
  ( Φ : _ uPred _,
      P ( x, .. ( y, Q -★ Φ pat%V) .. ) IC e @ E {{ Φ }}[γ])
    (at level 20, x closed binder, y closed binder,
     format "{{{| P |} } } e @ E {{{| x .. y ; pat , Q |} } }[ γ ]") : C_scope.
Notation "'{{{|' P |} } } e {{{| ; pat , Q |} } }[ γ ]" :=
  ( Φ : _ uPred _, P (Q -★ Φ pat%V) IC e {{ Φ }}[γ])
    (at level 20,
     format "{{{| P |} } } e {{{| ; pat , Q |} } }[ γ ]") : C_scope.
Notation "'{{{|' P |} } } e @ E {{{| ; pat , Q |} } }[ γ ]" :=
  ( Φ : _ uPred _, P (Q -★ Φ pat%V) IC e @ E {{ Φ }}[γ])
    (at level 20,
     format "{{{| P |} } } e @ E {{{| ; pat , Q |} } }[ γ ]") : C_scope.

Section ic.
Context `{ICState Λ, ICG Λ Σ}.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ nat iProp Σ.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.

Global Instance ic_ne γ E e n :
  Proper (pointwise_relation _ ((dist n) ==> (dist n)) ==> dist n)
         (@ic Λ Σ _ _ γ E e).
Proof.
  intros Φ1 Φ2 R; rewrite ic_eq /ic_def.
  repeat apply forall_ne => ?; apply wand_ne; auto.
  by rewrite R.
Qed.
Global Instance ic_proper γ E e :
  Proper (pointwise_relation _ ((≡) ==> (≡)) ==> (≡)) (@ic Λ Σ _ _ γ E e).
Proof.
  intros Φ Φ' R; apply equiv_dist=>n; apply ic_ne=>v k k' ->; apply equiv_dist.
  by rewrite R.
Qed.

Lemma ic_value' γ E Φ v : Φ v 0 IC of_val v @ E {{ Φ }}[γ].
Proof.
  iIntros "HΦ". rewrite ic_eq /ic_def.
  iIntros (σ1 σ2 w n) "[H Hown]"; iDestruct "H" as %Hstp.
  inversion Hstp as [Hs1 Hs2 Hs3 Hs4|Hs1 Hs2 Hs3 Hs4 Hs5]; subst.
  - erewrite (of_val_inj _ _ Hs4). iModIntro; iFrame.
  - simpl in *. apply val_stuck in Hs5. by rewrite to_of_val in Hs5.
Qed.

Lemma ic_strong_mono γ E1 E2 e Φ Ψ :
  E1 E2 ( v n, Φ v n ={E2}=★ Ψ v n)
               IC e @ E1 {{ Φ }}[γ] IC e @ E2 {{ Ψ }}[γ].
Proof.
  iIntros (Hsb) "[Hi H]". rewrite ic_eq /ic_def.
  iIntros (σ1 σ2 v n) "[Hr Ho]".
  iSpecialize ("H" $! σ1 σ2 v n with "[Hr Ho]"); first by iFrame.
  iMod (future_mask_mono with "H") as "[Hp $]"; trivial.
  replace (n - n) with 0 by omega; rewrite future_unfold_O.
  by iMod ("Hi" $! _ _ with "Hp").
Qed.

Lemma fupd_ic γ E e Φ : (|={E}=> IC e @ E {{ Φ }}[γ]) IC e @ E {{ Φ }}[γ].
Proof.
  iIntros "Hm". rewrite ic_eq /ic_def.
  iIntros (σ1 σ2 v n) "[Hr Ho]".
  iMod "Hm"; iModIntro.
  iSpecialize ("Hm" $! σ1 σ2 v n with "[Hr Ho]"); by iFrame.
Qed.

Lemma ic_fupd γ E e Φ :
  IC e @ E {{ v; n, |={E}=> Φ v n }}[γ] IC e @ E {{ Φ }}[γ].
Proof. iIntros "H". iApply (ic_strong_mono γ E); try iFrame; auto. Qed.

Lemma ic_bind K `{!LanguageCtx Λ K} γ E e Φ :
  IC e @ E {{ v; m, IC K (of_val v) @ E {{w; n, Φ w (m + n)}}[γ] }}[γ]
     IC K e @ E {{ Φ }}[γ].
Proof.
  iIntros "H".
  rewrite ic_eq /ic_def; iIntros (σ1 σ2 v n) "[Hr Ho]"; iDestruct "Hr" as %Hr.
  destruct (nsteps_bind _ Hr) as (k & σ' & w & Hle & Hstp1 & Hstp2).
  iMod ("H" $! σ1 σ' w k with "[Ho]") as "[H Ho]"; first by iFrame.
  iSpecialize ("H" $! σ' σ2 v (n-k) with "[Ho]"); first by iFrame.
  iMod "H".
  replace (n - k - (n - k)) with 0 by omega.
  replace (k + (n - k)) with n by omega.
  by iFrame.
Qed.

Derived rules

Lemma ic_mono γ E e Φ Ψ : ( v n, Φ v n Ψ v n)
  IC e @ E {{ Φ }}[γ] IC e @ E {{ Ψ }}[γ].
Proof.
  iIntros () "H"; iApply (ic_strong_mono _ E); auto.
  iFrame. iIntros (v n) "?". by iApply .
Qed.
Lemma ic_mask_mono γ E1 E2 e Φ : E1 E2
  IC e @ E1 {{ Φ }}[γ] IC e @ E2 {{ Φ }}[γ].
Proof. iIntros (?) "H". iApply (ic_strong_mono _ E1); auto. iFrame; eauto. Qed.
Global Instance ic_mono' γ E e :
  Proper (pointwise_relation _ ((≡) ==> (⊢)) ==> (⊢)) (@ic Λ Σ _ _ γ E e).
Proof. intros Φ Φ' H. by apply ic_mono => ? ?; apply H. Qed.

Lemma ic_value γ E Φ e v : to_val e = Some v Φ v 0 IC e @ E {{ Φ }}[γ].
Proof. intros; rewrite -(of_to_val e v) //; by apply ic_value'. Qed.
Lemma ic_value_fupd' γ E Φ v : (|={E}=> Φ v 0) IC of_val v @ E {{ Φ }}[γ].
Proof. intros. by rewrite -ic_fupd -ic_value'. Qed.
Lemma ic_value_fupd γ E Φ e v :
  to_val e = Some v (|={E}=> Φ v 0) IC e @ E {{ Φ }}[γ].
Proof. intros. rewrite -ic_fupd -ic_value //. Qed.

Lemma ic_frame_l γ E e Φ R :
  R IC e @ E {{ Φ }}[γ] IC e @ E {{ v; n, R Φ v n }}[γ].
Proof.
  iIntros "[??]". iApply (ic_strong_mono _ E E _ Φ); try iFrame; eauto.
  iIntros (??); auto.
Qed.
Lemma ic_frame_r γ E e Φ R :
  IC e @ E {{ Φ }}[γ] R IC e @ E {{ v; n, Φ v n R }}[γ].
Proof.
  iIntros "[??]". iApply (ic_strong_mono _ E E _ Φ); try iFrame; eauto.
  iIntros (??); auto.
Qed.

Lemma ic_wand_l γ E e Φ Ψ :
  ( v n, Φ v n -★ Ψ v n) IC e @ E {{ Φ }}[γ] IC e @ E {{ Ψ }}[γ].
Proof.
  iIntros "[H Hic]". iApply (ic_strong_mono _ E); auto.
  iFrame "Hic". iIntros (??) "?". by iApply "H".
Qed.
Lemma ic_wand_r γ E e Φ Ψ :
  IC e @ E {{ Φ }}[γ] ( v n, Φ v n -★ Ψ v n) IC e @ E {{ Ψ }}[γ].
Proof. by rewrite comm ic_wand_l. Qed.
End ic.

Proofmode class instances
Section proofmode_classes.
  Context `{ICState Λ, ICG Λ Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val Λ nat iProp Σ.

  Global Instance frame_ic γ E e R Φ Ψ :
    ( v n, Frame R (Φ v n) (Ψ v n))
    Frame R (IC e @ E {{ Φ }}[γ]) (IC e @ E {{ Ψ }}[γ]).
  Proof. rewrite /Frame=> HR. rewrite ic_frame_l. apply ic_mono, HR. Qed.

  Global Instance is_except_0_ic γ E e Φ : IsExcept0 (IC e @ E {{ Φ }}[γ]).
  Proof. by rewrite /IsExcept0 -{2}fupd_ic -except_0_fupd -fupd_intro. Qed.

  Global Instance elim_modal_bupd_ic γ E e P Φ :
    ElimModal (|==> P) P (IC e @ E {{ Φ }}[γ]) (IC e @ E {{ Φ }}[γ]).
  Proof. by rewrite /ElimModal (bupd_fupd E) fupd_frame_r wand_elim_r fupd_ic. Qed.

  Global Instance elim_modal_fupd_ic γ E e P Φ :
    ElimModal (|={E}=> P) P (IC e @ E {{ Φ }}[γ]) (IC e @ E {{ Φ }}[γ]).
  Proof. by rewrite /ElimModal fupd_frame_r wand_elim_r fupd_ic. Qed.

  (* lower precedence, if possible, it should always pick elim_upd_fupd_ic *)
  Global Instance elim_modal_fupd_ic_change_mask γ E1 E2 e P Φ :
    atomic e
    ElimModal (|={E1,E2}=> P) P
            (IC e @ E1 {{ Φ }}[γ]) (|={E2,E1}=> IC e @ E1 {{ Φ }}[γ])%I | 10.
  Proof.
    intros. rewrite /ElimModal fupd_frame_r wand_elim_r.
    iIntros "H". iApply fupd_ic. by do 2 iMod "H".
  Qed.

  Global Instance elim_modal_ic_ic γ E v Φ Ψ :
    ElimModal (IC of_val v @ E {{ Φ }}[γ]) (Φ v 0)
            (IC e @ E {{ Ψ }}[γ]) (IC e @ E {{ Ψ }}[γ])%I | 100.
  Proof.
    intros. rewrite /ElimModal. rewrite ic_eq /ic_def.
    iIntros "[H1 H2]". iIntros (σ1 σ2 w n) "[Hr Ho]"; iDestruct "Hr" as %Hr.
    iMod ("H1" $! σ1 σ1 v 0 with "[Ho]") as "[Hp Ho]"; first iFrame.
    { iPureIntro; constructor. }
    iSpecialize ("H2" with "Hp").
    iMod ("H2" $! σ1 σ2 w n with "[Ho]") as "[Hp Ho]"; first by iFrame.
    replace (n - 0 - n) with 0 by omega. by iFrame.
  Qed.

End proofmode_classes.