LogrelCC.examples.stack

From LogrelCC Require Import prelude.
From LogrelCC Require Import lang rules_unary cl_rules.
From iris.proofmode Require Import tactics.

Section stack.
  Context `{heapG Σ}.

  Definition create_stack :=
    Rec (Alloc (InjR Unit)).

  Definition create_stack_val :=
    RecV (Alloc (InjR Unit)).

  Lemma create_stack_to_val : to_val create_stack = Some create_stack_val.
  Proof. done. Qed.

  Lemma create_stack_closed : f, create_stack.[f] = create_stack.
  Proof. trivial. Qed.

  Definition stack_pop l :=
    Rec (Case (Load l)
              (App (Rec (InjL (Fst (Var 2))))
                   (Store l.[ren (+1)] (Load (Snd (Var 0)))))
              (InjR Unit)).

  Definition stack_pop_val l :=
    RecV (Case (Load l)
              (App (Rec (InjL (Fst (Var 2))))
                   (Store l.[ren (+1)] (Load (Snd (Var 0)))))
              (InjR Unit)).

  Lemma stack_pop_to_val l : to_val (stack_pop l) = Some (stack_pop_val l).
  Proof. done. Qed.

  Lemma stack_pop_subst f l :
    (stack_pop l).[f] = stack_pop l.[upn 2 f].
  Proof. by unfold stack_pop; asimpl. Qed.

  Lemma stack_pop_closed l :
     f, ( n, l.[upn n f] = l) (stack_pop l).[f] = (stack_pop l).
  Proof. intros f Hl. by rewrite stack_pop_subst Hl. Qed.

  Definition stack_push l :=
    Rec (Store l (InjL (Pair (Var 1) (Alloc (Load l))))).

  Definition stack_push_val l :=
    RecV (Store l (InjL (Pair (Var 1) (Alloc (Load l))))).

  Lemma stack_push_to_val l : to_val (stack_push l) = Some (stack_push_val l).
  Proof. done. Qed.

  Lemma stack_push_subst f l :
    (stack_push l).[f] = stack_push l.[upn 2 f].
  Proof. by unfold stack_push; asimpl. Qed.

  Lemma stack_push_closed l :
     f, ( n, l.[upn n f] = l) (stack_push l).[f] = (stack_push l).
  Proof. by intros f Hl; asimpl; rewrite !Hl. Qed.

  Fixpoint is_stack (s : list val) (l : loc) : iProp Σ :=
    match s with
    | [] => (l ↦ᵢ (InjRV UnitV))%I
    | x :: s' => ( l', l ↦ᵢ (InjLV (PairV x (LocV l'))) (is_stack s' l'))%I
    end.

  Lemma clwp_create_stack :
      (CLWP (App create_stack Unit) {{ v, l, v = LocV l is_stack [] l }})%I.
  Proof.
    iApply clwp_rec; eauto; simpl; iNext.
    iApply clwp_alloc; eauto; iNext.
    iIntros (l) "Hl". iApply clwp_value; eauto.
  Qed.

  Lemma clwp_stack_pop_empty l :
     is_stack [] l CLWP (App (stack_pop (Loc l)) Unit)
              {{ v, v = InjRV UnitV is_stack [] l }}.
  Proof.
    iIntros "Hs" => /=.
    iApply clwp_rec; eauto; asimpl; iNext.
    iApply (clwp_bind [CaseCtx _ _]).
    iApply clwp_load.
    iSplitR; last iFrame; iNext.
    iIntros "Hl"; iFrame.
    iApply clwp_value; eauto; simpl.
    iApply clwp_case_injr; eauto; iNext; simpl.
    iApply clwp_value; eauto.
  Qed.

  Lemma clwp_stack_pop_non_empty x s l :
     is_stack (x :: s) l CLWP (App (stack_pop (Loc l)) Unit)
              {{ v, v = InjLV x is_stack s l }}.
  Proof.
    iIntros "Hs"; simpl.
    iDestruct "Hs" as (l') "[Hl Hl']".
    iApply clwp_rec; eauto; asimpl; iNext.
    iApply (clwp_bind [CaseCtx _ _]).
    iApply clwp_load; iSplitR "Hl"; last (by iFrame); iNext; iIntros "Hl".
    iApply clwp_value; eauto. simpl.
    iApply clwp_case_injl; simpl; eauto; iNext; simpl.
    iApply (clwp_bind [LoadCtx; StoreRCtx (LocV _); AppRCtx (RecV _)]).
    iApply clwp_snd; eauto. iNext.
    iApply clwp_value; eauto; simpl.
    iApply (clwp_bind [StoreRCtx (LocV _); AppRCtx (RecV _)]).
    destruct s as [|y s]; simpl.
    - iApply clwp_load; iSplitR "Hl'"; last (by iFrame); iNext; iIntros "Hl'".
      iApply clwp_value; eauto.
      iApply (clwp_bind [AppRCtx (RecV _)]).
      iApply clwp_store; eauto;
        iSplitR "Hl"; last (by iFrame); iNext; iIntros "Hl".
      iApply clwp_value; eauto; simpl.
      iApply clwp_rec; eauto; iNext; asimpl.
      iApply (clwp_bind [InjLCtx]).
      iApply clwp_fst; eauto; iNext.
      iApply clwp_value; eauto; simpl.
      iApply clwp_value; eauto.
    - iDestruct "Hl'" as (l'') "[Hl' Hl'']".
      iApply clwp_load; iSplitR "Hl'"; last (by iFrame); iNext; iIntros "Hl'".
      iApply clwp_value; eauto.
      iApply (clwp_bind [AppRCtx (RecV _)]).
      iApply clwp_store; eauto using to_of_val;
        iSplitR "Hl"; last (by iFrame); iNext; iIntros "Hl".
      iApply clwp_value; eauto; simpl.
      iApply clwp_rec; eauto; iNext; asimpl.
      iApply (clwp_bind [InjLCtx]).
      iApply clwp_fst; eauto; iNext.
      iApply clwp_value; eauto; simpl.
      iApply clwp_value; eauto.
      iSplit; first done.
      iExists l''; simpl; iFrame.
  Qed.

  Lemma clwp_stack_push x s l :
     is_stack s l CLWP (App (stack_push (Loc l)) (of_val x))
              {{ v, v = UnitV is_stack (x :: s) l }}.
  Proof.
    iIntros "Hl"; simpl.
    iApply clwp_rec; eauto using to_of_val; asimpl; iNext.
    destruct s as [|y s]; simpl.
    - iApply (clwp_bind [AllocCtx; PairRCtx _; InjLCtx; StoreRCtx (LocV _)]).
      iApply clwp_load; iSplitR "Hl"; last (by iFrame); iNext; iIntros "Hl".
      iApply clwp_value; eauto using to_of_val; simpl.
      iApply (clwp_bind [PairRCtx _; InjLCtx; StoreRCtx (LocV _)]).
      iApply clwp_alloc; eauto; iNext.
      iIntros (l') "Hl'"; iApply clwp_value; eauto; simpl.
      iApply clwp_store; eauto; simpl;
        iFrame; iNext; iIntros "Hl".
      iApply clwp_value; eauto.
      iSplit; first done.
      iExists l'; iFrame.
    - iDestruct "Hl" as (l') "[Hl Hl']".
      iApply (clwp_bind [AllocCtx; PairRCtx _; InjLCtx; StoreRCtx (LocV _)]).
      iApply clwp_load; iSplitR "Hl"; last (by iFrame); iNext; iIntros "Hl".
      iApply clwp_value; eauto; simpl.
      iApply (clwp_bind [PairRCtx _; InjLCtx; StoreRCtx (LocV _)]).
      iApply clwp_alloc; eauto. iNext.
      iIntros (l'') "Hl''"; iApply clwp_value; eauto; simpl.
      iApply clwp_store; eauto; simpl;
        iFrame; iNext; iIntros "Hl".
      iApply clwp_value; eauto.
      iSplit; first done.
      iExists l''; iFrame.
      iExists l'; iFrame.
  Qed.

End stack.

Typeclasses Opaque create_stack.
Typeclasses Opaque stack_pop.
Typeclasses Opaque stack_push.
Global Opaque create_stack.
Global Opaque stack_pop.
Global Opaque stack_push.

Typeclasses Opaque create_stack_val.
Typeclasses Opaque stack_pop_val.
Typeclasses Opaque stack_push_val.
Global Opaque create_stack_val.
Global Opaque stack_pop_val.
Global Opaque stack_push_val.