(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext ssrnat_ext seq_ext machine_int multi_int uniq_tac.
Import MachineInt.
Require Import mips_seplog mips_frame mips_contrib mips_tactics mapstos.
Require Import mont_mul_strict_prg multi_zero_u_prg multi_zero_u_triple.
Require Import mont_square_strict_triple.
Import expr_m.
Import assert_m.

Local Open Scope machine_int_scope.
Local Open Scope eqmod_scope.
Local Open Scope heap_scope.
Local Open Scope uniq_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope multi_int_scope.
Local Open Scope zarith_ext_scope.

Section mont_square_strict_init.

Variables k alpha x z m one ext int_ X_ Y_ M_ Z_ quot C t s_ : reg.

Lemma mont_square_strict_init_triple :
  uniq(k, alpha, x, z, m, one, ext, int_, X_, Y_, M_, Z_, quot, C, t, s_, r0) ->
  forall nk valpha vx vm vz X M,
  u2Z (M `32_ 0) * u2Z valpha =m -1 {{ \B^1 }} ->
  size X = nk -> size M = nk ->
  u2Z vz + 4 * Z_of_nat nk.+1 < \B^1 ->
  \S_{ nk } X < \S_{ nk } M ->
  {{ fun s h => exists Z, size Z = nk /\
    [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
    (var_e x |--> X ** var_e z |--> Z ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h }}
  mont_mul_strict_init k alpha x x z m one ext int_ X_ Y_ M_ Z_ quot C t s_
  {{fun s h => exists Z, size Z = nk /\
    [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
    u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
    (var_e x |--> X ** var_e z |--> Z ++ zero32::nil ** var_e m |--> M ++ zero32::nil) s h /\
    \B^nk * \S_{ nk } Z =m \S_{ nk } X * \S_{ nk } X {{ \S_{ nk } M }} /\ \S_{ nk } Z < \S_{ nk } M }}.
Proof.
move=> Hset nk valpha vx vm vz X M Halpha HlenX HlenM Hnz HXM.
rewrite /mont_mul_strict_init.

(**  multi_zero ext k Z_ z ; *)

apply pull_out_exists => Z.

apply (hoare_prop_m.hoare_stren (!(fun s => size Z = nk) **
  (fun s h => [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
    u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
    ((var_e x |--> X ** var_e z |--> Z ++ zero32 :: nil) ** var_e m |--> M ++ zero32 :: nil) s h))).

move=> s h [HlenZ [Hrx [Hrz [Hrm_ [Hrk [Hralpha Hmem]]]]]].
exists heap.emp, h; repeat (split => //).
by map_tac_m.Disj.
by map_tac_m.Equal.
by rewrite conAE.

apply pull_out_bang => HlenZ.

apply (hoare_prop_m.hoare_stren
  ((fun s h => [z]_s = vz /\ u2Z [k]_s = Z_of_nat nk /\ (var_e z |--> Z) s h) **
    (fun s h => [x]_s = vx /\ [m]_s = vm /\ [alpha]_s = valpha /\
      (var_e x |--> X ** var_e z \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32 **
        var_e m |--> M ++ zero32 :: nil) s h))).

move=> s h [Hrx [Hrz [Hrm_ [Hrk [Hralpha Hmem]]]]].

rewrite decompose_last_equiv HlenZ !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
case: Hmem => h1 [h2 [Hdisj [Hunion [Hmem1 Hmem2]]]].
exists h1, h2; repeat (split; trivial).
by assoc_comm Hmem2.

apply while.hoare_seq with (
  (fun s h => [z]_s = vz /\ u2Z [k]_s = Z_of_nat nk /\ (var_e z |--> nseq nk zero32) s h) **
  (fun s h => [x]_s = vx /\ [m]_s = vm /\ [alpha]_s = valpha /\
    (var_e x |--> X ** var_e z \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32 **
      var_e m |--> M ++ zero32 :: nil) s h)).

apply frame_rule_R.
- eapply multi_zero_u_triple; eauto.
  + by Uniq_uniq r0.
  + rewrite Z_S in Hnz; lia.
- by Inde_frame.
- move=> ?; by Inde_mult.

apply while.hoare_seq with (fun s h => [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> nseq nk zero32 ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  store.multi_null s).

(**  (mflhxu r0 ; *)

apply hoare_mflhxu with (fun s h =>[x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> nseq nk zero32 ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  store.acx s = Z2u store.acx_size 0).

move=> s h [h1 [h2 [Hdisj [Hunion [[Hrz [Hrk Hmem1]] [Hrx [Hrm_ [Hralpha Hmem2]]]]]]]].
rewrite /wp_mflhxu.
repeat Reg_upd; repeat (split; trivial).
move: {Hmem1 Hmem2}(assert_m.con_cons _ _ _ _ _ Hdisj Hmem1 Hmem2) => Hmem.
rewrite Hunion decompose_last_equiv size_nseq store.upd_r0.
Assert_upd; by assoc_comm Hmem.

by apply store.acx_mflhxu_op.

(**  mthi r0 ; *)

apply hoare_mthi with (fun s h => [x]_s = vx /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e z |--> nseq nk zero32 ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  store.acx s = Z2u store.acx_size 0 /\ store.hi s = zero32).

move=> {Z HlenZ} s h [Hrx [Hrz [Hrm_ [Hrk [Hralpha [Hmem Hacx]]]]]].
rewrite /wp_mthi.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.acx_mthi_op.
by rewrite store.hi_mthi_op.

(**  mtlo r0) ; *)

apply hoare_mtlo'.

move=> {Z HlenZ} s h [Hrx [Hrz [Hrm_ [Hrk [Hralpha [Hmem [Hacx Hhi]]]]]]].
rewrite /wp_mtlo.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
apply store.utoZ_multi_null.
by rewrite store.utoZ_def store.hi_mtlo_op store.acx_mtlo_op store.lo_mtlo_op Hacx Hhi /zero32 !Z2uK.

(**  mont_mul_strict k alpha x y z m_ one ext int_ X_ Y_ M_ Z_ quot C t s_. *)

by eapply mont_square_strict_verif; eauto.
Qed.

End mont_square_strict_init.


Require Import PArith Setoid.
From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising2 Require Import Time.

From imm Require Import Events Execution.
From imm Require Import imm_s_hb.
From imm Require Import imm_s.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section FtoCoherent.
Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.
Variable IMMCON : imm_consistent G sc.
Variable I : actid -> Prop.

Notation "'acts'" := G.(acts).
Notation "'co'" := G.(co).
Notation "'coi'" := G.(coi).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'rfe'" := G.(rfe).
Notation "'rmw'" := G.(rmw).
Notation "'lab'" := G.(lab).

Notation "'E'" := G.(acts_set).
Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1). (* , format "'Loc_'  l"). *)
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_'" := (fun l => W ∩₁ Loc_ l).
(* Notation "'RW'" := (fun x => R x \/ W x). *)
Notation "'FR'" := (fun x => F x \/ R x).
Notation "'FW'" := (fun x => F x \/ W x).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (is_rlx lab).
Notation "'Rel'" := (is_rel lab).
Notation "'Acq'" := (is_acq lab).
Notation "'Acqrel'" := (is_acqrel lab).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Notation "'W_ex'" := G.(W_ex).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Variable IE : I ⊆₁ E ∩₁ W.
Variable INITINI: is_init ∩₁ E ⊆₁ I. Variables f_to f_from : actid -> Time.t.

Definition f_to_coherent :=
  (* ⟪ NW  : forall a, ~ is_w lab a -> f_to a = tid_init ⟫ /\ *)
  ⟪ TINITTO : forall x, (is_init ∩₁ E) x -> f_to x = tid_init ⟫ /\
  ⟪ TINITFROM : forall x, (is_init ∩₁ E) x -> f_from x = tid_init ⟫ /\
  ⟪ TTOFROM : forall x,
      I x -> ~ is_init x -> Time.lt (f_from x) (f_to x) ⟫ /\
  ⟪ TCO : forall x y,
      I x -> I y ->
      co x y -> Time.le (f_to x) (f_from y) ⟫ /\
  ⟪ TRMW : forall x y,
      I x -> I y -> (rf ⨾ rmw) x y -> f_to x = f_from y ⟫
.

Section Props.

Variable FCOH : f_to_coherent.

Lemma f_to_co_mon e e' (CO : co e e') (ISS : I e) (ISS' : I e') :
  Time.lt (f_to e) (f_to e').
Proof using WF IMMCON FCOH.
  eapply TimeFacts.le_lt_lt.
  2: eapply FCOH; auto.
  { by apply FCOH. }
  apply Execution_eco.no_co_to_init in CO; auto.
  { apply seq_eqv_r in CO. desf. }
  apply coherence_sc_per_loc.
  apply IMMCON.
Qed.

Lemma f_from_co_mon e e' (NINIT : ~ is_init e) (CO : co e e') (ISS : I e) (ISS' : I e') :
  Time.lt (f_from e) (f_from e').
Proof using FCOH.
  eapply TimeFacts.lt_le_lt.
  { eapply FCOH; eauto. }
    by apply FCOH.
Qed.

Lemma f_to_coherent_strict x y z (ISSX : I x) (ISSY : I y) (ISSZ : I z)
      (COXY: co x y) (COYZ: co y z) :
  Time.lt (f_to x) (f_from z).
Proof using WF IMMCON FCOH.
  eapply TimeFacts.le_lt_lt.
  { apply FCOH.
    3: by apply COXY.
    all: eauto. }
  eapply f_from_co_mon; eauto.
  apply Execution_eco.no_co_to_init in COXY; auto.
  { apply seq_eqv_r in COXY. desf. }
  apply coherence_sc_per_loc.
  apply IMMCON.
Qed.

Lemma lt_init_ts e (EE : E e) (WW : W e) (ISS : I e) (NINIT : ~ is_init e) :
  Time.lt tid_init (f_to e).
Proof using WF IMMCON IE INITINI FCOH.
  unfold is_w in *.
  destruct e; desf.
  cdes FCOH.
  assert (E (InitEvent l)) as EL.
  { apply WF.(wf_init). eexists.
    split; eauto. unfold loc. desf. }
  assert ((is_init ∩₁ E) (InitEvent l)) as LL.
  { by split; eauto. }
  erewrite <- TINITTO; eauto.
  eapply f_to_co_mon; eauto.
  eapply init_co_w; eauto.
  { unfold is_w. desf. }
  red. unfold loc. rewrite WF.(wf_init_lab).
  desf.
Qed.

Lemma le_init_ts e (EE : E e) (WW : W e) (ISS : I e) :
  Time.le tid_init (f_to e).
Proof using WF IMMCON IE INITINI FCOH.
  unfold is_w in *.
  destruct e; desf.
  { apply Time.le_lteq. right.
    symmetry. cdes FCOH. apply TINITTO.
    split; auto. }
  apply Time.le_lteq. left.
  eapply lt_init_ts; eauto.
  unfold is_w. desf.
Qed.

Lemma le_init_ts_from e (EE : E e) (WW : W e) (ISS : I e) (NINIT : ~ is_init e) :
  Time.le tid_init (f_from e).
Proof using WF IMMCON IE INITINI FCOH.
  unfold is_w in *.
  destruct e; desf.
  cdes FCOH.
  assert (E (InitEvent l)) as EL.
  { apply WF.(wf_init). eexists.
    split; eauto. unfold loc. desf. }
  assert ((is_init ∩₁ E) (InitEvent l)) as LL.
  { by split; eauto. }
  erewrite <- TINITTO; eauto.
  apply FCOH; eauto.
  eapply init_co_w; eauto.
  { unfold is_w. desf. }
  red. unfold loc. rewrite WF.(wf_init_lab).
  desf.
Qed.

Lemma f_to_eq e e' (SAME_LOC : same_loc lab e e') (ISS : I e) (ISS' : I e')
      (FEQ : f_to e = f_to e') :
  e = e'.
Proof using WF IMMCON IE FCOH.
  assert (E e /\ E e') as [EE EE'].
  { by split; apply IE. }
  assert (W e /\ W e') as [WE WE'].
  { by split; apply IE. }
  destruct (classic (e = e')) as [|NEQ]; auto.
  exfalso.
  edestruct (wf_co_total WF); eauto.
  1,2: split; [split|]; eauto.
  { assert (Time.lt (f_to e) (f_to e')) as HH.
    { eapply f_to_co_mon; eauto. }
    rewrite FEQ in *.
      by apply DenseOrder.lt_strorder in HH. }
  assert (Time.lt (f_to e') (f_to e)) as HH.
  { eapply f_to_co_mon; eauto. }
  rewrite FEQ in *.
    by apply DenseOrder.lt_strorder in HH.
Qed.

Lemma f_from_eq e e' (SAME_LOC : same_loc lab e e') (ISS : I e) (ISS' : I e')
      (NINIT : ~ is_init e) (NINIT' : ~ is_init e')
      (FEQ : f_from e = f_from e') :
  e = e'.
Proof using WF IMMCON IE FCOH.
  assert (E e /\ E e') as [EE EE'].
  { by split; apply IE. }
  assert (W e /\ W e') as [WE WE'].
  { by split; apply IE. }
  destruct (classic (e = e')) as [|NEQ]; auto.
  exfalso.
  edestruct (wf_co_total WF); eauto.
  1,2: split; [split|]; eauto.
  { assert (Time.lt (f_from e) (f_from e')) as HH.
    { eapply f_from_co_mon; eauto. }
    rewrite FEQ in *.
      by apply DenseOrder.lt_strorder in HH. }
  assert (Time.lt (f_from e') (f_from e)) as HH.
  { eapply f_from_co_mon; eauto. }
  rewrite FEQ in *.
    by apply DenseOrder.lt_strorder in HH.
Qed.

Lemma co_S_f_to_le w w'
      (SW  : I w)
      (SW' : I w')
      (CO  : co^? w w') :
  Time.le (f_to w) (f_to w').
Proof using WF IMMCON FCOH.
  destruct CO as [|CO]; [subst; reflexivity|].
  apply Time.le_lteq; left.
  eapply f_to_co_mon; eauto.
Qed.

Lemma co_S_f_from_le w w'
      (NINIT : ~ is_init w)
      (SW  : I w)
      (SW' : I w')
      (CO  : co^? w w') :
  Time.le (f_from w) (f_from w').
Proof using WF FCOH.
  destruct CO as [|CO]; [subst; reflexivity|].
  apply Time.le_lteq; left.
  eapply f_from_co_mon; eauto.
Qed.

Lemma to_from_disjoint_to w w'
      (NEQ : w <> w')
      (NINIT : ~ is_init w)
      (SW  : I w)
      (SW' : I w')
      (SL  : same_loc lab w w') :
  Time.le (f_to w') (f_from w) \/ Time.lt (f_to w) (f_to w').
Proof using WF IMMCON IE FCOH.
  edestruct is_w_loc as [l LL].
  { apply IE. apply SW. }
  edestruct WF.(wf_co_total) with (a:=w) (b:=w'); eauto.
  1,2: split; [by apply IE|]; eauto.
  { by rewrite <- SL. }
  { right. by apply f_to_co_mon. }
  left. by apply FCOH.
Qed.

Lemma to_from_disjoint_from w w'
      (NEQ : w <> w')
      (NINIT : ~ is_init w')
      (SW  : I w)
      (SW' : I w')
      (SL  : same_loc lab w w') :
  Time.lt (f_from w') (f_from w) \/ Time.le (f_to w) (f_from w').
Proof using WF IMMCON IE FCOH.
  edestruct is_w_loc as [l LL].
  { apply IE. apply SW. }
  edestruct WF.(wf_co_total) with (a:=w) (b:=w'); eauto.
  1,2: split; [by apply IE|]; eauto.
  { by rewrite <- SL. }
  { right. by apply FCOH. }
  left. apply f_from_co_mon; auto.
Qed.

End Props.

End FtoCoherent.

Add Parametric Morphism : f_to_coherent with signature
  eq ==> set_equiv ==> eq ==> eq ==> iff as f_to_coherent_more.
Proof using.
  ins. split; intros HH.
  all: red; splits; ins; try apply HH; auto; by apply H.
Qed.

Lemma f_to_coherent_mori G S S' f_to f_from
      (IN : S' ⊆₁ S)
      (FCOH : f_to_coherent G S f_to f_from) :
  f_to_coherent G S' f_to f_from.
Proof using.
  cdes FCOH.
  red. splits; auto.
Qed.


Require Import floyd.proofauto.
Require Import progs.odd.
Require Import progs.verif_evenodd_spec.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.

Definition Gprog : funspecs :=
     ltac:(with_library prog [odd_spec; even_spec]).

Lemma body_odd : semax_body Vprog Gprog f_odd odd_spec.
Proof.
start_function.
change even._n with _n.
forward_if (PROP (z > 0) LOCAL (temp _n (Vint (Int.repr z))) SEP ()).
*
 forward.
*
 forward. entailer!.
*
  normalize.
  forward_call (z-1).
  omega.
  forward.
  entailer!.
  rewrite Z.even_sub; simpl.
  case_eq (Z.odd z); rewrite Zodd_even_bool;
   destruct (Z.even z); simpl; try (intros; congruence).
Qed.
Locate augment_funspecs'.

(* The Espec for odd is different from the Espec for even;
  the former has only "even" as an external function, and vice versa. *)
Definition Espec := add_funspecs NullExtension.Espec (ext_link_prog odd.prog) Gprog.
Existing Instance Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
(*unfold Gprog at 2, prog, prog_funct; simpl. *)
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons body_odd.
Qed.


Require Import Thread0.

Module Make(M : S).
Import M.

Module T := Thread0.Make(M).
Import T.

Definition handlerS := SPEC reserving 49
  Al fs, PREmain[_] sched fs * mallocHeap 0.

Definition mainS := SPEC reserving 49
  PREmain[_] globalSched =?> 1 * mallocHeap 0.

Definition m := bimport [[ "scheduler"!"init" @ [initS], "scheduler"!"exit" @ [exitS],
                           "scheduler"!"spawn" @ [spawnS] ]]
  bmodule "test" {{
    bfunctionNoRet "handler"("xx", "yy") [handlerS]
      Exit 50
    end with bfunctionNoRet "main"("xx", "yy") [mainS]
      Init
      [Al fs, PREmain[_] sched fs * mallocHeap 0];;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * mallocHeap 0];;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * mallocHeap 0];;

      Exit 50
    end
  }}.

Theorem ok : moduleOk m.
  vcgen; abstract (sep_auto; auto).
Qed.

End Make.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.SpecLemmas.

Require Import VerdiRaft.NoAppendEntriesToSelfInterface.

Section NoAppendEntriesToSelf.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Lemma doLeader_no_messages_to_self :
    forall st h os st' ms m,
      doLeader st h = (os, st', ms) ->
      In m ms ->
      fst m <> h.
  Proof using.
    intros.
    unfold doLeader in *.
    repeat break_match; try solve [find_inversion; simpl in *; congruence].
    find_inversion.
    do_in_map.
    subst. simpl in *.
    find_apply_lem_hyp filter_In.
    intuition. subst.
    break_match; congruence.
  Qed.

  Lemma no_append_entries_to_self_do_leader :
    raft_net_invariant_do_leader no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
    do_in_map.
    subst. simpl in *.
    find_eapply_lem_hyp doLeader_no_messages_to_self; eauto.
  Qed.

  Lemma no_append_entries_to_self_do_generic_server :
    raft_net_invariant_do_generic_server no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
    do_in_map.
    subst. simpl in *.
    find_eapply_lem_hyp doGenericServer_packets. subst. simpl in *. intuition.
  Qed.

  Lemma no_append_entries_to_self_append_entries :
    raft_net_invariant_append_entries no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
    subst. simpl in *. subst.
    find_apply_lem_hyp handleAppendEntries_not_append_entries.
    intuition. find_false. repeat eexists; eauto.
  Qed.

  Lemma no_append_entries_to_self_append_entries_reply :
    raft_net_invariant_append_entries_reply no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
    do_in_map. subst. simpl in *.
    find_apply_lem_hyp handleAppendEntriesReply_packets.
    subst. intuition.
  Qed.

  Lemma no_append_entries_to_self_request_vote :
    raft_net_invariant_request_vote no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
    subst. simpl in *. subst.
    find_apply_lem_hyp handleRequestVote_no_append_entries.
    intuition. find_false. repeat eexists; eauto.
  Qed.

  Lemma no_append_entries_to_self_request_vote_reply :
    raft_net_invariant_request_vote_reply no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
  Qed.

  Lemma no_append_entries_to_self_client_request :
    raft_net_invariant_client_request no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
    do_in_map. subst. simpl in *.
    find_eapply_lem_hyp handleClientRequest_no_append_entries; eauto.
    intuition. find_false. repeat eexists; eauto.
  Qed.

  Lemma no_append_entries_to_self_timeout :
    raft_net_invariant_timeout no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
    do_in_map. subst. simpl in *.
    find_eapply_lem_hyp handleTimeout_not_is_append_entries; eauto.
    intuition. find_false. repeat eexists; eauto.
  Qed.

  Lemma no_append_entries_to_self_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
  Qed.

  Lemma no_append_entries_to_self_reboot :
    raft_net_invariant_reboot no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *.
    find_reverse_rewrite. intuition eauto.
  Qed.

  Lemma no_append_entries_to_self_init :
    raft_net_invariant_init no_append_entries_to_self.
  Proof using.
    red. red. intros. simpl in *. intuition.
  Qed.

  Theorem no_append_entries_to_self_invariant :
    forall net,
      raft_intermediate_reachable net ->
      no_append_entries_to_self net.
  Proof using.
    intros.
    apply raft_net_invariant; auto.
    - apply no_append_entries_to_self_init.
    - apply no_append_entries_to_self_client_request.
    - apply no_append_entries_to_self_timeout.
    - apply no_append_entries_to_self_append_entries.
    - apply no_append_entries_to_self_append_entries_reply.
    - apply no_append_entries_to_self_request_vote.
    - apply no_append_entries_to_self_request_vote_reply.
    - apply no_append_entries_to_self_do_leader.
    - apply no_append_entries_to_self_do_generic_server.
    - apply no_append_entries_to_self_state_same_packet_subset.
    - apply no_append_entries_to_self_reboot.
  Qed.

  Instance noaetsi : no_append_entries_to_self_interface.
  split. exact no_append_entries_to_self_invariant.
  Qed.

End NoAppendEntriesToSelf.


From Coq Require Import List.

From compcert Require Import common.Errors.
From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import Clocks.

From Velus Require Import Lustre.LSyntax.
From Velus Require Import Lustre.LCausality.
From Velus Require Import Lustre.Normalization.Normalization.

From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import Transcription.Tr.

Module Type COMPLETENESS
       (Import Ids : IDS)
       (Import Op : OPERATORS)
       (Import OpAux : OPERATORS_AUX Op)
       (Import LSyn : LSYNTAX Ids Op)
       (Import LCau : LCAUSALITY Ids Op LSyn)
       (Import Norm : NORMALIZATION Ids Op OpAux LSyn LCau)
       (Import CE : CESYNTAX Op)
       (NL : NLSYNTAX Ids Op CE)
       (Import TR : TR Ids Op OpAux LSyn CE NL).

  Fact to_constant_complete : forall c,
    normalized_constant c ->
    exists e', to_constant c = OK e'.
  Proof with eauto.
    intros c Hnorm. induction Hnorm.
    - eexists; simpl...
    - destruct IHHnorm as [e' He'].
      eexists; simpl...
  Qed.

  Fact to_lexp_complete : forall e,
    normalized_lexp e ->
    exists e', to_lexp e = OK e'.
  Proof with eauto.
    intros e Hnorm.
    induction e using exp_ind2; inv Hnorm.
    - (* const *) eexists; simpl...
    - (* var *) eexists; simpl...
    - (* unop *)
      apply IHe in H0 as [e' He'].
      eexists; simpl.
      rewrite He'; simpl...
    - (* binop *)
      apply IHe1 in H1 as [e1' He1].
      apply IHe2 in H4 as [e2' He2].
      eexists; simpl.
      rewrite He1. rewrite He2. simpl...
    - (* when *)
      inv H. apply H3 in H1 as [e' He'].
      eexists; simpl.
      rewrite He'. simpl...
  Qed.

  Corollary mmap_to_lexp_complete : forall es,
      Forall normalized_lexp es ->
      exists es', mmap to_lexp es = OK es'.
  Proof with eauto.
    intros es Hf.
    induction Hf.
    - eexists; simpl...
    - apply to_lexp_complete in H as [e' He'].
      destruct IHHf as [es' Hes'].
      eexists; simpl.
      rewrite He'; rewrite Hes'. simpl...
  Qed.

  Fact to_cexp_complete : forall e,
      normalized_cexp e ->
      exists e', to_cexp e = OK e'.
  Proof with eauto.
    intros e Hnorm.
    induction e using exp_ind2; inv Hnorm;
      try (eapply to_lexp_complete in H as [e' He'];
           exists (Eexp e'); unfold to_cexp; rewrite He'; simpl; eauto);
      try (solve [inv H1]).
    - (* when *)
      eapply to_lexp_complete in H0 as [e' He'].
      exists (Eexp e'). unfold to_cexp. rewrite He'; simpl...
    - (* merge *)
      inv H. inv H0.
      apply H4 in H3 as [et' Het'].
      apply H2 in H6 as [ef' Hef'].
      eexists. simpl.
      rewrite Het'. rewrite Hef'. simpl...
    - (* ite *)
      inv H. inv H0.
      apply to_lexp_complete in H4 as [e' He'].
      apply H3 in H6 as [et' Het'].
      apply H2 in H7 as [ef' Hef'].
      eexists; simpl.
      rewrite He'. rewrite Het'. rewrite Hef'. simpl...
  Qed.

  Fact to_equation_complete : forall G xs es out env envo,
      normalized_equation G out (xs, es) ->
      Forall (fun x => exists cl, find_clock env x = OK cl) xs ->
      (forall x e, envo x = Error e -> PS.In x out) ->
      exists eq', to_equation env envo (xs, es) = OK eq'.
  Proof with eauto.
    intros * Hnorm Hfind Henvo.
    inv Hnorm.
    - apply mmap_to_lexp_complete in H1 as [es' Hes'].
      eexists; simpl. rewrite Hes'; simpl...
    - apply mmap_to_lexp_complete in H1 as [es' Hes'].
      destruct cl.
      eexists; simpl. rewrite Hes'. simpl...
    - apply to_constant_complete in H3 as [e0' He0'].
      apply to_lexp_complete in H4 as [e' He'].
      inv Hfind. destruct H2 as [cl Hcl].
      eexists; simpl.
      rewrite He0'. rewrite He'. rewrite Hcl.
      simpl.
      specialize (Henvo x).
      destruct (envo x); simpl...
      exfalso...
    - specialize (to_cexp_complete _ H1) as [e' He'].
      inv Hfind. destruct H2 as [cl Hcl].
      eexists; simpl.
      destruct e; try (rewrite Hcl; rewrite He'; simpl; eauto).
      inv He'.
      inv He'.
  Qed.

  Corollary mmap_to_equation_complete : forall G eqs out env envo,
      Forall (normalized_equation G out) eqs ->
      Forall (fun x => exists cl, find_clock env x = OK cl) (vars_defined eqs) ->
      (forall x e, envo x = Error e -> PS.In x out) ->
      exists eqs', mmap (to_equation env envo) eqs = OK eqs'.
  Proof.
    induction eqs; intros * Hnorm Hfind Henvo; simpl.
    - eexists; eauto.
    - inv Hnorm. destruct a.
      simpl in Hfind. rewrite Forall_app in Hfind. destruct Hfind as [Hfind1 Hfind2].
      specialize (to_equation_complete _ _ _ _ _ _ H1 Hfind1 Henvo) as [eq' Heq'].
      eapply IHeqs in H2; eauto. destruct H2 as [eqs' Heqs'].
      rewrite Heqs'; rewrite Heq'; eexists; simpl; eauto.
  Qed.

  Corollary mmap_to_equation_complete' : forall G n out env envo,
      Forall (normalized_equation G out) (n_eqs n) ->
      Forall (fun x => exists cl, find_clock env x = OK cl) (vars_defined (n_eqs n)) ->
      (forall x e, envo x = Error e -> PS.In x out) ->
      exists eqs', mmap_to_equation env envo n = OK eqs'.
  Proof.
    intros * Hnorm Hfind Henvo.
    eapply mmap_to_equation_complete in Hnorm; eauto.
    destruct Hnorm as [eqs' Heqs'].
    exists (exist (fun neqs : list NL.equation => _) eqs' Heqs').
    unfold mmap_to_equation. rewrite Heqs'. reflexivity.
  Qed.

  Lemma to_node_complete : forall G n Hpref,
      normalized_node G n ->
      exists n', to_node n Hpref = OK n'.
  Proof.
    intros * Hnorm.
    unfold to_node.
    edestruct mmap_to_equation_complete' as [[? ?] H].
    4: (rewrite H; eauto).
    - unfold normalized_node in Hnorm. eassumption.
    - specialize (n_defd n) as Hperm.
      rewrite Forall_forall. intros x Hin.
      eapply Permutation.Permutation_in in Hperm; eauto. clear Hin.
      rewrite in_map_iff in Hperm; destruct Hperm as [[? [? ?]] [? Hin]]; simpl in H; subst.
      erewrite envs_eq_find with (ck:=c); simpl; eauto.
      + apply envs_eq_node.
      + rewrite In_idck_exists.
        exists t. repeat rewrite in_app_iff in *.
        destruct Hin; auto.
    - intros x e Hmem; simpl in Hmem.
      rewrite ps_from_list_In.
      rewrite <- fst_InMembers. rewrite <- Env.In_from_list.
      apply Env.mem_2.
      destruct (Env.mem x (Env.from_list (n_out n))); congruence.
  Qed.

  Lemma to_global_complete : forall G Hprefs,
      normalized_global G ->
      exists G', to_global G Hprefs = OK G'.
  Proof.
    induction G; intros * Hnormed; inv Hnormed.
    - exists nil. reflexivity.
    - unfold to_global; simpl.
      eapply to_node_complete in H1 as (hd'&Hton). erewrite Hton; clear Hton; simpl.
      eapply IHG in H2 as (tl'&HtoG). erewrite HtoG; clear HtoG; simpl.
      eauto.
  Qed.

  Theorem normalize_global_complete : forall G G' Hwl Hprefs Hprefs',
      normalize_global G Hwl Hprefs = OK G' ->
      exists G'', to_global G' Hprefs' = OK G''.
  Proof.
    intros * Hnorm.
    eapply to_global_complete.
    eapply normalize_global_normalized_global; eauto.
  Qed.
End COMPLETENESS.

Module CompletenessFun
       (Ids : IDS)
       (Op : OPERATORS)
       (OpAux : OPERATORS_AUX Op)
       (LSyn : LSYNTAX Ids Op)
       (LCau : LCAUSALITY Ids Op LSyn)
       (Norm : NORMALIZATION Ids Op OpAux LSyn LCau)
       (CE : CESYNTAX Op)
       (NL : NLSYNTAX Ids Op CE)
       (TR : TR Ids Op OpAux LSyn CE NL)
       <: COMPLETENESS Ids Op OpAux LSyn LCau Norm CE NL TR.
  Include COMPLETENESS Ids Op OpAux LSyn LCau Norm CE NL TR.
End CompletenessFun.


From RecordUpdate Require Import RecordSet.

From Perennial.Helpers Require Import CountableTactics Transitions.
From Perennial.goose_lang Require Import lang lifting slice typing spec_assert.
From Perennial.goose_lang Require ffi.disk.
From Perennial.algebra Require Import gen_heap_names.

From iris.algebra Require Import auth agree excl csum.
From Perennial.base_logic Require Import ghost_var.

Set Default Proof Using "Type".

(* TODO: move this out, it's completely general *)
(* Generalize life cycle of object state *)
Section recoverable.
  Context {Σ:Type}.
  Inductive RecoverableState :=
    | UnInit
    | Initing
    | Closed (s:Σ)
    | Opening (s:Σ)
    | Opened (s:Σ) (l:loc)
  .

  Definition recoverable_model : ffi_model :=
    mkFfiModel (RecoverableState) () (populate UnInit) _.

  Local Existing Instance recoverable_model.

  Context {ext:ffi_syntax}.

  Definition openΣ : transition (state*global_state) (Σ*loc) :=
    bind (reads id) (λ '(rs,g), match rs.(world) with
                           | Opened s l => ret (s,l)
                           | _ => undefined
                           end).

  Definition modifyΣ (f:Σ -> Σ) : transition (state*global_state) unit :=
    bind openΣ (λ '(s, l), modify (λ '(σ,g), (set world (λ _, Opened (f s) l) σ, g))).

  (* TODO: generalize to a transition to construct the initial value, using a zoom *)
  Definition initTo (init:Σ) (l:loc) : transition (state*global_state) unit :=
    bind (reads id) (λ '(rs,g), match rs.(world) with
                           | UnInit => modify (λ '(σ,g), (set world (fun _ => Opened init l) σ, g))
                           | _ => undefined
                           end).

  Definition open (l:loc) : transition (state*global_state) Σ :=
    bind (reads id) (λ '(rs,g), match rs.(world) with
                           | Closed s => bind (modify (λ '(σ,g), (set world (fun _ => Opened s l) σ, g)))
                                             (fun _ => ret s)
                           | _ => undefined
                           end).

  Definition close : transition (RecoverableState) unit :=
    bind (reads id) (fun s => match s with
                           | Opened s _ | Closed s => modify (fun _ => Closed s)
                           | UnInit => modify (fun _ => UnInit)
                           | _ => undefined
                           end).

  Global Instance Recoverable_inhabited : Inhabited RecoverableState := populate UnInit.
End recoverable.

Arguments RecoverableState Σ : clear implicits.
Arguments recoverable_model Σ : clear implicits.

Definition ty_ := forall (val_ty:val_types), @ty val_ty.
(* TODO: slice should not require an entire ext_ty *)
Definition sliceT_ (t: ty_) : ty_ := λ val_ty, prodT (arrayT (t _)) uint64T.
Definition blockT_: ty_ := sliceT_ (λ val_ty, byteT).

Inductive KvsOp :=
  | OpenOp (* both open and init map to the same function (makeKVS) *)
  | InitOp
  | GetOp
  | MultiPutMarkOp
  | MultiPutCommitOp
.

Instance eq_KvsOp : EqDecision KvsOp.
Proof.
  solve_decision.
Defined.

Instance KvsOp_fin : Countable KvsOp.
Proof.
  solve_countable KvsOp_rec 5%nat.
Qed.

Definition kvs_op : ffi_syntax.
Proof.
  refine (mkExtOp KvsOp _ _ Empty_set _ _).
Defined.

Inductive Kvs_ty := KvsT.

Instance kvs_val_ty: val_types :=
  {| ext_tys := Kvs_ty; |}.

Section kvs.
  Parameter kvs_sz : nat.

  Fixpoint init_keys (keys: list u64) (sz: nat) : list u64 :=
  match sz with
  | O => keys
  | S n => init_keys ((U64 (Z.of_nat n)) :: keys) n
  end.
  Definition kvs_keys_all : list u64 := init_keys [] kvs_sz.

  Definition kvs_state_typ := gmap u64 disk.Block.
  Fixpoint init_kvs (kvs: kvs_state_typ) (sz: nat) : kvs_state_typ :=
  match sz with
  | O => kvs
  | S n => <[(U64 (Z.of_nat n)) := (inhabitant disk.Block0)]> (init_kvs kvs n)
  end.
  Definition kvs_init_s : gmap u64 disk.Block := init_kvs ∅ kvs_sz.

  Definition KVPairT : ty := structRefT [uint64T; prodT (arrayT (uint64T)) uint64T].
  Existing Instances kvs_op kvs_val_ty.

  Inductive kvs_ext_tys : @val kvs_op -> (ty * ty) -> Prop :=
  | KvsOpType op :
      kvs_ext_tys (λ: "v", ExternalOp op (Var "v"))%V
       (match op with
         (* pair where first comp is type of inputs, sec is type of outputs *)
           (* have make take no arguments, initialize super + txn -- assume specs? *)
           (* kvs type should be opaque, but kvpair should be known by client *)
         | OpenOp => (unitT, extT KvsT)
         | InitOp => (unitT, extT KvsT)
         | GetOp => (prodT (extT KvsT) uint64T, prodT (KVPairT) boolT)
         | MultiPutMarkOp => (prodT (extT KvsT) (prodT (arrayT KVPairT) uint64T), unitT)
         | MultiPutCommitOp => (prodT (extT KvsT) (prodT (arrayT KVPairT) uint64T), boolT)
         end).

  Instance kvs_ty: ext_types kvs_op :=
    {| val_tys := kvs_val_ty;
       get_ext_tys := kvs_ext_tys |}.

  Definition kvs_state := RecoverableState (gmap u64 disk.Block).

  Instance kvs_model : ffi_model := recoverable_model (gmap u64 disk.Block).

  Existing Instances r_mbind r_fmap.

  Definition mark_slice {state} (t:ty) (v:val): transition state () :=
    match v with
    | PairV (#(LitLoc l)) (PairV #(LitInt sz) #(LitInt cap)) =>
      (* TODO: implement , mark as being read *)
      ret ()
    | _ => undefined
    end.

  Definition read_slice {state} (t:ty) (v:val): transition state (list val) :=
    match v with
    | PairV (#(LitLoc l)) (PairV #(LitInt sz) #(LitInt cap)) =>
      (* TODO: implement , return contents *)
      ret []
    | _ => undefined
    end.

  Definition read_kvpair_key {state} (t:ty) (v:val): transition state u64:=
    match v with
    | PairV #(LitInt key) #(LitLoc _) => ret key
    | _ => undefined
    end.

  Definition read_kvpair_dataslice {state} (t:ty) (v:val): transition state val :=
    match v with
    | PairV #(LitInt _) #(LitLoc dataloc) =>ret #(LitLoc dataloc)
    | _ => undefined
    end.

  Fixpoint update_keys (kvs : gmap u64 disk.Block) (keys : list u64) (data: list disk.Block)
    : gmap u64 disk.Block
    :=
    match keys, data with
    | k::ks, d::ds => update_keys (<[k := d]> kvs) ks ds
    | [], [] => kvs
    | _, _ => kvs
    end.

  Fixpoint tmapM {Σ A B} (f: A -> transition Σ B) (l: list A) : transition Σ (list B) :=
    match l with
    | [] => ret []
    | x::xs => b ← f x;
             bs ← tmapM f xs;
             ret (b :: bs)
    end.

  (* TODO: implement *)
  Definition to_block (l: list val): option disk.Block := None.

  Definition allocIdent: transition (state*global_state) loc :=
    l ← allocateN;
    modify (λ '(σ, g), (set heap <[l := Free #()]> σ, g));;
           ret l.

  Definition kvs_step (op:KvsOp) (v:val) : transition (state*global_state) val :=
    match op, v with
    | InitOp, LitV LitUnit =>
      kvsPtr ← allocIdent;
      initTo (kvs_init_s) kvsPtr;;
      ret $ (LitV $ LitLoc kvsPtr)
    | OpenOp, LitV LitUnit =>
      logPtr ← allocIdent;
      s ← open logPtr;
      ret $ LitV $ LitLoc logPtr
    | GetOp, PairV (LitV (LitLoc kvsPtr)) (LitV (LitInt key)) =>
      openΣ ≫= λ '(kvs, kvsPtr_), (*kvs is the state *)
      check (kvsPtr = kvsPtr_);;
      b ← unwrap (kvs !! key);
      l ← allocateN;
      modify (λ '(σ,g), (state_insert_list l (disk.Block_to_vals b) σ, g));;
             ret $ (PairV #(LitLoc l) #true) (*This could return false?*)
    | MultiPutMarkOp, PairV (LitV (LitLoc kvsPtr)) v => mark_slice KVPairT v;; ret $ #()
    | MultiPutCommitOp, PairV (LitV (LitLoc kvsPtr)) v =>
      (*convert goose representations of kvpair to coq pair of key and value, *)
      (*given list of updates, inserts into gmap *)
      (*to define spec effect of operation*)
      openΣ ≫= λ '(_, kvsPtr_),
      check (kvsPtr = kvsPtr_);;
      (* FIXME: append should be non-atomic in the spec because it needs to read
         an input slice (and the slices the input points to). *)
      (* need to mark that everything is being read so no concurrent modifications *)
      (* LYT: we might just need to check no other writers? Might need to split into two steps *)
      block_slices ← read_slice KVPairT v;
      block_keys ← tmapM (read_kvpair_key KVPairT) block_slices;
      block_dataslices ← tmapM (read_kvpair_dataslice KVPairT) block_slices;
      block_vals ← tmapM (read_slice (@slice.T _ kvs_ty byteT)) block_dataslices;
      new_blocks ← tmapM (unwrap ∘ to_block) block_vals;
      modifyΣ (λ s, update_keys s block_keys new_blocks);;
      ret $ #true (*TODO can this return false if commit_wait fails? *)
    | _, _ => undefined
    end.

  Instance kvs_semantics : ffi_semantics kvs_op kvs_model :=
    {| ffi_step := kvs_step;
       ffi_crash_step := fun s s' => relation.denote close s s' tt; |}. (* everything is durable *)
End kvs.

Inductive kvs_unopen_status := UnInit' | Closed'.

(* resource alg: append log has two: *)
(* (1) tracks status of append log (open/closed) --> anything with recoverable state*)
Definition openR := csumR (prodR fracR (agreeR (leibnizO kvs_unopen_status))) (agreeR (leibnizO loc)).

Definition Kvs_Opened (l: loc) : openR := Cinr (to_agree l).

(* Type class defn, define which algebras are available *)
Class kvsG Σ :=
  { kvsG_open_inG :> inG Σ openR; (* inG --> which resources are available in type class *)
    (* implicitly insert names for elements, used to tag which generation *)
    kvsG_open_name : gname;
    (* (2) exlusive/etc. algebra for disk blocks --> allows for ownership of blocks *)
    kvsG_state_inG :> gen_heap.gen_heapGS u64 disk.Block Σ;
  }.

(* without names: e.g. disk names stay same, memory ones are forgotten *)
Class kvs_preG Σ :=
  { kvsG_preG_open_inG :> inG Σ openR;
    kvsG_preG_state_inG :> gen_heap.gen_heapGpreS u64 disk.Block Σ;
  }.

Definition kvsΣ : gFunctors :=
  #[GFunctor openR; gen_heapΣ u64 disk.Block].

Instance subG_kvsG Σ: subG kvsΣ Σ → kvs_preG Σ.
Proof. solve_inG. Qed.

(* Helpers to manipulate names *)
Record kvs_names :=
  { kvs_names_open: gname;
    kvs_names_state: gen_heap_names; }.

Definition kvs_get_names {Σ} (kvs: kvsG Σ) :=
  {| kvs_names_open := kvsG_open_name; kvs_names_state := gen_heapG_get_names kvsG_state_inG|}.

Definition kvs_update {Σ} (kvs: kvsG Σ) (names: kvs_names) :=
  {| kvsG_open_inG := kvsG_open_inG;
     kvsG_open_name := (kvs_names_open names);
     kvsG_state_inG := gen_heapG_update kvsG_state_inG names.(kvs_names_state);
  |}.

Definition kvs_update_pre {Σ} (kvsG: kvs_preG Σ) (names: kvs_names) :=
  {| kvsG_open_inG := kvsG_preG_open_inG;
     kvsG_open_name := (kvs_names_open names);
     kvsG_state_inG := gen_heapG_update_pre kvsG_preG_state_inG names.(kvs_names_state);
  |}.

(* assert have resource that tell us that kvs is opened at l, persistent + duplicable *)
Definition kvs_open {Σ} {kvsG :kvsG Σ} (l: loc) :=
  own (kvsG_open_name) (Kvs_Opened l).
Definition kvs_closed_frag {Σ} {kvsG :kvsG Σ} :=
  own (kvsG_open_name) (Cinl ((1/2)%Qp, to_agree (Closed' : leibnizO kvs_unopen_status))).
Definition kvs_closed_auth {Σ} {kvsG :kvsG Σ} :=
  own (kvsG_open_name) (Cinl ((1/2)%Qp, to_agree (Closed' : leibnizO kvs_unopen_status))).
Definition kvs_uninit_frag {Σ} {ksG :kvsG Σ} :=
  own (kvsG_open_name) (Cinl ((1/2)%Qp, to_agree (UnInit' : leibnizO kvs_unopen_status))).
Definition kvs_uninit_auth {Σ} {kvsG :kvsG Σ} :=
  own (kvsG_open_name) (Cinl ((1/2)%Qp, to_agree (UnInit' : leibnizO kvs_unopen_status))).

(* what blocks are in the kvs *)
(* kvs: more fine-grained lock? or lock entire map? (more/less useful for clients?) *)
(* precondition in spec --> assert have points-to facts (no state RA), gen_heap *)
Definition kvs_auth {Σ} {kvs :kvsG Σ} (s: gmap u64 disk.Block) := gen_heap.gen_heap_interp s.
Definition kvs_frag {Σ} {kvsG :kvsG Σ} (k : u64) (v : disk.Block) : iProp Σ :=
   (gen_heap.mapsto (L:=u64) (V:=disk.Block) k (DfracOwn 1) v)%I.

Section kvs_interp.
  Existing Instances kvs_op kvs_model kvs_val_ty.

  (* ctx assertions map physical state to which resource assertions should be true, *)
  (* stores auth copy of fact*)
  Definition kvs_ctx {Σ} {kvsG: kvsG Σ} (kvs: @ffi_state kvs_model) : iProp Σ :=
    match kvs with
    | Opened s l => kvs_open l ∗ kvs_auth s
    | Closed s => kvs_closed_auth ∗ kvs_auth s
    | UnInit => kvs_uninit_auth ∗ kvs_auth (∅ : gmap u64 disk.Block) (*  XXXX kvs_init_s *)
    | _ => False%I
    end.

  (* When first start program, what initial resources assertions do you get *)
  Definition kvs_start {Σ} {kvsG: kvsG Σ} (kvs: @ffi_state kvs_model) : iProp Σ :=
    match kvs with
    | Opened s l => kvs_open l ∗ ([∗ list] k ∈ kvs_keys_all, (∃ v, kvs_frag k v)%I)
    | Closed s => kvs_closed_frag ∗ ([∗ list] k ∈ kvs_keys_all, (∃ v, kvs_frag k v)%I)
    | UnInit => kvs_uninit_frag
    | _ => False%I
    end.

(* get access to whether open/closed status *)
  Definition kvs_restart {Σ} (kvsG: kvsG Σ) (kvs: @ffi_state kvs_model) :=
    match kvs with
    | Opened s l => kvs_open l
    | Closed s => kvs_closed_frag
    | UnInit => kvs_uninit_frag
    | _ => False%I
    end.
  (*how to interpret physical state as ghost resources*)
  Program Instance kvs_interp : ffi_interp kvs_model :=
    {| ffiGS := kvsG;
       ffi_local_names := kvs_names;
       ffi_global_names := unit;
       ffi_get_local_names := @kvs_get_names;
       ffi_get_global_names := (λ _ _, tt);
       ffi_update_local := @kvs_update;
       ffi_get_update := _;
       ffi_ctx := @kvs_ctx;
       ffi_global_ctx _ _ _ := True%I;
       ffi_start Σ G w _ := @kvs_start Σ G w;
       ffi_restart := @kvs_restart;
       ffi_crash_rel := λ Σ hF1 σ1 hF2 σ2, ⌜ @kvsG_state_inG _ hF1 = @kvsG_state_inG _ hF2 ∧
                                           kvs_names_state (kvs_get_names hF1) =
                                           kvs_names_state (kvs_get_names hF2) ⌝%I;
    |}.
  Next Obligation.
    intros.
    destruct hF.
    destruct names.
    unfold kvs_update. simpl.
    destruct kvsG_state_inG0; simpl. unfold kvs_get_names; simpl.
    unfold gen_heapG_get_names; simpl.
    destruct kvs_names_state0; simpl; auto.
    Qed.
  Next Obligation. intros ? [[]] => //=. Qed.
  Next Obligation. intros ? [[]] => //=.
                   unfold kvs_update; simpl.
                   destruct kvsG_state_inG0; simpl.
                   unfold kvs_get_names; simpl.
                   unfold gen_heapG_get_names; simpl.
                   auto.
  Qed.
  Next Obligation. intros ? [[]] => //=. Qed.
  Next Obligation. intros ? [[]] => //=. Qed.
End kvs_interp.

Section misc_lemmas.
  Context `{kvsG_ctx: inG Σ openR}.

  Theorem openR_frac_split γ (q1 q2 : Qp) x :
    own γ (Cinl ((q1 + q2)%Qp, x) : openR) ⊣⊢ own γ (Cinl (q1, x)) ∗ own γ (Cinl (q2, x)).
  Proof.
    rewrite -own_op.
    f_equiv.
    apply Cinl_equiv.
    apply pair_proper; simpl.
    - rewrite frac_op //.
    - rewrite agree_idemp //.
  Qed.
End misc_lemmas.

Section kvs_lemmas.
  Context `{kvsG_ctx: kvsG Σ}.

  Global Instance kvs_ctx_Timeless kvs: Timeless (kvs_ctx kvs).
  Proof. destruct kvs; apply _. Qed.

  Global Instance kvs_start_Timeless kvs: Timeless (kvs_start kvs).
  Proof. destruct kvs; apply _. Qed.

  Global Instance kvs_restart_Timeless kvs: Timeless (kvs_restart _ kvs).
  Proof. destruct kvs; apply _. Qed.

  Global Instance kvs_open_Persistent (l: loc) : Persistent (kvs_open l).
  Proof. rewrite /kvs_open/Kvs_Opened. apply own_core_persistent. rewrite /CoreId//=. Qed.

  Lemma kvs_closed_auth_uninit_frag:
    kvs_closed_auth -∗ kvs_uninit_frag -∗ False.
  Proof.
    iIntros "Hauth Huninit_frag".
    iDestruct (own_valid_2 with "Hauth Huninit_frag") as %Hval.
    inversion Hval as [? Heq%to_agree_op_inv].
    inversion Heq.
  Qed.

  Lemma kvs_uninit_auth_closed_frag:
    kvs_uninit_auth -∗ kvs_closed_frag -∗ False.
  Proof.
    iIntros "Hauth Huninit_frag".
    iDestruct (own_valid_2 with "Hauth Huninit_frag") as %Hval.
    inversion Hval as [? Heq%to_agree_op_inv].
    inversion Heq.
  Qed.

  Lemma kvs_uninit_auth_opened l:
    kvs_uninit_auth -∗ kvs_open l -∗ False.
  Proof.
    iIntros "Huninit_auth Hopen".
    iDestruct (own_valid_2 with "Huninit_auth Hopen") as %Hval.
    inversion Hval.
  Qed.

  Lemma kvs_closed_auth_opened l:
    kvs_closed_auth -∗ kvs_open l -∗ False.
  Proof.
    iIntros "Huninit_auth Hopen".
    iDestruct (own_valid_2 with "Huninit_auth Hopen") as %Hval.
    inversion Hval.
  Qed.

  (* know that we're closed + know value at a particular key *)
  Notation "l k↦ v" := (gen_heap.mapsto (L:=u64) (V:=disk.Block) l (DfracOwn 1) v%V)
                              (at level 20, format "l  k↦ v") : bi_scope.
  Notation "l k↦{ q } v" := (gen_heap.mapsto (L:=u64) (V:=disk.Block) l (DfracOwn q) v%V)
                              (at level 20, q at level 50, format "l  k↦{ q }  v") : bi_scope.
  Lemma kvs_ctx_unify_closed kvs (key: u64) (val: disk.Block):
    kvs_closed_frag -∗ key k↦ val -∗ kvs_ctx kvs -∗ ∃ s, ⌜s !! key = Some val ∧ kvs = Closed s ⌝.
  Proof.
    destruct kvs; try eauto; iIntros "Hclosed_frag Hstate_frag Hctx".
    - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
      iDestruct (kvs_closed_auth_uninit_frag with "[$] [$]") as %[].
    - iExists s.
      iDestruct "Hctx" as "(Hclosed_auth&Hstate_auth)".
      iPoseProof (gen_heap_valid with "Hstate_auth Hstate_frag") as "H".
      iSplit; auto.
      - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
        iDestruct (own_valid_2 with "Huninit_auth Hclosed_frag") as %Hval.
        inversion Hval.
  Qed.

  Lemma kvs_ctx_unify_closed' kvs:
    kvs_closed_frag -∗ kvs_ctx kvs -∗ ⌜∃ s, kvs = Closed s ⌝.
  Proof.
    destruct kvs; try eauto; iIntros "Hclosed_frag Hctx".
    - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
      iDestruct (kvs_closed_auth_uninit_frag with "[$] [$]") as %[].
    - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
        iDestruct (own_valid_2 with "Huninit_auth Hclosed_frag") as %Hval.
        inversion Hval.
  Qed.

  Lemma kvs_auth_frag_unif (s : gmap u64 disk.Block) (k: u64) (v: disk.Block):
    kvs_auth s -∗ k k↦ v -∗ ∃ s', ⌜s' !! k = Some v ∧ s = s'⌝.
  Proof.
    rewrite /kvs_auth/kvs_frag. iIntros "H1 H2".
    iExists s.
    iPoseProof (gen_heap_valid with "H1 H2") as "H".
    iSplit; auto.
  Qed.

  Lemma kvs_open_unif l l':
    kvs_open l -∗ kvs_open l' -∗ ⌜ l = l' ⌝.
  Proof.
    rewrite /kvs_auth/kvs_frag.
    iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %Hval.
    rewrite /Kvs_Opened -Cinr_op in Hval.
    assert (l ≡ l') as Heq.
    { eapply to_agree_op_inv. eauto. }
    inversion Heq. by subst.
  Qed.

  Lemma kvs_ctx_unify_uninit kvs:
    kvs_uninit_frag -∗ kvs_ctx kvs -∗ ⌜ kvs = UnInit ⌝.
  Proof.
    destruct kvs; try eauto; iIntros "Huninit_frag Hctx".
    - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
      iDestruct (own_valid_2 with "Huninit_auth Huninit_frag") as %Hval.
      inversion Hval as [? Heq%to_agree_op_inv].
      inversion Heq.
    - iDestruct "Hctx" as "(Hauth&Hstate_auth)".
      iDestruct (own_valid_2 with "Hauth Huninit_frag") as %Hval.
      inversion Hval.
  Qed.

  Lemma kvs_ctx_unify_opened l kvs:
    kvs_open l -∗ kvs_ctx kvs -∗ ⌜ ∃ vs, kvs = Opened vs l ⌝.
  Proof.
      destruct kvs as [| | | | vs' l']; try eauto; iIntros "Hopen Hctx".
    - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
      iDestruct (own_valid_2 with "Huninit_auth Hopen") as %Hval.
      inversion Hval.
    - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
      iDestruct (own_valid_2 with "Huninit_auth Hopen") as %Hval.
      inversion Hval.
    - iDestruct "Hctx" as "(Huninit_auth&Hstate_auth)".
      iDestruct (kvs_open_unif with "[$] [$]") as %Heq.
      subst. eauto.
  Qed.

  Lemma kvs_uninit_token_open (l: loc):
    kvs_uninit_auth -∗ kvs_uninit_frag ==∗ kvs_open l.
  Proof.
    iIntros "Hua Huf".
    iCombine "Hua Huf" as "Huninit".
    rewrite -Cinl_op.
    iMod (own_update _ _ (Kvs_Opened l) with "Huninit") as "$"; last done.
    { apply: cmra_update_exclusive.
      { apply Cinl_exclusive. rewrite -pair_op frac_op Qp.half_half.
        simpl. apply pair_exclusive_l. apply _.
      }
      { econstructor. }
    }
  Qed.

  Lemma kvs_closed_token_open (l: loc):
    kvs_closed_auth -∗ kvs_closed_frag ==∗ kvs_open l.
  Proof.
    iIntros "Hua Huf".
    iCombine "Hua Huf" as "Huninit".
    rewrite -Cinl_op.
    (*Print cmra_update. can transform facts to another fact that is compatible w/others' facts*)
    iMod (own_update _ _ (Kvs_Opened l) with "Huninit") as "$"; last done.
    { apply: cmra_update_exclusive.
      { apply Cinl_exclusive. rewrite -pair_op frac_op Qp.half_half.
        simpl. apply pair_exclusive_l. apply _.
      }
      { econstructor. }
    }
  Qed.

  (* insert updated keyval *)
  Lemma kvs_state_update s k v1 v2:
    kvs_auth s -∗ k k↦v1 ==∗ kvs_auth (<[k := v2]>s)∗ k k↦ v2.
  Proof.
    unfold kvs_auth. apply gen_heap_update.
  Qed.

(* Not related to physical state yet, just updates to ghost vars*)
End kvs_lemmas.

From Perennial.goose_lang Require Import adequacy.

(* when crashes, ffi_crash_rel: hF[] = instance of type class kvsG *)
(* Program Instance --> define instance of type class, don't need to fill in all fields (craete goal, obligation) *)Program Instance kvs_interp_adequacy:
  @ffi_interp_adequacy kvs_model kvs_interp kvs_op kvs_semantics :=
  {| ffi_preG := kvs_preG;
     ffiΣ := kvsΣ;
     subG_ffiPreG := subG_kvsG;
     ffi_initP := λ σ _, σ = UnInit;
     ffi_update_pre := (λ _ hP names _, @kvs_update_pre _ hP names)
  |}.
Next Obligation. rewrite //=. Qed.
Next Obligation. rewrite //=. intros ?? [] [] => //=. Qed.
Next Obligation.
  intros.
  unfold ffi_get_names; simpl.
  unfold kvs_get_names; unfold kvs_update_pre.
  unfold gen_heapG_get_names; simpl.
  destruct names; simpl.
  destruct kvs_names_state0; simpl; auto.
Qed.
Next Obligation.
  (*if in uninit state, can initialize algebra and give ffi start, show that ffi start can be created*)
  (* first part: status *)
  rewrite //=.
  iIntros (Σ hPre σ g ->). simpl.
  rewrite /kvs_uninit_auth/kvs_uninit_frag/kvs_frag/kvs_auth.
  iMod (own_alloc (Cinl (1%Qp, to_agree UnInit') : openR)) as (γ1) "H".
  { repeat econstructor => //=. }
  iMod (gen_heap_name_strong_init ∅) as (names) "(Hctx&Hpts)".
  iFrame. iModIntro.
  iExists {| kvs_names_open := γ1; kvs_names_state := names |}.
  iPoseProof (openR_frac_split γ1 (1/2) (1/2) (to_agree UnInit')) as "HOpen".
  iEval (rewrite -Qp.half_half) in "H".
  iEval (rewrite -frac_op) in "H".
  iDestruct "HOpen" as "[H1 H2]".
  iDestruct ("H1" with "H") as "[H1' H2']".
  iSplitR "H1'"; auto.
  iSplitL "H2'"; auto.
Qed.

Next Obligation. (* restart, crashed to new ffi_state, Hold = old ffiGS, ffi_update plugs in new names *)
  iIntros (Σ σ σ' g Hcrash Hold) "Hinterp _".
  inversion Hcrash; subst.
  monad_inv. inversion H. subst. inversion H1. subst.
  destruct x; monad_inv.
  - inversion Hcrash. subst. inversion H1. subst. inversion H3. subst.
    inversion H2. subst. inversion H4. subst.
    (* XXX: monad_inv should handle *)
    iMod (own_alloc (Cinl (1%Qp, to_agree UnInit') : openR)) as (γ1) "H".
    (*γ1 is new name, plug into new config name *)
    { repeat econstructor => //=. }
    iExists {| kvs_names_open := γ1; kvs_names_state := kvs_names_state (kvs_get_names _) |}.
    iDestruct "Hinterp" as "(?&?)". rewrite //=/kvs_restart//=.
    iFrame. rewrite left_id comm -assoc. iSplitL ""; first eauto.
    * destruct kvsG_state_inG; simpl.
      unfold gen_heapG_update; simpl.
      unfold gen_heapG_get_names; simpl.
      auto.
    * rewrite /kvs_uninit_auth/kvs_uninit_frag/kvs_frag/kvs_auth.
    iModIntro. by rewrite -own_op -Cinl_op -pair_op frac_op Qp.half_half agree_idemp.
  - inversion Hcrash. subst. inversion H1. subst. inversion H3. subst.
    inversion H2. subst. inversion H4. subst.
    (* XXX: monad_inv should handle *)
    iMod (own_alloc (Cinl (1%Qp, to_agree Closed') : openR)) as (γ1) "H".
    { repeat econstructor => //=. }
    iExists {| kvs_names_open := γ1; kvs_names_state := kvs_names_state (kvs_get_names _) |}.
    iDestruct "Hinterp" as "(?&?)". rewrite //=/kvs_restart//=.
    iFrame. rewrite left_id comm -assoc. iSplitL ""; first eauto.
   * destruct kvsG_state_inG; simpl.
      unfold gen_heapG_update; simpl.
      unfold gen_heapG_get_names; simpl.
      auto.
  *
    rewrite /kvs_uninit_auth/kvs_uninit_frag/kvs_frag/kvs_auth.
    iModIntro. by rewrite -own_op -Cinl_op -pair_op frac_op Qp.half_half agree_idemp.
  - inversion Hcrash. subst. inversion H1. subst. inversion H3. subst.
    inversion H2. subst. inversion H4. subst.
    (* XXX: monad_inv should handle *)
    iMod (own_alloc (Cinl (1%Qp, to_agree Closed') : openR)) as (γ1) "H".
    { repeat econstructor => //=. }
    iExists {| kvs_names_open := γ1; kvs_names_state := kvs_names_state (kvs_get_names _) |}.
    iDestruct "Hinterp" as "(?&?)". rewrite //=/kvs_restart//=.
    iFrame. rewrite left_id comm -assoc. iSplitL ""; first eauto.
   * destruct kvsG_state_inG; simpl.
      unfold gen_heapG_update; simpl.
      unfold gen_heapG_get_names; simpl.
      auto.
   *
    rewrite /kvs_uninit_auth/kvs_uninit_frag/kvs_frag/kvs_auth.
    iModIntro. by rewrite -own_op -Cinl_op -pair_op frac_op Qp.half_half agree_idemp.
Qed.

From Perennial.program_proof Require Import proof_prelude.
From Perennial.goose_lang Require Import refinement_adequacy.
Section spec.

Instance kvs_spec_ext : spec_ffi_op := {| spec_ffi_op_field := kvs_op |}.
Instance kvs_spec_ffi_model : spec_ffi_model := {| spec_ffi_model_field := kvs_model |}.
Instance kvs_spec_ext_semantics : spec_ext_semantics (kvs_spec_ext) (kvs_spec_ffi_model) :=
  {| spec_ext_semantics_field := kvs_semantics |}.
Instance kvs_spec_ffi_interp : spec_ffi_interp kvs_spec_ffi_model :=
  {| spec_ffi_interp_field := kvs_interp |}.
Instance kvs_spec_ty : ext_types (spec_ffi_op_field) := kvs_ty.
Instance kvs_spec_interp_adequacy : spec_ffi_interp_adequacy (spec_ffi := kvs_spec_ffi_interp) :=
  {| spec_ffi_interp_adequacy_field := kvs_interp_adequacy |}.

Context `{invGS Σ}.
Context `{crashGS Σ}.
Context `{!refinement_heapG Σ}.

Existing Instance spec_ffi_interp_field.
Existing Instance spec_ext_semantics_field.
Existing Instance spec_ffi_op_field.
Existing Instance spec_ffi_model_field.

Implicit Types K: spec_lang.(language.expr) → spec_lang.(language.expr).
Instance kvsG0 : kvsG Σ := refinement_spec_ffiG.

  Ltac inv_head_step :=
    repeat match goal with
        | _ => progress simplify_map_eq/= (* simplify memory stuff *)
        | H : to_val _ = Some _ |- _ => apply of_to_val in H
        | H : head_step ?e _ _ _ _ _ _ _ |- _ =>
          try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
     and can thus better be avoided. *)
          inversion H; subst; clear H
        | H : ffi_step _ _ _ _ _ |- _ =>
          inversion H; subst; clear H
        | [ H1: context[ match world ?σ with | _ => _ end ], Heq: world ?σ = _ |- _ ] =>
          rewrite Heq in H1
        end.

Lemma ghost_step_init_stuck E j K {HCTX: LanguageCtx K} σ g:
  nclose sN_inv ⊆ E →
  (σ.(@world _ kvs_spec_ffi_model.(@spec_ffi_model_field)) ≠ UnInit) →
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) InitOp #()) -∗
  source_ctx (CS := spec_crash_lang) -∗
  source_state σ g -∗
  |NC={E}=> False.
