LogrelCC.examples.refinement.oneshotCC.oneshotCC_progs

From iris.algebra Require Import auth gset.
From iris.program_logic Require Import adequacy.
From LogrelCC Require Import rules_unary rules_binary soundness_binary.
From iris.proofmode Require Import tactics.
From LogrelCC Require Import typing.

(* diverging term. Perhaps move elsewhere! *)
Definition OMEGA := App (Rec (App (Var 0) (Var 1))) Unit.

Section wp_OMEGA.
  Context `{heapG Σ}.

  Lemma wp_OMEGA E K : (WP fill K OMEGA @ E {{_, False}})%I.
  Proof. iLöb as "IH"; iApply wp_rec; eauto. Qed.

End wp_OMEGA.

Lemma OMEGA_closed : f, OMEGA.[f] = OMEGA.
Proof. by intros ?; asimpl. Qed.

Hint Rewrite OMEGA_closed : autosubst.

Typeclasses Opaque OMEGA.
Global Opaque OMEGA.

Section progs.
  Context `{heapG Σ, cfgSG Σ}.

  Definition call_cc := TLam (Lam (Callcc (App (Var 1) (Var 0)))).

  Definition call_cc_type :=
    TForall (TArrow (TArrow (TCont (TVar 0)) (TVar 0)) (TVar 0)).

  Lemma call_cc_typed : [] ⊢ₜ call_cc : call_cc_type.
  Proof. repeat econstructor. Qed.

  Definition call_cc1_ectx b eK : ectx :=
    [LetInCtx
       (If (Load b.[ren (+1)]) OMEGA
           (LetIn (Store b.[ren (+1)] (#♭ true))
                  (Throw (Var 1) eK.[ren (+2)])))].

  Lemma call_cc1_ectx_eq b eK :
    call_cc1_ectx b eK =
    [LetInCtx
       (If (Load b.[ren (+1)]) OMEGA
           (LetIn (Store b.[ren (+1)] (#♭ true))
                  (Throw (Var 1) eK.[ren (+2)])))].
  Proof. trivial. Qed.

  Lemma call_cc1_ectx_subst b eK :
     f, (Cont (call_cc1_ectx b eK)).[f] = Cont (call_cc1_ectx b.[f] eK.[f]).
  Proof. by intros f; unfold call_cc1_ectx; asimpl. Qed.

  Hint Rewrite call_cc1_ectx_subst : autosubst.

  Typeclasses Opaque call_cc1_ectx.
  Global Opaque call_cc1_ectx.

  Definition call_cc1 :=
    TLam
      (Lam (LetIn
              (Alloc (#♭ false))
              (Callcc
                 (App
                    (Var 2)
                    (Cont (call_cc1_ectx (Var 1) (Var 0))))
              )
           )
      ).

  Lemma call_cc1_eq :
    call_cc1 =
    TLam
      (Lam (LetIn
              (Alloc (#♭ false))
              (Callcc
                 (App
                    (Var 2)
                    (Cont (call_cc1_ectx (Var 1) (Var 0))))
              )
           )
      ).
  Proof. trivial. Qed.

  Lemma call_cc1_closed : f, call_cc1.[f] = call_cc1.
  Proof. by asimpl. Qed.
  Hint Rewrite call_cc1_closed : autosubst.

  Definition call_cc1_inner_body :=
    LetIn
      (Alloc (#♭ false))
      (Callcc
         (App
            (Var 2)
            (Cont (call_cc1_ectx (Var 1) (Var 0))))).

  Lemma call_cc1_inner_body_eq :
    call_cc1_inner_body =
    LetIn
      (Alloc (#♭ false))
      (Callcc
         (App
            (Var 2)
            (Cont (call_cc1_ectx (Var 1) (Var 0))))).
  Proof. trivial. Qed.

  Typeclasses Opaque call_cc1_inner_body.
  Global Opaque call_cc1_inner_body.

  Lemma step_call_cc_1 f K E ρ j:
    nclose specN E
    spec_ctx ρ j fill K (App (TApp call_cc1) (of_val f))
    ={E}=∗
         b, b ↦ₛ (#♭v false)
               j fill K (App (of_val f)
                               (Cont (call_cc1_ectx (Loc b) (Cont K)))).
  Proof.
    iIntros (HE) "[#Hcfg Hj]".
    iMod (step_tlam _ _ _ (AppLCtx _ :: K) with "[Hj]") as "Hj"; eauto; simpl.
    rewrite call_cc1_ectx_eq.
    iMod (step_Lam with "[Hj]") as "Hj"; eauto using to_of_val.
    asimpl.
    iMod (step_alloc _ _ _ ((LetInCtx _) :: K) with "[Hj]") as (b) "[Hj Hb]";
      eauto; simpl; eauto.
    iMod (step_LetIn _ _ _ _ _ _ (LocV _) with "[Hj]") as "Hj";
      eauto using to_of_val.
    asimpl.
    iMod (step_callcc with "[Hj]") as "Hj"; eauto.
    asimpl.
    iModIntro. iExists b; rewrite call_cc1_ectx_eq; iFrame.
  Qed.

  Typeclasses Opaque call_cc1.
  Global Opaque call_cc1.

  Definition G r :=
    Rec (LetIn
           (App (TApp call_cc1)
                (Lam (LetIn
                        (Store r.[ren (+3)] (Var 0))
                        (App (Var 3) (Cont [ThrowLCtx (Load r.[ren (+4)])])))))
           (App
              (TApp call_cc1)
              (Lam (App (Var 2) (Lam (Throw (Var 2) (Var 1))))))
      ).

  Lemma G_eq r :
    G r =
    Rec (LetIn
           (App (TApp call_cc1)
                (Lam (LetIn
                        (Store r.[ren (+3)] (Var 0))
                        (App (Var 3) (Cont [ThrowLCtx (Load r.[ren (+4)])])))))
           (App
              (TApp call_cc1)
              (Lam (App (Var 2) (Lam (Throw (Var 2) (Var 1))))))
      ).
  Proof. trivial. Qed.

  Lemma G_subst r : f, (G r).[f] = G r.[f].
  Proof. by intros f; rewrite /G; asimpl. Qed.

  Hint Rewrite G_subst : autosubst.

  Typeclasses Opaque G.
  Global Opaque G.

  Lemma step_G l f K E ρ j :
    nclose specN E
    spec_ctx ρ j fill K (App (G (Loc l)) (of_val f))
    ={E}=∗
        j fill K
        (LetIn
             (App (TApp call_cc1)
                (Lam (LetIn
                        (Store (Loc l) (Var 0))
                        (App
                           (of_val f).[ren (+2)]
                           (Cont [ThrowLCtx (Load (Loc l))])))))
             (App
                (TApp call_cc1)
                (Lam (App (G (Loc l)) (Lam (Throw (ids 2) (ids 1))))))).
  Proof.
    iIntros (HE) "[#Hcfg Hj]".
    rewrite {1}G_eq.
    iMod (step_rec with "[Hj]"); eauto using to_of_val.
    rewrite -G_eq. by asimpl.
  Qed.

  Definition call_cc' :=
    TLam (Rec (App (Rec (App (G (Var 1)) (Var 3))) (Alloc (Cont [])))).

  Lemma call_cc'_closed : f, call_cc'.[f] = call_cc'.
  Proof. by intros ?; asimpl. Qed.

  Hint Rewrite call_cc'_closed : autosubst.

End progs.

Hint Rewrite call_cc1_ectx_subst : autosubst.
Hint Rewrite call_cc1_closed : autosubst.
Hint Rewrite G_subst : autosubst.
Hint Rewrite call_cc'_closed : autosubst.