Proof.
  iIntros (??) "Hj Hctx H".
  iMod (ghost_step_stuck with "Hj Hctx H") as "[]".
  { eapply stuck_ExternalOp; first (by eauto).
    apply head_irreducible_not_atomically; [ by inversion 1 | ].
    intros ????? Hstep.
    repeat (inv_head_step; simpl in *; repeat monad_inv).
    destruct (σ.(world)); try congruence;
    repeat (inv_head_step; simpl in *; repeat monad_inv).
  }
  { solve_ndisj. }
Qed.

Lemma ghost_step_open_stuck E j K {HCTX: LanguageCtx K} σ g:
  nclose sN_inv ⊆ E →
  (∀ vs, σ.(@world _ kvs_spec_ffi_model.(@spec_ffi_model_field)) ≠ Closed vs) →
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) OpenOp #()) -∗
  source_ctx (CS := spec_crash_lang) -∗
  source_state σ g -∗
  |NC={E}=> False.
Proof.
  iIntros (??) "Hj Hctx H".
  iMod (ghost_step_stuck with "Hj Hctx H") as "[]".
  { eapply stuck_ExternalOp; first (by eauto).
    apply head_irreducible_not_atomically; [ by inversion 1 | ].
    intros ??????.
    repeat (inv_head_step; simpl in *; repeat monad_inv).
    destruct (σ.(world)); try congruence;
    repeat (inv_head_step; simpl in *; repeat monad_inv); eauto.
    eapply H2; eauto.
  }
  { solve_ndisj. }
Qed.

Lemma kvs_closed_init_false E j K {HCTX: LanguageCtx K}:
  nclose sN ⊆ E →
  spec_ctx -∗
  kvs_closed_frag -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) InitOp #()) -∗ |NC={E}=>
  False.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hclosed_frag Hj".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iDestruct (kvs_ctx_unify_closed' with "[$] [$]") as %Heq; subst.
  iMod (ghost_step_init_stuck with "[$] [$] [$]") as "[]".
  { solve_ndisj. }
  destruct Heq; subst; auto. congruence.
Qed.

Lemma kvs_opened_init_false l E j K {HCTX: LanguageCtx K}:
  nclose sN ⊆ E →
  spec_ctx -∗
  kvs_open l -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) InitOp #()) -∗ |NC={E}=>
  False.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hopened Hj".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iDestruct (kvs_ctx_unify_opened with "[$] [$]") as %Heq; subst.
  iMod (ghost_step_init_stuck with "[$] [$] [$]") as "[]".
  { solve_ndisj. }
  { destruct Heq as (?&Heq). by rewrite Heq. }
Qed.

Lemma kvs_init_init_false E j K {HCTX: LanguageCtx K} j' K' {HCTX': LanguageCtx K'}:
  nclose sN ⊆ E →
  spec_ctx -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) InitOp #()) -∗
  j' ⤇ K' (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) InitOp #()) -∗ |NC={E}=>
  False.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hj Hj'".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iEval (simpl) in "Hffi".
  destruct σ.(world) eqn:Heq; rewrite Heq; try (iDestruct "Hffi" as %[]).
  - iMod (ghost_step_lifting with "Hj Hctx H") as "(Hj&H&_)". (* step one thread *)
    { apply head_prim_step. simpl. constructor 1. econstructor.
      * eexists _ (fresh_locs (dom σ.(heap))); repeat econstructor.
        ** apply fresh_locs_non_null; lia.
        ** hnf; intros. apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh.
        ** econstructor.
        ** simpl. rewrite Heq. repeat econstructor.
      * repeat econstructor.
    }
    { solve_ndisj. }
    iMod (ghost_step_init_stuck with "Hj' [$] [$]") as "[]".
    { solve_ndisj. }
    { simpl. congruence. }
  - iMod (ghost_step_init_stuck with "Hj' [$] [$]") as "[]".
    { solve_ndisj. }
    { congruence. }
  - iMod (ghost_step_init_stuck with "Hj' [$] [$]") as "[]".
    { solve_ndisj. }
    { congruence. }
Qed.

Lemma kvs_init_open_false E j K {HCTX: LanguageCtx K} j' K' {HCTX': LanguageCtx K'}:
  nclose sN ⊆ E →
  spec_ctx -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) InitOp #()) -∗
  j' ⤇ K' (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) OpenOp #()) -∗ |NC={E}=>
  False.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hj Hj'".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iEval (simpl) in "Hffi".
  destruct σ.(world) eqn:Heq; rewrite Heq; try (iDestruct "Hffi" as %[]).
  - iMod (ghost_step_stuck with "Hj' Hctx H") as "[]".
    { eapply stuck_ExternalOp; first (by eauto).
      apply head_irreducible_not_atomically; [ by inversion 1 | ].
      intros ??????. by repeat (inv_head_step; simpl in *; repeat monad_inv).
    }
    { solve_ndisj. }
  - iMod (ghost_step_init_stuck with "Hj [$] [$]") as "[]".
    { solve_ndisj. }
    { congruence. }
  - iMod (ghost_step_init_stuck with "Hj [$] [$]") as "[]".
    { solve_ndisj. }
    { congruence. }
Qed.

Lemma ghost_step_kvs_init E j K {HCTX: LanguageCtx K}:
  nclose sN ⊆ E →
  spec_ctx -∗
  kvs_uninit_frag -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) InitOp #())
  -∗ |NC={E}=>
  ∃ (l: loc), j ⤇ K (#l)%V ∗ kvs_open l.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hvals Hj".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iDestruct (kvs_ctx_unify_uninit with "[$] [$]") as %Heq.
  iMod (ghost_step_lifting with "Hj Hctx H") as "(Hj&H&_)".
  { apply head_prim_step. simpl. constructor 1. econstructor.
    * eexists _ (fresh_locs (dom σ.(heap))); repeat econstructor.
      ** apply fresh_locs_non_null; lia.
      ** hnf; intros. apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh.
      ** econstructor.
      ** simpl. rewrite Heq. repeat econstructor.
    * repeat econstructor.
  }
  { solve_ndisj. }
  simpl. rewrite Heq.
  iDestruct "Hffi" as "(Huninit_auth&Hvals_auth)".
  iMod (kvs_uninit_token_open ((fresh_locs (dom σ.(heap)))) with "[$] [$]") as "#Hopen".
  iMod (na_heap_alloc _ σ.(heap) (fresh_locs (dom σ.(heap))) (#()) (Reading O) with "Hσ") as "(Hσ&?)".
  { rewrite //=. }
  { apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh. }
  { apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh. }
  { auto. }
  iMod (gen_heap_alloc_big ∅ kvs_init_s with "Hvals_auth") as "Hgh".
  { apply map_disjoint_empty_r. }
  { iMod ("Hclo" with "[Hσ H Hrest Hgh]") as "_".
    - iNext. iExists _, _. iFrame "H".  iFrame. iFrame "Hopen".
      iDestruct "Hgh" as "[Hgh Hmap]". simpl in *.
      rewrite right_id; auto. rewrite fresh_alloc_equiv_null_non_alloc; iFrame.
    - iModIntro. iExists _. iFrame "Hopen". iFrame.
  }
Qed.

Lemma kvs_uninit_open_false E j K {HCTX: LanguageCtx K}:
  nclose sN ⊆ E →
  spec_ctx -∗
  kvs_uninit_frag -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) OpenOp #()) -∗ |NC={E}=>
  False.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hclosed_frag Hj".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iDestruct (kvs_ctx_unify_uninit with "[$] [$]") as %Heq; subst.
  iMod (ghost_step_open_stuck with "[$] [$] [$]") as "[]".
  { solve_ndisj. }
  { congruence. }
Qed.

Lemma kvs_opened_open_false l E j K {HCTX: LanguageCtx K}:
  nclose sN ⊆ E →
  spec_ctx -∗
  kvs_open l -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) OpenOp #()) -∗ |NC={E}=>
  False.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hopened Hj".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  simpl.
  iDestruct (kvs_ctx_unify_opened with "[$] [$]") as %Heq; subst.
  iMod (ghost_step_open_stuck with "[$] [$] [$]") as "[]".
  { solve_ndisj. }
  { destruct Heq as (?&Heq). by rewrite Heq. }
Qed.

Lemma kvs_open_open_false E j K {HCTX: LanguageCtx K} j' K' {HCTX': LanguageCtx K'}:
  nclose sN ⊆ E →
  spec_ctx -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) OpenOp #()) -∗
  j' ⤇ K' (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) OpenOp #()) -∗ |NC={E}=>
  False.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Hj Hj'".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iEval (simpl) in "Hffi".
  destruct σ.(world) eqn:Heq; rewrite Heq; try (iDestruct "Hffi" as %[]).
  - iMod (ghost_step_open_stuck with "Hj' [$] [$]") as "[]".
    { solve_ndisj. }
    { congruence. }
  - iMod (ghost_step_lifting with "Hj Hctx H") as "(Hj&H&_)".
    { apply head_prim_step. simpl. constructor 1. econstructor.
      * eexists _ (fresh_locs (dom σ.(heap))); repeat econstructor.
        ** apply fresh_locs_non_null; lia.
        ** hnf; intros. apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh.
        ** econstructor.
        ** simpl. rewrite Heq. repeat econstructor.
      * repeat econstructor.
    }
    { solve_ndisj. }
    iMod (ghost_step_open_stuck with "Hj' [$] [$]") as "[]".
    { solve_ndisj. }
    { simpl. congruence. }
  - iMod (ghost_step_open_stuck with "Hj' [$] [$]") as "[]".
    { solve_ndisj. }
    { congruence. }
Qed.

Lemma ghost_step_kvs_open E j K {HCTX: LanguageCtx K}:
  nclose sN ⊆ E →
  spec_ctx -∗
  kvs_closed_frag -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) OpenOp #())
  -∗ |NC={E}=>
  ∃ (l: loc), j ⤇ K #l%V ∗ kvs_open l.
Proof.
  iIntros (?) "(#Hctx&#Hstate) Huninit_frag Hj".
  iInv "Hstate" as (σ g) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iDestruct (kvs_ctx_unify_closed' with "[$] [$]") as %Heq.
  destruct Heq as [s Heq].
  iMod (ghost_step_lifting with "Hj Hctx H") as "(Hj&H&_)".
  { apply head_prim_step. simpl. constructor 1. econstructor.
    * eexists _ (fresh_locs (dom σ.(heap))); repeat econstructor.
      ** apply fresh_locs_non_null; lia.
      ** hnf; intros. apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh.
      ** econstructor.
      ** simpl. rewrite Heq. repeat econstructor.
    * repeat econstructor.
  }
  { solve_ndisj. }
  simpl. rewrite Heq.
  iDestruct "Hffi" as "(Huninit_auth&Hvals_auth)".
  iMod (kvs_closed_token_open ((fresh_locs (dom σ.(heap)))) with "[$] [$]") as "#Hopen".
  iMod (na_heap_alloc _ σ.(heap) (fresh_locs (dom σ.(heap))) (#()) (Reading O) with "Hσ") as "(Hσ&?)".
  { rewrite //=. }
  { apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh. }
  { apply (not_elem_of_dom (D := gset loc)). by apply fresh_locs_fresh. }
  { auto. }
  iMod ("Hclo" with "[Hσ Hvals_auth H Hrest]") as "_".
  { iNext. iExists _, _. iFrame "H".  iFrame. iFrame "Hopen". rewrite fresh_alloc_equiv_null_non_alloc. iFrame. }
  iModIntro. iExists _. iFrame "Hopen". iFrame.
Qed.

(* XXX TODO how to return block?
Lemma ghost_step_kvs_get E j K {HCTX: LanguageCtx K} l k v :
  nclose sN ⊆ E →
  spec_ctx -∗
  kvs_open l -∗
  j ⤇ K (ExternalOp (ext := @spec_ffi_op_field kvs_spec_ext) GetOp #l #(LitInt k))
  ={E}=∗
  j ⤇ K #(LitLoc l)%V ∗ l ↦ v ∗ kvs_frag k v.
Proof.
  iIntros (?) "(#Hctx&#Hstate) #Hopen Hj".
  iInv "Hstate" as (σ) "(>H&Hinterp)" "Hclo".
  iDestruct "Hinterp" as "(>Hσ&>Hffi&Hrest)".
  iDestruct (kvs_ctx_unify_opened with "[$] [$]") as %Heq.
  destruct Heq as (vs'&Heq).
  iMod (ghost_step_lifting with "Hj Hctx H") as "(Hj&H&_)".
  { apply head_prim_step. repeat (eauto || monad_simpl || rewrite Heq || econstructor). }
  { solve_ndisj. }
  simpl. rewrite Heq.
  iDestruct "Hffi" as "(Huninit_auth&Hvals_auth)".
  iMod (kvs_state_update [] with "[$] [$]") as "(Hvals_auth&?)".
  iMod ("Hclo" with "[Hσ Hvals_auth H Hrest]") as "_".
  { iNext. iExists _. iFrame "H". iFrame. iFrame "Hopen". }
  iModIntro. iFrame.
Qed.*)

End spec.