Require Import Nat.
Require Import String.
Require Import List.
From mathcomp Require Import all_ssreflect all_algebra.
From LF Require Export lang_spec_declassify type_spec_declassify.

Set Implicit Arguments.

Inductive state_equiv_spec (s1 s2:state) (VGamma:venv) (AGamma:aenv) : Prop :=
| st_equiv_spec :
  s1.(scmd) = s2.(scmd) ->
  s1.(ms) = s2.(ms) ->
  (forall x, VGamma x = Some Public -> s1.(rmap) x = s2.(rmap) x) ->
  (not s1.(ms) ->
     (forall x, VGamma x = Some PublicLoad -> s1.(rmap) x = s2.(rmap) x) /\
     (forall a, AGamma a = Some APublic -> s1.(mmap) a = s2.(mmap) a)) ->
  state_equiv_spec s1 s2 VGamma AGamma.

Definition constant_time_spec (VGamma:venv) (AGamma:aenv) (s1 s2:state) :=
forall s1' s2' d l1 l2 n,
state_equiv_spec s1 s2 VGamma AGamma ->
multi_step_spec s1 d l1 n s1' ->
multi_step_spec s2 d l2 n s2' ->
l1 = l2 /\ (safe_state s1' <-> safe_state s2').

Definition extract_declassify_leakage_spec (l : leakage) : option value :=
match l with
 | Ldeclassify v => v
 | _ => None
end.

Fixpoint extract_declassify_leakages_spec (l : seq leakage) : seq (option value) :=
match l with
 | [::] => [::]
 | l :: ls => extract_declassify_leakage_spec l :: extract_declassify_leakages_spec ls
end.

Fixpoint extract_declassify_leakagess_spec (l : seq (seq leakage)) : seq (seq (option value)) :=
match l with
 | [::] => [::]
 | l :: ls => extract_declassify_leakages_spec l :: extract_declassify_leakagess_spec ls
end.

Definition constant_time_declassify_spec (VGamma:venv) (AGamma:aenv) (s1 s2:state) :=
forall s1' s2' d l1 l2 n,
state_equiv_spec s1 s2 VGamma AGamma ->
multi_step_spec s1 d l1 n s1' ->
multi_step_spec s2 d l2 n s2' ->
extract_declassify_leakagess_spec l1 = extract_declassify_leakagess_spec l2 /\
(safe_state s1' <-> safe_state s2').

Lemma progress : forall VGamma AGamma s,
type_cmd VGamma AGamma s.(scmd) ->
safe_state s.
Proof.
move=> VGamma AGamma [] /= [].
(* empty *)
+ by left.
(* i::c *)
move=> i c r m b hty. induction hty. induction H.
(* Iempty :: c *)
+ right.
  exists Dstep.
  exists [::].
  exists {| scmd := c0;
            rmap := r;
            mmap := m;
            ms := b |}.
  by apply Iempty_sem_spec.
(* x := e:: c*)
+ right.
  exists Dstep.
  exists (if d
          then [:: Ldeclassify (Some (sem_expr_spec {| scmd := Iassgn x d e :: c0; rmap := r; mmap := m; ms := b |} e))]
          else [:: Lempty]).
  exists {| scmd := c0;
            rmap := update_rmap r x
                       (sem_expr_spec {| scmd := Iassgn x d e :: c0; rmap := r; mmap := m; ms := b |} e);
            mmap := m;
            ms := b |}.
  by apply Iassgn_sem_spec.
(* x := a[e]::c *) (* array can be public/secret *)
+ case: a H0=> a e H0. right.
  exists (Dload a (sem_expr_spec {| scmd := Iload x d (AA a e) :: c0; rmap := r; mmap := m; ms := b |} e)).
  exists  (if d
           then [:: Lindex (sem_expr_spec {| scmd := Iload x d (AA a e) :: c0; rmap := r; mmap := m; ms := b |} e);
                    Ldeclassify
                    (Some (Array.get (mmap {| scmd := Iload x d (AA a e) :: c0; rmap := r; mmap := m; ms := b |} a)
                           (sem_expr_spec {| scmd := Iload x d (AA a e) :: c0; rmap := r; mmap := m; ms := b |} e)))]
                else [:: Lindex (sem_expr_spec {| scmd := Iload x d (AA a e) :: c0; rmap := r; mmap := m; ms := b |} e)]).
  exists {| scmd := c0;
            rmap := update_rmap r x
                       (Array.get (mmap {| scmd := Iload x d (AA a e) :: c0; rmap := r; mmap := m; ms := b |} a)
                       (sem_expr_spec {| scmd := Iload x d (AA a e) :: c0; rmap := r; mmap := m; ms := b |} e));
            mmap := m;
            ms := b |}.
  by apply Iload_sem_spec.
(* a[e] := e *)
+ case: a H0=> a ei H0. right.
  exists (Dstore a (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c0; rmap := r; mmap := m; ms := b |} ei)).
  exists (if d
          then [:: Lindex (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c0; rmap := r; mmap := m; ms := b |} ei);
                   Ldeclassify (Some (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c0; rmap := r; mmap := m; ms := b |} e))]
          else [:: Lindex (sem_expr_spec {| scmd := Istore (AA a ei) d  e :: c0; rmap := r; mmap := m; ms := b |} ei)]).
  exists {| scmd := c0;
            rmap := r;
            mmap := update_mem m a
                       (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c0; rmap := r; mmap := m; ms := b |} ei)
                       (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c0; rmap := r; mmap := m; ms := b |} e);
            ms := b |}.
  by apply Istore_sem_spec.
(* if b i1 i2 *)
+ case: b0 H=> b0 e1 e2 H. right.
  exists (Dforce (eval_bool_op b0
                 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e1)
                 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e2))).
  exists [::(Lbool (eval_bool_op b0
                (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e1)
                (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e2)))].
  exists {| scmd := (if (eval_bool_op b0 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e1)
                                        (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e2))
                        then i0
                        else i') ++ c0;
            rmap := {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |}.(rmap);
            mmap := {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |}.(mmap);
            ms := if (eval_bool_op b0
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e1)
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e2)) ==
                     (eval_bool_op b0
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e1)
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e2))
                  then {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |}.(ms) else true |}.
  by apply Iif_sem_spec with b0 e1 e2 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e1) (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i0 i' :: c0; rmap := r; mmap := m; ms := b |} e2).
(* protect x v *)
+ right.
  exists Dstep.
  exists [::Lempty].
  exists {| scmd := c0;
            rmap := if b then update_rmap r x 0 else update_rmap r x (r y);
            mmap := m;
            ms := b |}.
  by apply Iprotect_sem_spec.
by left.
Qed.

Lemma union_public_eq : forall T T',
union_vlevel T T' = Public ->
T = Public /\ T' = Public.
Proof.
unfold union_vlevel. move=> T T'.
case: T=> //=.
by case: T'=> //=.
Qed.

Lemma union_publicload_eq : forall T T',
union_vlevel T T' = PublicLoad ->
T = PublicLoad \/ T = Public.
Proof.
unfold union_vlevel. move=> T T'.
case: T=> //=.
+ case: T'=> //=. move=> h. by right.
case: T' => //=.
+ move=> h; by left.
by left.
Qed.

Lemma public_subtype_publicload : forall T,
sub_vlevel T Public = true ->
sub_vlevel T PublicLoad.
Proof.
move=> T ht. by case: T ht=> //=.
Qed.

Definition public_ms ms := if ms then Public else PublicLoad.

Lemma sub_public_always_public : forall T,
sub_vlevel T Public = true ->
T = Public.
Proof.
by move=> [] //=.
Qed.

Lemma sub_publicload_public : forall T,
sub_vlevel T PublicLoad = true ->
T = Public \/ T = PublicLoad.
Proof.
move=> [] //= ht.
+ by left.
by right.
Qed.

Lemma sub_sub_vlevel : forall T T',
sub_vlevel (union_vlevel T T') Public ->
sub_vlevel T Public /\ sub_vlevel T' Public.
Proof.
move=> T T' h.
split=> //=;
apply sub_public_always_public in h; rewrite /=.
apply union_public_eq in h; by case: h=> ->.
apply union_public_eq in h; by case: h=> _ ->.
Qed.

Lemma sub_sub_vlevel' : forall T T',
sub_vlevel (union_vlevel T T') PublicLoad ->
sub_vlevel T PublicLoad /\ sub_vlevel T' PublicLoad.
Proof.
move=> T T' h.
split=> //=.
+ by case: T h=> //=.
case: T' h=> //=. by case: T=> //=.
Qed.

Lemma expr_equiv_val : forall VGamma AGamma s1 s2 e T,
state_equiv_spec s1 s2 VGamma AGamma ->
type_expr VGamma e T ->
sub_vlevel T (public_ms (s1.(ms))) ->
sem_expr_spec s1 e = sem_expr_spec s2 e.
Proof.
move=> VGamma AGamma [] st1 r1 m1 b1 [] st2 r2 m2 b2 e T /= hvar hty hteq.
move: hvar. move=> [] /= hst hb hx hms; subst.
induction hty.
+ rewrite /public_ms in hteq. case: b2 hms hteq.
  + move=> hms hteq. case: T H hteq=> //=.
    move=> hx' _. by move: (hx x hx').
  move=> hms hteq. case: T H hteq=> //=.
  + move=> hx' _. by move: (hx x hx').
  move=> hxty. have ht : ~ false. + by auto.
  move: (hms ht)=> [] hr hm _. by move: (hr x hxty).
rewrite /public_ms /= in hteq. case: b2 hms IHhty1 IHhty2 hteq.
+ move=> ht /= h1 h2 /= h. apply sub_sub_vlevel in h.
  case: h=> h1' h2'.
  case: o=> //=;move: (h1 h1') => ->; by move: (h2 h2') => ->.
move=> ht /= h1 h2 /= h. apply sub_sub_vlevel' in h.
case: h=> h1' h2'.
case: o=> //=;move: (h1 h1') => ->; by move: (h2 h2') => ->.
Qed.

Lemma expr_equiv_val_public : forall VGamma s1 s2 e T,
(forall x ,VGamma x = Some Public ->
 s1.(rmap) x = s2.(rmap) x) ->
type_expr VGamma e T ->
T = Public ->
sem_expr_spec s1 e = sem_expr_spec s2 e.
Proof.
move=> VGamma [] st1 r1 m1 b1 [] st2 r2 m2 b2 e T /= hvar hty hteq.
induction hty.
+ rewrite hteq in H. rewrite /=. by move: (hvar x H)=> ->.
apply union_public_eq in hteq. case: hteq=> h1 h2.
case: o=> //=;move: (IHhty1 h1) => ->; by move: (IHhty2 h2) => ->.
Qed.

(* Because our language design is safe: it never goes to a stuck state *)
(* In speculative semantic it might be diff *)
Lemma safe_lang : forall s,
safe_state s.
Proof.
rewrite /safe_state /= /final_state /=.
move=> [] st r m b /=. case: st=> //=.
+ by left.
move=> i c. case: i.
(* Iempty *)
+ right. exists Dstep. exists [::]. exists {| scmd := c; rmap := r; mmap := m; ms := b |}.
  by apply Iempty_sem_spec.
(* x := e:: c*)
+ move=> x d e. right.
  exists Dstep.
  exists  (if d
          then [:: Ldeclassify (Some (sem_expr_spec {| scmd := Iassgn x d e :: c; rmap := r; mmap := m; ms := b |} e))]
          else [:: Lempty]).
  exists {| scmd := c;
            rmap := update_rmap r x
                       (sem_expr_spec {| scmd := Iassgn x d e :: c; rmap := r; mmap := m; ms := b |} e);
            mmap := m;
            ms := b |}.
  by apply Iassgn_sem_spec.
(* x := a[e]::c *) (* array can be public/secret *)
+ move=> x d a. case: a=> a e. right.
  exists (Dload a (sem_expr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := b |} e)).
  exists  (if d
           then [:: Lindex (sem_expr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := b |} e);
                    Ldeclassify
                    (Some (Array.get (mmap {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := b |} a)
                           (sem_expr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := b |} e)))]
                else [:: Lindex (sem_expr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := b |} e)]).
  exists {| scmd := c;
            rmap := update_rmap r x
                       (Array.get (mmap {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := b |} a)
                       (sem_expr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := b |} e));
            mmap := m;
            ms := b |}.
  by apply Iload_sem_spec.

(* a[e] := e *)
+ move=> a d e. case: a=> a ei. right.
  exists (Dstore a (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c; rmap := r; mmap := m; ms := b |} ei)).
  exists (if d
          then [:: Lindex (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c; rmap := r; mmap := m; ms := b |} ei);
                   Ldeclassify (Some (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c; rmap := r; mmap := m; ms := b |} e))]
          else [:: Lindex (sem_expr_spec {| scmd := Istore (AA a ei) d  e :: c; rmap := r; mmap := m; ms := b |} ei)]).
  exists {| scmd := c;
            rmap := r;
            mmap := update_mem m a
                       (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c; rmap := r; mmap := m; ms := b |} ei)
                       (sem_expr_spec {| scmd := Istore (AA a ei) d e :: c; rmap := r; mmap := m; ms := b |} e);
            ms := b |}.
  by apply Istore_sem_spec.
(* if b i1 i2 *)
+ move=> b0 i1 i2. case: b0=> b0 e1 e2. right.
  exists (Dforce (eval_bool_op b0
                 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e1)
                 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e2))).
  exists [::(Lbool (eval_bool_op b0
                (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e1)
                (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e2)))].
  exists {| scmd := (if (eval_bool_op b0 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e1)
                                        (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e2))
                        then i1
                        else i2) ++ c;
            rmap := {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |}.(rmap);
            mmap := {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |}.(mmap);
            ms := if (eval_bool_op b0
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e1)
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e2)) ==
                     (eval_bool_op b0
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e1)
                     (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e2))
                  then {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |}.(ms) else true |}.
  by apply Iif_sem_spec with b0 e1 e2 (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e1) (sem_expr_spec {| scmd := Iif (Ebool b0 e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := b |} e2).
(* protect x y *)
+ move=> x y. right.
  exists Dstep.
  exists [::Lempty].
  exists {| scmd := c;
            rmap := if b then update_rmap r x 0 else update_rmap r x (r y);
            mmap := m;
            ms := b |}.
  by apply Iprotect_sem_spec.
Qed.

Lemma leakage_eq_n : forall s d l n s',
multi_step_spec s d l n s' ->
size l = n.
Proof.
move=> [] st r m b d l n [] st' r' m' b' hmulti.
induction hmulti; auto.
by induction H;rewrite -cat1s size_cat /= IHhmulti add1n /= addn1.
Qed.

Lemma type_concat : forall VGamma AGamma c1 c2,
type_cmd VGamma AGamma c1 ->
type_cmd VGamma AGamma c2 ->
type_cmd VGamma AGamma (c1 ++ c2).
Proof.
move=> VGamma AGamma c1 c2 hc1 hc2.
induction c1; rewrite /=.
+ by apply hc2.
inversion hc1; subst.
apply T_seq.
+ by apply H1.
apply IHc1. by apply H2.
Qed.

Lemma preservation : forall VGamma AGamma s1 d1 l1 s1',
type_cmd VGamma AGamma s1.(scmd) ->
sem_instr_spec s1 d1 l1 s1' ->
type_cmd VGamma AGamma s1'.(scmd).
Proof.
move=> VGamma AGamma [] st r m b d1 l1 s1' hty hstep.
induction hstep.
(* Iempty *)
+ rewrite H /= in hty. by inversion hty; (try discriminate); subst.
(* x := e *)
+ rewrite /update_rmap /update_map /=. rewrite H in hty.
  by inversion hty.
(* if b i1 i2 *)
+ rewrite H /= in hty. inversion hty; subst.
  inversion H5; subst.
  case: ifP=> //=.
  (* true *)
  + move=> htrue. by move: (type_concat H4 H6).
  (* false *)
  move=> hfalse. by move: (type_concat H7 H6).
(* x := a[e] *)
+ rewrite /update_rmap /update_map /=. rewrite H in hty.
  by inversion hty.
(* a[e] := e *)
+ rewrite /update_rmap /update_map /=. rewrite H in hty.
  by inversion hty.
(* protect x v *)
rewrite /update_rmap /update_map /=. rewrite H in hty.
by inversion hty.
Qed.

Lemma step_spec_spec : forall s d l s',
sem_instr_spec s d l s' ->
s.(ms) = true ->
s'.(ms) = true.
Proof.
move=> [] st1 r1 m1 ms d l s' hstep /= hms; subst.
inversion hstep; auto.
rewrite /= in H6. rewrite /=.
by case: ifP=> //=.
Qed.

Lemma step_deterministic_dir : forall s d l1 s1 l2 s2,
sem_instr_spec s d l1 s1 ->
sem_instr_spec s d l2 s2 ->
l1 = l2 /\ s1 = s2.
Proof.
move=> [] st1 r1 m1 ms1 d l1 s2 l2 s2' hstep hstep'.
inversion hstep; (try discriminate); subst.
(* Iempty *)
+ rewrite /= in H. rewrite H /= in hstep'.
  inversion hstep'; (try discriminate); subst.
  rewrite /= in H0 hstep hstep'; subst.
  split=> //=; by inversion H0.
(* x := e *)
+ rewrite /= in H. rewrite H /= in hstep'.
  inversion hstep'; (try discriminate); subst.
  rewrite /= in H0 hstep hstep'; subst.
  split=> //=. by case: H0=> /= h1 h2 h3 h4; subst.
  by inversion H0.
(* if b i i' *)
+ inversion hstep'; (try discriminate); subst.
  rewrite /= in H H1 hstep hstep'; subst.
  case: H1=> h1 h2 h3 h4 h5 h6; subst. by split=> //=.
(* x := a[e] *)
+ rewrite /= in H. rewrite H /= in hstep'.
  inversion hstep'; (try discriminate); subst.
  rewrite /= in H3 H5 hstep hstep'; subst.
  case: H5=> h1 h2 h3 h4; subst. by split=> //=.
(* a[e] := e *)
+ rewrite /= in H. rewrite H /= in hstep'.
  inversion hstep'; (try discriminate); subst.
  rewrite /= in H3 H5 hstep hstep'; subst.
  case: H5=> h1 h2 h3 h4; subst. by split=> //=.
(* protect *)
rewrite /= in H. rewrite H /= in hstep'.
inversion hstep'; (try discriminate); subst.
split=> //=. by case: H0=> h1 h2 h3; subst.
Qed.

Definition declassify_val_spec (d:bool) ve (v : seq (option value)) : value :=
  if d then (odflt 0 (last None v))
  else ve.

Definition build_i_leakage_spec (s: state) (v : seq (option value)) : seq leakage :=
match (nth Iempty (scmd s) 0) with
 | Iempty => [::]
 | Iassgn x d e => if d then [:: Ldeclassify (nth None v 0)] else [:: Lempty]
 | Iload x d (AA a e) => if d then [:: Lindex (sem_expr_spec s e); Ldeclassify (nth None v 1)]
                              else [:: Lindex (sem_expr_spec s e)]
 | Istore (AA a e) d e' => if d then [:: Lindex (sem_expr_spec s e); Ldeclassify (nth None v 1)]
                                else [:: Lindex (sem_expr_spec s e)]
 | Iif (Ebool bop e1 e2) i1 i2 => [:: Lbool (eval_bool_op bop (sem_expr_spec s e1) (sem_expr_spec s e2))]
 | Iprotect x y => [:: Lempty]
end.

Inductive build_state_instr_spec : state -> seq (option value) -> directive -> state -> Prop :=
| build_next_empty : forall c r m ms,
                      build_state_instr_spec {| scmd := Iempty :: c; rmap := r; mmap := m; ms := ms |} [::] Dstep
                      {| scmd := c; rmap := r; mmap := m; ms := ms |}
| build_next_assgn : forall x d e c r m ms vs,
                      build_state_instr_spec {| scmd := Iassgn x d e :: c; rmap := r; mmap := m; ms := ms |} vs Dstep
                      {| scmd := c;
                         rmap := update_rmap r x
                                  (declassify_val_spec d
                                   (sem_expr_spec {| scmd := Iassgn x d e :: c; rmap := r; mmap := m; ms := ms |} e) vs);
                         mmap := m; ms := ms |}
| build_next_load : forall x d a e c r m ms vs,
                    build_state_instr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := ms |} vs
                    (Dload a (sem_expr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := ms |} e))
                    {| scmd := c;
                       rmap := update_rmap r x
                               (declassify_val_spec d (Array.get (m a)
                               (sem_expr_spec {| scmd := Iload x d (AA a e) :: c; rmap := r; mmap := m; ms := ms |} e)) vs);
                       mmap := m;
                       ms := ms |}
| build_next_store : forall d a e e' c r m ms vs,
                     build_state_instr_spec {| scmd := Istore (AA a e) d e' :: c; rmap := r; mmap := m; ms := ms |} vs
                     (Dstore a (sem_expr_spec {| scmd := Istore (AA a e) d e' :: c; rmap := r; mmap := m; ms := ms |} e))
                      {| scmd := c;
                         rmap := r;
                         mmap := update_mem m a
                                 (sem_expr_spec {| scmd := Istore (AA a e) d e' :: c; rmap := r; mmap := m; ms := ms |}  e)
                                 (declassify_val_spec d
                                 (sem_expr_spec {| scmd := Istore (AA a e) d e' :: c; rmap := r; mmap := m; ms := ms |} e') vs);
                         ms := ms |}
| build_next_if : forall e1 e2 i1 i2 bop bf c r m ms vs,
                  build_state_instr_spec {| scmd := Iif (Ebool bop e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := ms |} vs
                  (Dforce bf)
                  {| scmd := (if bf then i1 else i2) ++ c;
                     rmap := r;
                     mmap := m;
                     ms := if (eval_bool_op bop
                               (sem_expr_spec {| scmd := Iif (Ebool bop e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := ms |} e1)
                               (sem_expr_spec {| scmd := Iif (Ebool bop e1 e2) i1 i2 :: c; rmap := r; mmap := m; ms := ms |} e2)) == bf
                           then ms
                           else true |}
| build_next_protect : forall x y c r m ms vs,
                       build_state_instr_spec {| scmd := Iprotect x y :: c; rmap := r; mmap := m; ms := ms |} vs
                       Dstep
                       {| scmd := c;
                          rmap := if ms
                                  then update_rmap r x 0
                                  else update_rmap r x (r y);
                          mmap := m;
                          ms := ms |}.

(*Inductive build_c_leakage_spec : state -> seq (seq (option value)) -> seq (seq leakage) -> Prop :=
| build_leakage_empty_c_vs : forall r m ms,
                             build_c_leakage_spec {| scmd := [::]; rmap := r; mmap := m; ms := ms |} [::] [::]
| build_leakage_seq_c_vs   : forall i c r m ms d v vs s' ls,
                             build_state_instr_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |} v d s' ->
                             build_c_leakage_spec s' vs ls ->
                             build_c_leakage_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |} (v :: vs)
                             ((build_i_leakage_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |}  v) :: ls)
| build_leakage_empty_c_seq_vs : forall r m ms vs,
                                 build_c_leakage_spec {| scmd := [::]; rmap := r; mmap := m; ms := ms |} vs [::]
| build_leakage_seq_c_empty_vs : forall i c r m ms,
                                 build_c_leakage_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |} [::] [::].*)

Inductive build_c_leakage_spec : state -> seq (seq (option value)) -> seq directive -> seq (seq leakage) -> Prop :=
| build_leakage_empty_c_vs : forall r m ms,
                             build_c_leakage_spec {| scmd := [::]; rmap := r; mmap := m; ms := ms |} [::] [::] [::]
| build_leakage_seq_c_vs   : forall i c r m ms d ds v vs s' l ls,
                             build_i_leakage_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |}  v = l ->
                             build_state_instr_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |} v d s' ->
                             build_c_leakage_spec s' vs ds ls ->
                             build_c_leakage_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |} (v :: vs) (d :: ds)
                             (l :: ls)
| build_leakage_empty_c_seq_vs : forall r m ms vs,
                                 build_c_leakage_spec {| scmd := [::]; rmap := r; mmap := m; ms := ms |} vs [::] [::]
| build_leakage_seq_c_empty_vs : forall i c r m ms,
                                 build_c_leakage_spec {| scmd := i :: c; rmap := r; mmap := m; ms := ms |} [::] [::] [::].

Lemma declassify_mem_to_leakage_spec : forall VGamma AGamma c,
type_cmd VGamma AGamma c ->
(forall s1 s2 ov,
   c = s1.(scmd) ->
   state_equiv_spec s1 s2 VGamma AGamma ->
   build_i_leakage_spec s1 ov = build_i_leakage_spec s2 ov).
Proof.
move=> VGamma AGamma c hty.
move=> [] c1 r1 m1 ms1 [] c2 r2 m2 ms2 ov /= hc /= hequiv /=; subst.
move: hequiv=> [] /= hc hms hr hm; subst. rewrite /= in hty.
elim: hty; last first. + by auto.
move=> i c htyi htyc hrec. move: r1 m1 r2 m2 hr hm hrec.
induction htyi.
(* empty *)
+ by move=> r1 m1 r2 m2 hr hm hrec /=.
(* x := e *)
+ by move=> r1 m1 r2 m2 hr hm hrec /=.
(* x := a[e] *)
+ move=> r1 m1 r2 m2 hr hm hrec /=. case: a H0=> //=.
  move=> x' e htya. inversion htya; subst.
  have hpub : Public = Public. + by auto.
  rewrite /build_i_leakage_spec /=.
  have hequiv : state_equiv_spec {| scmd := Iload x d (AA x' e) :: c; rmap := r1; mmap := m1; ms := ms2 |}
                {| scmd := Iload x d (AA x' e) :: c; rmap := r2; mmap := m2; ms := ms2 |} VGamma AGamma.
  + by auto.
  have hms : sub_vlevel Public (public_ms (ms
              {| scmd := Iload x d (AA x' e) :: c; rmap := r1; mmap := m1; ms := ms2 |})).
  + by auto.
  by have -> := expr_equiv_val hequiv H5 hms.
(* a[e] := e *)
+ move=> r1 m1 r2 m2 hrec hm hr. case: a H0=> //=.
  move=> x' ei htya. inversion htya; subst.
  have hpub : Public = Public. + by auto.
  rewrite /build_i_leakage_spec /=.
  have hequiv : state_equiv_spec {| scmd := Istore (AA x' ei) d e :: c; rmap := r1; mmap := m1; ms := ms2 |}
                {| scmd := Istore (AA x' ei) d e :: c; rmap := r2; mmap := m2; ms := ms2 |} VGamma AGamma.
  + by auto.
  have hms : sub_vlevel Public (public_ms (ms
              {| scmd := Istore (AA x' ei) d e :: c; rmap := r1; mmap := m1; ms := ms2 |})).
  + by auto.
  by have -> := expr_equiv_val hequiv H5 hms.
(* if e i i' *)
+ move=> r1 m1 r2 m2 hr hm hrec /=. case: b H=> //= b' e e' hty.
  inversion hty; subst. apply union_public_eq in H5.
  case H5=> h5 h6; subst. case: H5=> hpub _.
  rewrite /build_i_leakage_spec /=.
  have hequiv : state_equiv_spec {| scmd := Iif (Ebool b' e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |}
                {| scmd := Iif (Ebool b' e e') i i' :: c; rmap := r2; mmap := m2; ms := ms2 |} VGamma AGamma.
  + by auto.
  have hms : sub_vlevel Public (public_ms (ms
              {| scmd := Iif (Ebool b' e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |})).
  + by auto.
  have -> := expr_equiv_val hequiv H3 hms. by have -> := expr_equiv_val hequiv H6 hms.
(* protect *)
move=> r1 m1 r2 m2 hr hm hrec /=.
by rewrite /build_i_leakage_spec /=.
Qed.

Lemma declassify_to_leakage_i_spec :
forall s1 s1' d l c,
 c = s1.(scmd) ->
 sem_instr_spec s1 d l s1' ->
 build_i_leakage_spec s1 (extract_declassify_leakages_spec l) = l.
Proof.
move=> s1 s1' d l c. case: s1=> c1 r1 m1 ms /= hc; subst.
case: c1=> //=.
+ move=> hsem. by inversion hsem; subst; (try discriminate).
move=> [].
+ move=> c /=.
(* empty *)
+ move=> hsem. inversion hsem; subst; (try discriminate).
  by rewrite /build_i_leakage_spec /extract_declassify_leakages_spec /=.
(* assgn *)
+ move=> x d' e c hsem. inversion hsem; subst; (try discriminate).
  case: H=> h1 h2 h3 h4; subst.
  rewrite /build_i_leakage_spec /=. by case: d0 hsem=> hsem /=.
(* load *)
+ move=> x d' a c hsem. inversion hsem; subst; (try discriminate).
  case: H=> h1 h2 h3 h4; subst.
  rewrite /build_i_leakage_spec /=. by case: d0 hsem=> hsem /=.
(* store *)
+ move=> x d' a c hsem. inversion hsem; subst; (try discriminate).
  case: H=> h1 h2 h3 h4; subst.
  rewrite /build_i_leakage_spec /=. by case: d0 hsem=> hsem /=.
(* cond *)
+ move=> b c c1' c2' hsem. inversion hsem; subst; (try discriminate).
  case: H=> h1 h2 h3 h4; subst. by rewrite /build_i_leakage_spec /=.
(* protect *)
move=> x y c hsem. inversion hsem; subst; (try discriminate).
case: H=> h1 h2 h3; subst. by rewrite /build_i_leakage_spec /=.
Qed.

Lemma build_empty_c_leakage : forall r1 m1 ms1 ov,
build_c_leakage_spec {| scmd := [::]; rmap := r1; mmap := m1; ms := ms1 |} ov [::] [::].
Proof.
move=> r1 m1 ms1 ov /=. case: ov=> //=.
+ by constructor.
move=> v vs /=. by constructor.
Qed.

Lemma build_empty_dvalue_leakage : forall s1,
build_c_leakage_spec s1 [::] [::] [::].
Proof.
move=> s1. case: s1=> //=.
move=> c r m ms /=. case: c=> //=.
+ by constructor.
move=> v vs /=. by constructor.
Qed.

Lemma step_declassify_state_equiv_spec : forall VGamma AGamma c s1 s2 d ov s1' s2',
type_cmd VGamma AGamma c ->
s1.(scmd) = c ->
state_equiv_spec s1 s2 VGamma AGamma ->
build_state_instr_spec s1 ov d s1' ->
build_state_instr_spec s2 ov d s2' ->
state_equiv_spec s1' s2' VGamma AGamma.
Proof.
move=> VGamma AGamma c [] st1 r1 m1 ms1 [] st2 r2 m2 ms2 dir ov s1' s2' /= hty hc hequiv.
have hequiv' := hequiv.
move: hequiv=> [] /= hst hms hr hm.
move: r1 m1 ms1 r2 m2 ms2 dir ov s1' s2' hms hr hm hequiv'; subst.
induction hty; subst.
+ induction H; rewrite /=.
  (* Iempty *)
  + move=> r1 m1 ms1 r2 m2 ms2 dir ov s1' s2' hms hr hm hequiv' hb1 hb2.
    inversion hb1; (try discriminate); subst.
    inversion hb2; (try discriminate); subst.
    by apply st_equiv_spec.
(* x := e *)
+ move=> r1 m1 ms1 r2 m2 ms2 dir ov s1 s2' hms hr hm hequiv' hb1 hb2 /=.
  inversion hb1; (try discriminate); subst.
  inversion hb2; (try discriminate); subst.
  apply st_equiv_spec.
  + by auto.
  + by auto.
  + case: d H1 IHhty hequiv' hb1 hb2 => //=.
    + case: T H=> //=.
      (* x is secret *)
      + move=> hx _ IHhty hequiv' hb1 hb2 x' hx' /=.
        rewrite /update_rmap /update_map. case: ifP=> /=.
        + by move=> hxeq.
        move=> hxneq. by move: (hr x' hx').
      (* x is publicload *)
      move=> hx _ IHhty hequiv' hb1 hb2 x' hx' /=.
      rewrite /update_rmap /update_map /=. case: ifP=> //=.
      move=> hneq. by move: (hr x' hx').
    (* d is false *)
    move=> H1 IHhty hequiv' hb1 hb2 x' hx' /=.
    rewrite /update_rmap /update_map. case: ifP=> //=.
    + move=> hxeq. apply eqb_eq in hxeq; subst.
      rewrite H in hx'. case: hx'=> hx''; subst.
      apply sub_public_always_public in H1; subst. have hpub : Public = Public. + by auto.
      by have /= := expr_equiv_val_public {| scmd := Iassgn x' false e :: c; rmap := r1; mmap := m1; ms := ms2 |}
              {| scmd := Iassgn x' false e :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H0 hpub.
    move=> hxneq. by move: (hr x' hx').
  (* no speculation *)
  move=> /= hms'. case: d H1 IHhty hequiv' hb1 hb2 => //=.
  + case: T H=> //=.
    (* x is secret *)
    + move=> hx _ IHhty hequiv' hb1 hb2 /=. split=> //=.
      + rewrite /update_rmap /update_map /=. move=> x' hx'.
        case: ifP=> //=. move=> hneq. move: (hm hms')=> [] hr' hm'.
        by move: (hr' x' hx').
      move=> a ha. move: (hm hms')=> [] hr' hm'. by move: (hm' a ha).
    (* x is publicload *)
    + move=> hx _ IHhty hequiv' hb1 hb2 /=. split=> //=.
      + move=> x' hx'. rewrite /update_rmap /update_map. case: ifP=> //=.
        + move=> hneq. move: (hm hms')=> [] hr' hm'.
        by move: (hr' x' hx').
      move=> a ha. move: (hm hms')=> [] hr' hm'. by move: (hm' a ha).
  move=> H1 IHhty hequiv'. split=> //=.
  + move=> x' hx'. rewrite /update_rmap /update_map. case: ifP=> //=.
    + move=> hxeq. apply eqb_eq in hxeq; subst. rewrite H in hx'.
      case: hx'=> [] ht; subst. apply sub_publicload_public in H1; subst.
      case: H1.
      + move=> H1; subst. have hpub : Public = Public. + by auto.
        by have /= := expr_equiv_val_public {| scmd := Iassgn x' false e :: c; rmap := r1; mmap := m1; ms := ms2 |}
              {| scmd := Iassgn x' false e :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H0 hpub.
      have hsub : sub_vlevel PublicLoad
     (public_ms (ms {| scmd := Iassgn x' false e :: c; rmap := r1; mmap := m1; ms := ms2 |})) .
      + rewrite /public_ms. by case: ifP=> //=.
      move=> H1; subst. by have := expr_equiv_val hequiv' H0 hsub.
     move=> hxneq. move: (hm hms')=> [] hr' hm'. by move: (hr' x' hx').
  move=> a ha. move: (hm hms')=> [] hr' hm'. by move: (hm' a ha).
(* x := a[e] *)
+ move=> r1 m1 ms1 r2 m2 ms2 dir ov s1' s2' hms hr hm hequiv' hb1 hb2 /=.
  case: a H0 IHhty hequiv' hb1 hb2=> //=.
  move=> x' ei hta IHhty hequiv' hb1 hb2 /=.
  inversion hb1; (try discriminate); subst.
  inversion hb2; (try discriminate); subst.
  apply st_equiv_spec.
  + by auto.
  + by auto.
  + move=> x'' hr' /=. inversion hta; (try discriminate); subst.
    case: d H1 IHhty hequiv' hb1 hb2 H11 => //=.
    + case: T H=> //=.
      + move=> hx _ IHhty hequiv' /=.
        rewrite /update_rmap /update_map /=.
        case: ifP=> //=. move=> hneq. by move: (hr x'' hr').
      move=> hx _ IHhty hequiv' hb1 hb2 hei.
      rewrite /update_rmap /update_map /=. case: ifP=> //=.
      move=> hneq. by move: (hr x'' hr').
    move=> H1 IHhty hequiv'.
    rewrite /update_rmap /update_map. case: ifP=> //=.
    + move=> hxeq. apply eqb_eq in hxeq; subst. rewrite H in hr'. case: hr'=> h1; subst.
      apply  sub_public_always_public in H1. by case: T' hta H3 H1=> //=.
    move=> hneq. by move: (hr x'' hr').
  move=> /= hms1. case: d H1 IHhty hequiv' hb1 hb2 H11 => //.
  + move=> H1 IHhty hequiv' /=. split=> //=.
    + move=> x'' hx''. rewrite /update_rmap /update_map /=. case: ifP=> //=.
      move=> hneq. move: (hm hms1)=> [] hr' hm'. by move: (hr' x'' hx'').
    move=> a ha. move: (hm hms1)=> [] hr' hm'. by move: (hm' a ha).
  move=> H1 IHhty hequiv' /=. split=> //=.
  + move=> x'' hx''. rewrite /update_rmap /update_map /=. case: ifP=> //=.
    + move=> heq. move: (hm hms1)=> [] hr' hm'. apply eqb_eq in heq; subst.
      rewrite H in hx''. case: hx''=> h1; subst. inversion hta; (try discriminate); subst.
      rewrite H11 /=.
      apply sub_publicload_public in H1; subst. case: T' hta H3 H1=> //=.
      + by move=> haty hx'ty [] //=.
      move=> haty hx' [] //= _. move: (hm hms1)=> [] hr1 hm1. by move: (hm1 x' hx')=> ->.
    move=> hneq. move: (hm hms1)=> [] hr' hm'. by move: (hr' x'' hx'').
  move=> a ha. move: (hm hms1)=> [] hr' hm'. by move: (hm' a ha).
(* a[e] := e *)
+ move=> r1 m1 ms1 r2 m2 ms2 dir ov s1' s2' hms hr hm hequiv' hb1 hb2 /=.
  case: a H0 IHhty hequiv' hb1 hb2=> //=.
  move=> x' ei hta IHhty hequiv' hb1 hb2 /=.
  inversion hb1; (try discriminate); subst.
  inversion hb2; (try discriminate); subst.
  apply st_equiv_spec.
  + by auto.
  + by auto.
  + move=> x'' hr' /=. inversion hta; (try discriminate); subst.
    case: d H1 IHhty hequiv' hb1 hb2 H11=> //=.
    + case: T H=> //=.
      + move=> hx _ IHhty hequiv' /=. by move: (hr x'' hr').
        move=> H. case: T' hta H3=> //= hta H3 _ IHhty hequiv'. by move: (hr x'' hr').
      by move: (hr x'' hr').
    move=> H. case: T' hta H3=> //= hta H3 _ IHhty hequiv'. by move: (hr x'' hr').
    by move: (hr x'' hr').
    move=> H1 IHhty hequiv'. by move: (hr x'' hr').
  move=> /= hms1. split=> //=.
  + move=> x'' hx''. move: (hm hms1)=> [] hr' hm'. by move: (hr' x'' hx'').
  move=> a ha /=. case: d H1 IHhty hequiv' hb1 hb2 H11=> //=.
  + case: T' hta=> //= hta _ IHhty hequiv' /=.
    inversion hta; (try discriminate); subst.
    rewrite /update_mem /update_map /=. case: ifP=> //=.
    + move=> heq. apply eqb_eq in heq; subst.
      rewrite ha in H2. by case: H2.
    move=> hneq. move: (hm hms1)=> [] hr' hm'. by move: (hm' a ha).
  move=> hb1 hb2 heeq. rewrite /update_mem /update_map. case: ifP=> //=.
  + move=> heq. apply eqb_eq in heq; subst.
    move: (hm hms1)=> [] hr1 hm1. by move: (hm1 a ha)=> ->.
  move=> hneq. move: (hm hms1)=> [] hr1 hm1. by move: (hm1 a ha)=> ->.
  move=> H1 Ihhty hequiv' /=. move: (hm hms1)=> [] hr' hm'.
  rewrite /update_mem /update_map /=. case: ifP=> //=.
  + move=> heq. apply eqb_eq in heq; subst.
    move: (hm' a ha)=> ->. inversion hta; (try discriminate); subst.
    rewrite ha in H3. case: H3=> h3; subst.
    have hpub : Public = Public. + by auto.
    have -> := expr_equiv_val_public {| scmd := Istore (AA a ei) false e :: c; rmap := r1; mmap := m1; ms := ms2 |}
          {| scmd := Istore (AA a ei) false e :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H5 hpub.
    case: T H1 H=> //= _ H1.
    by have -> := expr_equiv_val_public {| scmd := Istore (AA a ei) false e :: c; rmap := r1; mmap := m1; ms := ms2 |}
          {| scmd := Istore (AA a ei) false e :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H1 hpub.
  move=> hb1 hb2 heeq. move: (hm hms1)=> [] hr1 hm1. move: (hm1 a ha)=> <-.
  have hsub : (sub_vlevel PublicLoad
     (public_ms
        (ms {| scmd := Istore (AA a ei) false e :: c; rmap := r1; mmap := m1; ms := ms2 |}))). + rewrite /public_ms /=. by case: ifP=> //=.
  by have -> := expr_equiv_val hequiv' H1 hsub.
 by move: (hm' a ha).
(* If b i i' *)
+ move=> r1 m1 ms1 r2 m2 ms2 dir ov s1' s2' hms hr hm hequiv' hb1 hb2 /=.
  case: b H0 H IHhty hequiv' hb1 hb2 => //=.
  move=> bop e e' hity hbty IHhty hequiv' hb1 hb2 /=.
  inversion hb1; (try discriminate); subst.
  inversion hb2; (try discriminate); subst.
  inversion hbty; (try discriminate); subst.
  apply union_public_eq in H4. case: H4=> h4 h5; subst.
  apply st_equiv_spec. + by auto.
  + rewrite /=. have hpub : Public = Public. + by auto.
    have -> := expr_equiv_val_public {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |}
            {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H2 hpub.
    by have -> := expr_equiv_val_public {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |}
            {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H5 hpub.
  + move=> x hx /=. by move: (hr x hx).
  + move=> /= hms'. split=> //=.
    + move=> x hx. have hpub : Public = Public. + by auto.
    have he := expr_equiv_val_public {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |}
            {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H2 hpub.
    have he' := expr_equiv_val_public {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |}
            {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H5 hpub.
    rewrite he he' /= in hms'. move: hms'. case: ifP=> //= heval hms'.
    move: (hm hms')=> [] hr' hm'. by move: (hr' x hx).
  move=> a ha.  have hpub : Public = Public. + by auto.
  have he := expr_equiv_val_public {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |}
            {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H2 hpub.
  have he' := expr_equiv_val_public {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r1; mmap := m1; ms := ms2 |}
            {| scmd := Iif (Ebool bop e e') i i' :: c; rmap := r2; mmap := m2; ms := ms2 |} hr H5 hpub.
  rewrite he he' /= in hms'. move: hms'. case: ifP=> //= heval hms'. move: (hm hms')=> [] hr' hm'.
  by move: (hm' a ha).
(* Protect x y *)
+ move=> r1 m1 ms1 r2 m2 ms2 ov dir s1' s2' hms hr hm hequiv' hb1 hb2 /=.
  inversion hb1; (try discriminate); subst.
  inversion hb2; (try discriminate); subst.
  apply st_equiv_spec.
  + by auto.
  + by auto.
  + move=> x' hx' /=. case: ms2 hm hequiv' hb1 hb2=> //=.
    + move=> hms hm hequiv'; subst.
      rewrite /update_rmap /update_map. case: ifP=> //=.
      move=> hneq. by move: (hr x' hx').
    move=> hms hm hequiv'; subst. rewrite /update_rmap /update_map /=.
    case: ifP=> //=.
    + move=> heq. apply eqb_eq in heq; subst. apply sub_publicload_public in H1; subst.
      case: H1=> //=.
      + move=> H1; subst. by move: (hr y H0).
      move=> H1; subst. have ht : ~false. + by auto.
      move: (hms ht)=> [] hr1 hm1. by move: (hr1 y H0).
    move=> hneq. by move: (hr x' hx').
  move=> /= hms1. split=> //=.
  + move=> x' hx'. case: ifP=> //=.
    + move=> hms1'; subst. move: (hm hms1)=> [] hr' hm'.
      rewrite /update_rmap /update_map. case: ifP=> //=.
      + move=> heq. apply eqb_eq in heq; subst. apply sub_publicload_public in H1; subst.
        case: H1=> //=.
        + move=> H1; subst. by move: (hr y H0).
        move=> H1; subst. by move: (hr' y H0).
      move=> hneq. by move: (hr' x' hx').
    move=> a ha. move: (hm hms1)=> [] hr' hm'. by move: (hm' a ha).
move=> r1 m1 ms1 r2 m2 ms2 dir ov /= s1' s2' hms hr hm hequiv hb1 hb2 /=; subst.
by inversion hb1; (try discriminate); subst.
Qed.

Lemma st_show_spec : forall s,
{| scmd := scmd s; rmap := rmap s; mmap := mmap s; ms := ms s |} = s.
Proof.
move=> s. by case: s.
Qed.

Lemma step_to_build_state_spec : forall s d l s',
sem_instr_spec s d l s' ->
build_state_instr_spec s (extract_declassify_leakages_spec l) d s'.
Proof.
move=> [] c r1 m1 ms1 d l s' hstep.
case: c hstep=> //=.
+move=> hstep. by inversion hstep; (try discriminate); subst.
move=> i c hstep. case: i hstep=> //=.
(* Iempty *)
+ move=> hstep. inversion hstep; (try discriminate); subst; rewrite /=.
  inversion H; (try discriminate); subst. by constructor.
(* x := e *)
+ move=> x d' e hstep. case: d' hstep=> //=.
  + move=> hstep. inversion hstep; (try discriminate); subst.
    case: d0 hstep H=> //= hstep [] h1 h2 h3; subst. by constructor.
  move=> hstep. inversion hstep; (try discriminate); subst; rewrite /=.
  case: d0 hstep H=> //= hstep [] h1 h2 h3; subst. by constructor.
(* x := a[e] *)
+ move=> x d' a hstep. case: d' hstep=> //=.
  + move=> hstep. inversion hstep; (try discriminate); subst.
    case: d0 hstep H=> //= hstep [] h1 h2 h3; subst. by constructor.
  move=> hstep. inversion hstep; (try discriminate); subst; rewrite /=.
  case: d0 hstep H=> //= hstep [] h1 h2 h3; subst. by constructor.
(* a[e] := e *)
+ move=> x d' e hstep. case: d' hstep=> //=.
  + move=> hstep. inversion hstep; (try discriminate); subst.
    case: d0 hstep H=> //= hstep [] h1 h2 h3; subst. by constructor.
  move=> hstep. inversion hstep; (try discriminate); subst; rewrite /=.
  case: d0 hstep H=> //= hstep [] h1 h2 h3; subst. by constructor.
(* if b i i' *)
+ move=> b i i' hstep. case: b hstep=> //= bop e e' hstep.
  inversion hstep; (try discriminate); subst; rewrite /=.
  inversion H; (try discriminate); subst.
  by apply build_next_if.
(* protect x y *)
move=> x y hstep /=. inversion hstep; (try discriminate); subst; rewrite /=.
inversion H; (try discriminate); subst. by constructor.
Qed.

Lemma preservation_without_semantic_spec : forall VGamma AGamma s ov d s',
type_cmd VGamma AGamma s.(scmd) ->
build_state_instr_spec s ov d s' ->
type_cmd VGamma AGamma s'.(scmd).
Proof.
move=> VGamma AGamma [] c r m ms ov d s' /= hty hnext.
case: c hty hnext=> //=.
+ move=> hty hnext. by inversion hnext; (try discriminate); subst.
move=> i c hi hnext.
case:i hi hnext=> //=.
+ move=> hi hnext. inversion hnext; (try discriminate); subst; rewrite /=.
  by inversion hi; (try discriminate); subst.
+ move=> x d' e hi hnext. inversion hnext; (try discriminate); subst; rewrite /=.
  by inversion hi; (try discriminate); subst.
+ move=> x d' a hi hnext. inversion hnext; (try discriminate); subst; rewrite /=.
  by inversion hi; (try discriminate); subst.
+ move=> a d' e hi hnext. inversion hnext; (try discriminate); subst; rewrite /=.
  by inversion hi; (try discriminate); subst.
+ move=> b i i' hi hnext. inversion hnext; (try discriminate); subst; rewrite /=.
  inversion hi; (try discriminate); subst. inversion H1; (try discriminate); subst.
  apply type_concat=> //=. by case: ifP.
move=> x y hi hnext. inversion hnext; (try discriminate); subst; rewrite /=.
by inversion hi; (try discriminate); subst.
Qed.

Lemma declassify_mem_to_leakages : forall VGamma AGamma c,
type_cmd VGamma AGamma c ->
(forall s1 s2 ov ls1 ls2 ds,
   c = s1.(scmd) ->
   state_equiv_spec s1 s2 VGamma AGamma ->
   build_c_leakage_spec s1 ov ds ls1 ->
   build_c_leakage_spec s2 ov ds ls2 ->
   ls1 = ls2).
Proof.
move=> VGamma AGamma c hty.
move=> [] c1 r1 m1 ms1 [] c2 r2 m2 ms2 ov ls1 ls2 ds hc hequiv /=; subst.
move: hequiv=> [] /= hst /= hms hr hm; subst. rewrite /= in hty.
move: c2 r1 m1 r2 m2 ls1 ls2 ds ms2 hm hr hty.
induction ov.
(* ov = [::] *)
+ move=> c2 r1 m1 r2 m2 ms2 hm hr hty.
  case: c2 hm hr hty=> //=.
  + move=> ls1 ls2 ds hm hr hty h1 h2.
    inversion h1; (try discriminate); subst. + by inversion h2; (try discriminate); subst.
    + by inversion h2; (try discriminate); subst.
  move=> i c ls1 ls2 ds hm hr hty h1 h2. inversion h1; (try discriminate); subst.
  by inversion h2; (try discriminate); subst.
move=> c2 r1 m1 r2 m2 ls1 ls2 ds hm hr hty.
case: c2 hm hr hty=> /=.
(* empty seq of instructions *)
+ move=> hms hm hr hty h1 h2. inversion h1; (try discriminate); subst. by inversion h2; (try discriminate); subst.
(* i :: c *)
move=> i c ms hm hr /= hty h1 h2; rewrite /=. have h1' := h1. have h2' := h2.
inversion h1; (try discriminate); subst. inversion h2; (try discriminate); subst.
have heq : scmd {| scmd := i :: c; rmap := r1; mmap := m1; ms := ms |} = i :: c. + by auto.
have heq' : i :: c = scmd {| scmd := i :: c; rmap := r1; mmap := m1; ms := ms |}. + by auto.
have hequiv : state_equiv_spec {| scmd := i :: c; rmap := r1; mmap := m1; ms := ms |}
              {| scmd := i :: c; rmap := r2; mmap := m2; ms := ms |} VGamma AGamma.
+ apply st_equiv_spec; by auto.
have hsteq := step_declassify_state_equiv_spec.
move: (hsteq VGamma AGamma (i::c) {| scmd := i :: c; rmap := r1; mmap := m1; ms := ms |}
{| scmd := i :: c; rmap := r2; mmap := m2; ms := ms |} d a s' s'0 hty heq hequiv H9 H12)=> hequiv'.
move: hequiv'=> [] hst hms hr' hm'. rewrite -heq in hty.
have hty' := preservation_without_semantic_spec hty H9.
case: s' H9 H10 hm' hst hms hr' hty'=> s1' r1' m1' ms1' H9 /= H10 /= hm' hst hms /= hr' hty'; subst.
case: s'0 H9 H10 H12 H13 hm' hr' hty'=> s2' r2' m2' ms2' H9 H10 H12 H13 /= hm' /= hr' hty'; subst. rewrite /= in H9.
move: (IHov s2' r1' m1' r2' m2' ls ls0 ds0 ms2' hm' hr' hty' H10 H13)=> ->.
by have -> := declassify_mem_to_leakage_spec hty a heq' hequiv.
Qed.

Lemma declassify_to_leakage_c : forall VGamma AGamma c,
type_cmd VGamma AGamma c ->
(forall s1 s1' n d l,
 c = s1.(scmd) ->
 multi_step_spec s1 d l n s1' ->
 build_c_leakage_spec s1 (extract_declassify_leakagess_spec l) d l).
Proof.
move=> VGamma AGamma c /= hty.
move=> [] c1 r1 m1 ms1 s1' n d l hc hmulti; subst.
move: c1 r1 m1 ms1 s1' d l hmulti hty.
induction n.
(* n = 0 *)
+ move=> c1 r1 m1 ms1 s1' d l hmulti hty /=.
  (* 0 step means s1 = s1' and no leakage [::] *)
  inversion hmulti; (try discriminate); subst; rewrite /=.
  + case: c1 hmulti hty. + move=> hmulti hty. by constructor.
  move=> i c hmulti hty. by constructor.
  by case: (n) H=> //=.
(* n != 0 *)
move=> c1 r1 m1 ms1 s1' d l hmulti hty.
rewrite -addn1 in hmulti.
inversion hmulti; (try discriminate); subst.
(* empty leakage *)
+ by case: n H3 IHn hmulti=> //=.
(* non-empty leakage *)
case: c1 hty hmulti H0=> //=.
(* empty seq of instructions *)
+ move=> hty hmulti hsem.
  inversion hmulti; (try discriminate); subst.
  by inversion H8; (try discriminate); subst.
(* i :: c *)
move=> i c hty hmulti H0 /=.
inversion hmulti; (try discriminate); subst.
apply PeanoNat.Nat.add_cancel_r in H; rewrite H in H4.
apply PeanoNat.Nat.add_cancel_r in H8 ; subst.
have heq : i :: c = {| scmd := i :: c; rmap := r1; mmap := m1; ms := ms1 |}.(scmd). + by auto.
have heq' : {| scmd := i :: c; rmap := r1; mmap := m1; ms := ms1 |}.(scmd) = i :: c. + by auto.
have hnext : build_state_instr_spec {| scmd := i :: c; rmap := r1; mmap := m1; ms := ms1 |}
                   (extract_declassify_leakages_spec l0) d0 s'0.
+ by have := step_to_build_state_spec H9.
have hi := declassify_to_leakage_i_spec heq H9.
rewrite heq in hty.
have hty' := preservation_without_semantic_spec hty hnext.
apply build_leakage_seq_c_vs with s'0.
+ by apply hi.
+ by apply hnext.
case: s'0 H9 H10 hnext hty'=> //= s2 r2 m2 ms H9 H10 hnext hty'.
by move: (IHn s2 r2 m2 ms s1' d' l' H10 hty').
Qed.

Lemma type_declassify_ct_to_ct_spec : forall VGamma AGamma s1 s2,
type_cmd VGamma AGamma s1.(scmd) /\ constant_time_declassify_spec VGamma AGamma s1 s2 ->
constant_time_spec VGamma AGamma s1 s2.
Proof.
move=> VGamma AGamma s1 s2 hty. rewrite /constant_time_spec /=.
case: hty=> [] hty hdeclassify. rewrite /constant_time_declassify_spec in hdeclassify.
move=> s1' s2' d l1 l2 n hequiv hmulti hmulti'.
move: (hdeclassify s1' s2' d l1 l2 n hequiv hmulti hmulti')=> [] hdeq hsafe {hdeclassify}.
split; last by split=> //= hst; apply safe_lang.
move: s1 s2 d l1 l2 hmulti hmulti' hequiv hty hdeq.
induction n.
(* n = 0 *)
+ move=> s1 s2 d l1 l2 hmulti hmulti' hequiv hty hdeq.
  inversion hmulti; (try discriminate); subst.
  inversion hmulti'; (try discriminate); subst; auto.
  by case:(n) H.
move=> s1 s2 d l1 l2 hmulti hmulti' hequiv hty hdeq.
inversion hmulti; (try discriminate); subst.
inversion hmulti'; (try discriminate); subst; auto.
have hd:= declassify_to_leakage_i_spec. have heq : forall s, scmd s = scmd s. + by auto.
move: (hd s1 s' d0 l (scmd s1) (heq s1) H0)=> <- /=.
have hequiv' := hequiv.
case: hequiv=> [] hst hms hr hm. rewrite hst in hty.
move: (hd s2 s'0 d0 l0 (scmd s2) (heq s2) H7)=> <- /=.
case: hdeq=> hd1 hds1. rewrite hd1.
rewrite addn1 in H5. case: H5=> h1; subst.
rewrite addn1 in H. case: H=> h; subst.
have hequiv'' := step_declassify_state_equiv_spec hty hst hequiv'.
have hs1eq := step_to_build_state_spec H0. rewrite hd1 in hs1eq.
have hs2eq := step_to_build_state_spec H7.
rewrite -hst in hty.
have hty' := preservation hty H0.
move: (hequiv'' d0 (extract_declassify_leakages_spec l0) s' s'0 hs1eq hs2eq)=> {hequiv''} hequiv''.
move: (IHn s' s'0 d' l' l'0 H4 H9 hequiv'' hty' hds1)=> ->.
by have -> := declassify_mem_to_leakage_spec hty (extract_declassify_leakages_spec l0) (heq s1) hequiv'.
Qed.


Require Import Util IL RenamedApart LabelsDefined OptionR.
Require Import Annotation Exp SetOperations Liveness.Liveness Restrict.

Set Implicit Arguments.

Lemma plus_minus_eq n m
  : n + m - n = m.
Proof.
  omega.
Qed.

Ltac inv_get_step_some_minus :=
  match goal with
  | [ H : get (?f ⊝ (?g1 ⊝ ?A) \\ (?g2 ⊝ ?B) ++ ?C) ?k _,
          H' : get ?A ?k _ |- _ ] =>
    eapply get_app_lt_1 in H; [| eauto 20 with len]
  | [ H : get (?f ⊝ (?g1 ⊝ ?A) \\ (?g2 ⊝ ?B) ++ ?C) ?k _,
          H' : get ?B ?k _ |- _ ] =>
    eapply get_app_lt_1 in H; [| eauto 20 with len]
  | [ H : get (?f ⊝ (?g1 ⊝ ?A) \\ (?g2 ⊝ ?B) ++ ?C) (❬?B❭ + ?n) _ |- _ ] =>
    let LENEQ := fresh "LenEq" in
    assert (LENEQ:❬f ⊝ (g1 ⊝ A) \\ (g2 ⊝ B)❭ = ❬B❭) by eauto with len;
    rewrite get_app_ge in H;
    [ rewrite LENEQ in H; rewrite plus_minus_eq in H
    | rewrite LENEQ; omega]
  | [ H : get (?f ⊝ (?g1 ⊝ ?A) \\ (?g2 ⊝ ?B) ++ ?C) (❬?A❭ + ?n) _ |- _ ] =>
    let LENEQ := fresh "LenEq" in
    assert (LENEQ:❬f ⊝ (g1 ⊝ A) \\ (g2 ⊝ B)❭ = ❬A❭) by eauto with len;
    rewrite get_app_ge in H;
    [ rewrite LENEQ in H; rewrite plus_minus_eq in H
    | rewrite LENEQ; omega]
  end.

Smpl Add inv_get_step_some_minus : inv_get.

(** * Definition of Coherence: [srd] *)

Inductive srd : list (option (set var)) -> stmt -> ann (set var) -> Prop :=
| srdExp DL x e s lv al
  : srd (restr (getAnn al \ singleton x) ⊝ DL) s al
    -> srd DL (stmtLet x e s) (ann1 lv al)
| srdIf DL e s t lv als alt
  : srd DL s als
    -> srd DL t alt
    -> srd DL (stmtIf e s t) (ann2 lv als alt)
| srdRet e DL lv
  : srd DL (stmtReturn e) (ann0 lv)
| srdGoto DL lv G' f Y
  : get DL (counted f) (Some G')
    -> srd DL (stmtApp f Y) (ann0 lv)
| srdLet DL F t lv als alt
  : length F = length als
    -> (forall n Zs a, get F n Zs -> get als n a ->
                 srd (restr (getAnn a \ of_list (fst Zs)) ⊝
                            (Some ⊝ (getAnn ⊝ als) \\ (fst ⊝ F) ++ DL)) (snd Zs) a)
    -> srd (Some ⊝ (getAnn ⊝ als) \\ (fst ⊝ F) ++ DL) t alt
    -> srd DL (stmtFun F t) (annF lv als alt).

(** ** Some monotonicity properties *)

Lemma srd_monotone (DL DL' : list (option (set var))) s a
 : srd DL s a
   -> PIR2 (fstNoneOrR Equal) DL DL'
   -> srd DL' s a.
Proof.
  intros. general induction H; eauto using srd.
  - econstructor.
    eapply IHsrd; eauto. eapply restrict_subset; eauto.
  - destruct (PIR2_nth H0 H); eauto; dcr. inv H3.
    econstructor; eauto.
  - econstructor; eauto.
    + intros. eapply H1; eauto.
      repeat rewrite List.map_app.
      eapply PIR2_app; eauto.
      eapply restrict_subset; eauto.
    + eapply IHsrd. eapply PIR2_app; eauto.
Qed.

Lemma srd_monotone2 (DL DL' : list (option (set var))) s a
 : srd DL s a
   -> PIR2 (fstNoneOrR (flip Subset)) DL DL'
   -> srd DL' s a.
Proof.
  intros. general induction H; eauto using srd.
  - econstructor.
    eapply IHsrd; eauto. eapply restrict_subset2; eauto.
  - destruct (PIR2_nth H0 H); eauto; dcr. inv H3.
    econstructor; eauto.
  - econstructor; eauto.
    + intros. eapply H1; eauto.
      repeat rewrite List.map_app.
      eapply PIR2_app; eauto.
      eapply restrict_subset2; eauto.
    + eapply IHsrd. eapply PIR2_app; eauto.
Qed.


Set Primitive Projections.

Axiom I : Set.
Axiom O : I -> SProp.
Definition ℙ := forall i : I, O i.

Inductive seq {A : Type} (x : A) : A -> SProp := srefl : @seq A x x.

Axiom uip : forall A (x y : A), seq x y -> x = y.
Axiom uip₀ : forall A (x y : A) (p q : x = y), p = q.

Axiom sfunext : forall (A : SProp) (B : A -> Type) (f g : forall x, B x),
  (forall x, f x = g x) -> f = g.
Axiom funext : forall A (B : A -> Type) (f g : forall x, B x),
  (forall x, f x = g x) -> f = g.
Axiom pi : forall (A : Prop) (p q : A), p = q.

Record isSheaf (A : Type) := {
  shf_elt : forall i : I, (O i -> A) -> A;
  shf_spc : forall i (x : A), x = shf_elt i (fun _ => x);
}.

Arguments shf_elt {_}.
Arguments shf_spc {_}.

Module Import Sh.

Private Inductive Shf (A : Type) :=
| ret : A -> Shf A
| ask : forall i, (O i -> Shf A) -> Shf A.

Arguments ret {_}.
Arguments ask {_}.

Axiom eqn : forall {A} (i : I) (x : Shf A), ask i (fun _ => x) = x.

Fixpoint Shf_rect (A : Type) (P : Shf A -> Type)
  (ur : forall (x : A), P (ret x))
  (ua : forall (i : I) (k : O i -> Shf A),
    (forall o : O i, P (k o)) -> P (ask i k))
  (ue : forall (i : I) (x : Shf A) (px : P x),
    match eqn i x in _ = e return P e with eq_refl => ua i (fun _ => x) (fun _ => px) end = px)
  (x : Shf A) {struct x} :
  P x :=
match x with
| ret x => ur x
| ask i k => ua i k (fun o => Shf_rect A P ur ua ue (k o))
end.

Fixpoint Shf_sind (A : Type) (P : Shf A -> SProp)
  (ur : forall (x : A), P (ret x))
  (ua : forall (i : I) (k : O i -> Shf A),
    (forall o : O i, P (k o)) -> P (ask i k))
  (x : Shf A) {struct x} :
  P x :=
match x with
| ret x => ur x
| ask i k => ua i k (fun o => Shf_sind A P ur ua (k o))
end.

End Sh.

Inductive Shε {A} : (ℙ -> A) -> SProp :=
| retε : forall x : A, Shε (fun _ => x)
| askε : forall (i : I) (k : O i -> ℙ -> A),
  (forall o, Shε (k o)) -> Shε (fun α => k (α i) α)
.

Definition eval {A} (x : Shf A) (α : ℙ) : A.
Proof.
unshelve refine (
Shf_rect A (fun _ => A) (fun x => x) (fun i k r => r (α i)) _ x
).
{ clear; intros; destruct eqn; reflexivity. }
Defined.

Lemma evalε : forall A (x : Shf A), Shε (eval x).
Proof.
intros A x.
simple refine (
Shf_sind A (fun x => Shε (eval x)) _ _ x
); clear x; simpl.
+ intros x.
  apply (retε x).
+ intros i k kε.
  apply (askε i (fun o => eval (ask i k))).
  apply kε.
Qed.

Lemma eval_retract : forall A (x : Shf A) (α : ℙ),
  ret (eval x α) = x.
Proof.
intros A x α.
apply uip.
refine (
Shf_sind A (fun x => seq (ret (eval x α)) x) _ _ x
); clear x; simpl.
+ reflexivity.
+ intros i k r.
  change (eval (ask i k) α) with (eval (k (α i)) α).
  change k with (fun _ : O i => k (α i)) at 2.
  rewrite eqn.
  apply r.
Qed.

Section Permut.

Variable A : Type.
Variable i j : I.
Variable k : O i -> O j -> Shf A.

Lemma permut_equiv :
  ask i (fun o => ask j (fun q => k o q)) = ask j (fun q => ask i (fun o => k o q)).
Proof.
match goal with [ |- ?p = ?q ] => rewrite <- (eqn i q) end.
f_equal; apply sfunext; intros o.
f_equal; apply sfunext; intros q.
change (fun o' => k o' q) with (fun _ : O i => k o q).
rewrite eqn; reflexivity.
Qed.

End Permut.

Inductive inhabited (A : Type) : SProp := inhabits : A -> inhabited A.

Definition unique_choice :=
  forall (A : Type) (hA : forall x y : A, x = y), inhabited A -> A.

Definition choice := forall (A : Type), inhabited A -> A.

Section WithChoice.

Variable AC : choice.

Definition sreify {A : Type} (x : ℙ -> A) (xε : Shε x) :
  inhabited {x₀ : Shf A | eval x₀ = x }.
Proof.
induction xε.
+ constructor.
  exists (ret x); reflexivity.
+ constructor.
  unshelve eexists.
  - refine (ask i (fun o => _)).
    specialize (H o).
    apply AC in H.
    destruct H as [x₀ Hx].
    exact x₀.
  - simpl.
    apply sfunext; intros α.
    match goal with [ |- context [ask i ?k ] ] =>
      change k with (fun _ : O i => k (α i))
    end; simpl.
    rewrite eqn.
    destruct AC.
    rewrite e; reflexivity.
Defined.

Definition reify {A : Type} (x : ℙ -> A) (xε : Shε x) :=
  proj1_sig (AC _ (@sreify A x xε)).

Lemma eval_reify : forall (A : Type) (x : ℙ -> A) (xε : Shε x),
  eval (reify x xε) = x.
Proof.
intros A x xε.
unfold reify.
destruct AC as [y hy]; simpl; assumption.
Qed.

Lemma reify_eval : forall (A : Type) (x : Shf A),
  reify (eval x) (evalε _ x) = x.
Proof.
intros A x.
apply uip.
simple refine (
Shf_sind A (fun x => seq (reify (eval x) (evalε A x)) x) _ _ x
); clear x; simpl.
+ intros x.
  unfold reify.
  destruct AC as [y hy]; simpl in *.

Abort.

End WithChoice.

Lemma unique_eval_ret : forall A (p : Shf A) (x : A),
  eval p = (fun _ : ℙ => x) -> p = ret x.
Proof.
intros A p x e.
apply uip.
revert x e.
refine (Shf_sind A (fun p => forall x, eval p = (fun _ => x) -> seq p (ret x)) _ _ p); clear p.
+ intros x₀ x e.
  unfold eval in e.
  cbn in *.
Admitted.

Lemma unique_eval_inv : forall A (x : ℙ -> A) (xε : Shε x)
  (p q : {x₀ : Shf A | eval x₀ = x }), p = q.
Proof.
intros A x xε [p hp] [q hq].
cut (p = q).
+ intros e; revert hq; destruct e; intros hq.
  assert (e : hp = hq) by apply uip₀.
  destruct e; reflexivity.
+ apply uip.
  revert p x xε hp q hq.
  refine (Shf_sind A _ _ _).
  - intros x₀ x xε hp q hq.
    compute in hp.
    revert q x₀ x xε hp hq.
    refine (Shf_sind A _ _ _).
    * intros x₁ x₂ x xε hp hq.
      compute in hq.
      revert x₁ x₂ hp hq.
      induction xε; intros x₁ x₂ hp hq.

Admitted.

Definition sreify {A : Type} {U : unique_choice} (x : ℙ -> A) (xε : Shε x) :
  inhabited {x₀ : Shf A | eval x₀ = x }.
Proof.
induction xε.
+ constructor.
  exists (ret x); reflexivity.
+ constructor.
  unshelve eexists.
  - refine (ask i (fun o => _)).
    specialize (H o).
    apply U in H; [|intros; apply unique_eval_inv, s].
    destruct H as [x₀ Hx].
    exact x₀.
  - simpl.
    apply sfunext; intros α.
    match goal with [ |- context [ask i ?k ] ] =>
      change k with (fun _ : O i => k (α i))
    end; simpl.
    rewrite eqn.
    destruct U.
    rewrite e; reflexivity.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import approx_star0.

Lemma extensional_cantest {p} : forall a, extensional_op (@NCan p (NCanTest a)).
Proof.
  introv Hpra Hprt Hprt' Hcv Has Hi.
  applydup @compute_decompose_aux in Hcv; auto; exrepnd.

  repndors; exrepnd; [|allsimpl; subst; repnd; complete ginv].

  assert (m <= S k) as XX by omega.
  repnud Hcv.
  eapply reduces_atmost_split in XX; eauto.
  remember (S k - m) as skm.
  destruct skm; [omega|].
  assert (skm <= k) by (subst; omega).
  apply reduces_atmost_S in XX; exrepnd.
  applydup @reduces_atmost_preserves_program in Hcv4; auto.
  allapply @isprogram_cantest_implies; exrepnd; subst; cpx.

  unfold lblift_sub in Has; simpl in Has; repnd; GC.
  repeat(approxrelbtd); show_hyps.
  allapply @approx_star_bterm_nobnd2.

  apply no_change_after_val_like with (k2:=k) in Hcv3; auto; [].
  make_red_val_like Hcv3 h1.
  apply (Hi _ _ a2) in h1; auto; prove_isprogram;[].

  extensional_ind XX0 k hh.

  dorn Hcv0.

  - apply iscan_implies in Hcv0; repndors; exrepnd; subst;
    csunf XX1; allsimpl; ginv.

    { apply (Hi _ _ (if canonical_form_test_for a c1 then b0 else c0)) in hh;
        auto; prove_isprogram;
        try (complete (destruct (canonical_form_test_for a c1); auto));
        eauto 2 with slow.
      apply howe_lemma2 in h1; exrepnd; auto; prove_isprogram.

      apply @approx_star_open_trans with (b := if canonical_form_test_for a c1 then b0 else c0); auto.
      apply approx_implies_approx_open.
      apply @approx_trans with (b := oterm (NCan (NCanTest a)) [nobnd (oterm (Can c1) lbt'),nobnd b0,nobnd c0]).
      apply reduces_to_implies_approx_eauto; prove_isprogram.
      apply reduces_to_if_step; reflexivity.
      apply reduces_to_implies_approx_eauto; prove_isprogram.
      apply reduces_to_prinarg; auto; destruct h0; auto.
    }

    { apply howe_lemma2_seq in h1; exrepnd; auto.
      apply (Hi _ _ c0) in hh; auto.
      eapply approx_star_open_trans;[exact hh|clear hh].
      apply approx_implies_approx_open.
      apply reduces_to_implies_approx_eauto; prove_isprogram.
      eapply reduces_to_trans;[apply reduces_to_prinarg;eauto|].
      apply reduces_to_if_step.
      csunf; simpl; auto.
    }

  - apply isexc_implies in Hcv0; auto; exrepnd; subst.
    csunf XX1; allsimpl; ginv.
    apply reduces_atmost_exc in XX0; subst.
    apply howe_lemma2_exc in h1; exrepnd; auto; prove_isprogram.

    apply @approx_star_open_trans with (b := mk_exception a' e').
    apply approx_star_exception; auto.
    apply approx_implies_approx_open.
    apply computes_to_exception_implies_approx; auto; prove_isprogram.
    allrw @computes_to_exception_as_reduces_to.
    apply @reduces_to_trans with (b := oterm (NCan (NCanTest a)) [nobnd (mk_exception a' e'),nobnd b0,nobnd c0]).
    apply reduces_to_prinarg; auto.
    apply reduces_to_if_step; reflexivity.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/")
*** End:
*)


From Perennial.program_proof.mvcc Require Import
     txn_prelude
     txnmgr_repr tuple_repr index_proof wrbuf_repr.

Section repr.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

Definition own_txn_impl (txn : loc) (wrbuf : loc) (ts : nat) γ : iProp Σ :=
  ∃ (tid sid : u64) (idx txnmgr : loc) (p : proph_id),
    "Htid" ∷ txn ↦[Txn :: "tid"] #tid ∗
    (* This ensures we do not lose the info that [tid] does not overflow. *)
    "%Etid" ∷ ⌜int.nat tid = ts⌝ ∗
    "Hsid" ∷ txn ↦[Txn :: "sid"] #sid ∗
    "%HsidB" ∷ ⌜(int.Z sid) < N_TXN_SITES⌝ ∗
    "Hwrbuf"    ∷ txn ↦[Txn :: "wrbuf"] #wrbuf ∗
    "#Hidx" ∷ readonly (txn ↦[Txn :: "idx"] #idx) ∗
    "#HidxRI" ∷ is_index idx γ ∗
    "#Htxnmgr" ∷ readonly (txn ↦[Txn :: "txnMgr"] #txnmgr) ∗
    "#HtxnmgrRI" ∷ is_txnmgr txnmgr γ ∗
    "Hactive" ∷ active_tid γ tid sid ∗
    "#Hp" ∷ readonly (txnmgr ↦[TxnMgr :: "p"] #p) ∗
    "#Hinv" ∷ mvcc_inv_sst γ p ∗
    "_" ∷ True.

(* TODO: Unify [own_txn] and [own_txn_ready]. *)
Definition own_txn (txn : loc) (ts : nat) (view : dbmap) γ τ : iProp Σ :=
  ∃ (wrbuf : loc) (mods : dbmap),
    "Himpl"     ∷ own_txn_impl txn wrbuf ts γ ∗
    "#Hltuples" ∷ ([∗ map] k ↦ v ∈ view, ltuple_ptsto γ k v ts) ∗
    "Htxnmap"   ∷ txnmap_auth τ (mods ∪ view) ∗
    "%Hmodsdom" ∷ ⌜dom mods ⊆ dom view⌝ ∗
    "HwrbufRP"  ∷ own_wrbuf_xtpls wrbuf mods.

Definition own_txn_ready (txn : loc) (ts : nat) (view : dbmap) γ τ : iProp Σ :=
  ∃ (wrbuf : loc) (mods : dbmap) (tpls : gmap u64 loc),
    "Himpl"     ∷ own_txn_impl txn wrbuf ts γ ∗
    "#Hltuples" ∷ ([∗ map] k ↦ v ∈ view, ltuple_ptsto γ k v ts) ∗
    "Htxnmap"   ∷ txnmap_auth τ (mods ∪ view) ∗
    "%Hmodsdom" ∷ ⌜dom mods ⊆ dom view⌝ ∗
    "HwrbufRP"  ∷ own_wrbuf wrbuf mods tpls ∗
    "Htuples"   ∷ own_tuples_locked ts tpls γ.

(* TODO: Unify [own_txn_impl] and [own_txn_uninit]. *)
Definition own_txn_uninit (txn : loc) γ : iProp Σ :=
  ∃ (tid sid : u64) (wrbuf : loc) (idx txnmgr : loc) (p : proph_id) (mods : dbmap),
    "Htid" ∷ txn ↦[Txn :: "tid"] #tid ∗
    "Hsid" ∷ txn ↦[Txn :: "sid"] #sid ∗
    "%HsidB" ∷ ⌜(int.Z sid) < N_TXN_SITES⌝ ∗
    "Hwrbuf" ∷ txn ↦[Txn :: "wrbuf"] #wrbuf ∗
    "HwrbufRP" ∷ own_wrbuf_xtpls wrbuf mods ∗
    "#Hidx" ∷ readonly (txn ↦[Txn :: "idx"] #idx) ∗
    "#HidxRI" ∷ is_index idx γ ∗
    "#Htxnmgr" ∷ readonly (txn ↦[Txn :: "txnMgr"] #txnmgr) ∗
    "#HtxnmgrRI" ∷ is_txnmgr txnmgr γ ∗
    "#Hp" ∷ readonly (txnmgr ↦[TxnMgr :: "p"] #p) ∗
    "#Hinv" ∷ mvcc_inv_sst γ p ∗
    "_" ∷ True.

End repr.

#[global]
Hint Extern 1 (environments.envs_entails _ (own_txn_impl _ _ _ _)) => unfold own_txn_impl : core.
#[global]
Hint Extern 1 (environments.envs_entails _ (own_txn _ _ _ _ _)) => unfold own_txn : core.
#[global]
Hint Extern 1 (environments.envs_entails _ (own_txn_ready _ _ _ _ _)) => unfold own_txn_ready : core.
#[global]
Hint Extern 1 (environments.envs_entails _ (own_txn_uninit _ _)) => unfold own_txn_uninit : core.

Section lemma.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

Lemma own_txn_txnmap_ptsto_dom {txn ts view k v γ τ} :
  own_txn txn ts view γ τ -∗
  txnmap_ptsto τ k v -∗
  ⌜k ∈ dom view⌝.
Proof.
  iIntros "Htxn Hptsto".
  iNamed "Htxn".
  iDestruct (txnmap_lookup with "Htxnmap Hptsto") as "%Hlookup".
  iPureIntro.
  apply elem_of_dom_2 in Hlookup. set_solver.
Qed.

Lemma own_txn_impl_tid txn wrbuf ts γ :
  own_txn_impl txn wrbuf ts γ -∗
  ∃ (tid : u64), ⌜int.nat tid = ts⌝.
Proof. iIntros "Htxn". iNamed "Htxn". eauto. Qed.

End lemma.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import approx_star0.
Require Import approx_star_abs.

Lemma nuprl_extensional_abs {p} :
  forall x : opabs, @extensional_op p (Abs x).
Proof.
  introv Hpra Hprt Hprt' Hcv Has Hi.
  allfold (approx_starbts lib).
  apply computes_to_val_like_in_max_k_steps_S in Hcv; exrepnd.
  csunf Hcv1; allsimpl.
  apply compute_step_lib_success in Hcv1; exrepnd; subst.
  dup Hcv2 as fe1.
  pose proof (approx_starbts_numvars lib (Abs x) lbt lbt' Has) as eqnum.
  apply @found_entry_change_bs with (bs2 := lbt') in Hcv2; auto.
  rename Hcv2 into fe2.

  unfold extensional_op_ind in Hi.

  apply Hi with (v := mk_instance vars lbt' rhs) in Hcv0; auto;
  [ | complete (eapply isprogram_subst_lib; eauto;
                apply isprogram_ot_iff in Hprt; repnd; auto)
    | complete (eapply isprogram_subst_lib; eauto;
                apply isprogram_ot_iff in Hprt'; repnd; auto)
    | ]; clear Hi.

  - apply @approx_star_open_trans with (b := mk_instance vars lbt' rhs); auto.
    apply approx_implies_approx_open.
    apply reduces_to_implies_approx_eauto; prove_isprogram.
    apply reduces_to_if_step; simpl.
    eapply compute_step_lib_success_change_bs; eauto.

  - unfold correct_abs in correct;repnd.
    eapply mk_instance_approx_star_congr; eauto; try (complete (intro xxx; ginv)).

    + apply found_entry_implies_matching_entry in fe1.
      unfold matching_entry in fe1; sp.

    + apply found_entry_implies_matching_entry in fe2.
      unfold matching_entry in fe2; sp.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/")
*** End:
*)


Import EqNotations.
From Perennial.Helpers Require Import Map.
From Perennial.algebra Require Import auth_map liftable log_heap async.
From Perennial.base_logic Require Import lib.mono_nat lib.ghost_map.

From Goose.github_com.mit_pdos.go_journal Require Import jrnl.
From Perennial.program_logic Require Export ncinv.
From Perennial.program_proof Require Import buf.buf_proof addr.addr_proof obj.obj_proof.
From Perennial.program_proof Require jrnl.jrnl_proof.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.goose_lang.lib Require Import slice.typed_slice.
From Perennial.goose_lang.ffi Require Import disk_prelude.

(** * A more separation logic-friendly spec for jrnl

Overview of resources used here:

durable_mapsto_own - durable, exclusive
durable_mapsto - durable but missing modify_token
jrnl_maps_to - ephemeral

is_crash_lock (durable_mapsto_own) (durable_mapsto)
on crash: exchange durable_mapsto for durable_mapsto_own

lift: move durable_mapsto_own into transaction and get jrnl_maps_to and durable_mapsto is added to is_jrnl

is_jrnl P = is_jrnl_mem * is_jrnl_durable P

reads and writes need jrnl_maps_to and is_jrnl_mem

is_jrnl_durable P -* P (P is going to be durable_mapsto) (use this to frame out crash condition)

exchange own_last_frag γ for own_last_frag γ' ∗ modify_token γ' (in sep_jrnl layer)
exchange ephemeral_txn_val γ for ephemeral_txn_val γ' if the transaction id was preserved
 *)

(* mspec is a shorthand for referring to the old "map-based" spec, since we will
want to use similar names in this spec *)
Module mspec := jrnl.jrnl_proof.

Notation versioned_object := ({K & (bufDataT K * bufDataT K)%type}).

Definition objKind (obj: object): bufDataKind := projT1 obj.
Definition objData (obj: object): bufDataT (objKind obj) := projT2 obj.

Class jrnlG Σ :=
  { jrnl_buffer_inG :> mapG Σ addr object;
    jrnl_mspec_jrnlG :> mspec.jrnlG Σ;
    jrnl_asyncG :> asyncG Σ addr object;
  }.

Definition jrnlΣ : gFunctors :=
  #[ mapΣ addr object; mspec.jrnlΣ; asyncΣ addr object ].

#[global]
Instance subG_jrnlΣ Σ : subG jrnlΣ Σ → jrnlG Σ.
Proof. solve_inG. Qed.

Record jrnl_names :=
  { jrnl_txn_names : txn_names;
    jrnl_async_name : async_gname;
  }.

Section goose_lang.
  Context `{!jrnlG Σ}.
  Context `{!heapGS Σ}.

  Context (N:namespace).

  Implicit Types (l: loc) (γ: jrnl_names) (γtxn: gname).
  Implicit Types (obj: object).

  Definition txn_durable γ txn_id :=
    (* oof, this leaks all the abstractions *)
    mono_nat_lb_own γ.(jrnl_txn_names).(txn_walnames).(heapspec.wal_heap_durable_lb) txn_id.

  Definition txn_system_inv γ: iProp Σ :=
    ∃ (σs: async (gmap addr object)),
      "H◯async" ∷ ghost_var γ.(jrnl_txn_names).(txn_crashstates) (3/4) σs ∗
      "H●latest" ∷ async_ctx γ.(jrnl_async_name) 1 σs
  .

  (* modify_token is an obligation from the jrnl_proof, which is how the txn
  invariant keeps track of exclusive ownership over an address. This proof has a
  more sophisticated notion of owning an address coming from the logical setup
  in [async.v], but we still have to track this token to be able to lift
  addresses into a transaction. *)
  Definition modify_token γ (a: addr) : iProp Σ :=
    ∃ obj, obj.invariant.mapsto_txn γ.(jrnl_txn_names) a obj.

  Global Instance modify_token_conflicting γ T :
    Conflicting (λ (l : addr) (_ : T), modify_token γ l).
  Proof.
    iIntros (a0 v0 a1 v1) "H0 H1".
    iDestruct "H0" as (o0) "H0".
    iDestruct "H1" as (o1) "H1".
    iApply (mspec.mapsto_txn_conflicting with "H0 H1").
  Qed.

  (* The basic statement of what is in the logical, committed disk of the
  transaction system.

  Has three components: the value starting from some txn i, a token giving
  exclusive ownership over transactions ≥ i, and a persistent witness that i is
  durable (so we don't crash to before this fact is relevant). The first two are
  grouped into [ephemeral_val_from]. *)
  Definition durable_mapsto γ (a: addr) obj: iProp Σ :=
    ∃ i, ephemeral_val_from γ.(jrnl_async_name) i a obj ∗
         txn_durable γ i.

  Global Instance durable_mapsto_conflicting γ :
    Conflicting (λ a v, durable_mapsto γ a v).
  Proof.
    iIntros (a0 v0 a1 v1) "H0 H1".
    iDestruct "H0" as (o0) "[H0 _]".
    iDestruct "H1" as (o1) "[H1 _]".
    destruct (decide (a0 = a1)); try done; subst.
    iDestruct (ephemeral_val_from_conflict with "H0 H1") as "H". done.
  Qed.

  Definition durable_mapsto_own γ a obj: iProp Σ :=
    modify_token γ a ∗ durable_mapsto γ a obj.

  Global Instance durable_mapsto_own_discretizable γ a obj: Discretizable (durable_mapsto_own γ a obj).
  Proof. apply _. Qed.

  Definition crash_point γ logm crash_txn : iProp Σ :=
    async_ctx γ.(jrnl_async_name) 1 logm ∗
    ⌜(length (possible logm) >= crash_txn + 1)%nat⌝.

  Definition txn_durable_exchanger γ txn_id :=
    heapspec.heapspec_durable_exchanger γ.(jrnl_txn_names).(txn_walnames) txn_id.

  Lemma txn_durable_exchanger_use γ n lb :
    txn_durable_exchanger γ n -∗
    txn_durable γ lb -∗
    ⌜ (lb ≤ n)%nat ⌝.
  Proof. iIntros. iApply (heapspec.heapspec_durable_exchanger_use with "[$] [$]"). Qed.

  Definition token_exchanger (a:addr) crash_txn γ γ' : iProp Σ :=
    (∃ i, async.own_last_frag γ.(jrnl_async_name) a i) ∨
    (async.own_last_frag γ'.(jrnl_async_name) a crash_txn ∗ modify_token γ' a).

  Definition ephemeral_txn_val_exchanger (a:addr) crash_txn γ γ' : iProp Σ :=
    ∃ v, ephemeral_txn_val γ.(jrnl_async_name) crash_txn a v ∗
         ephemeral_txn_val γ'.(jrnl_async_name) crash_txn a v.

  Definition addr_exchangers {A} txn γ γ' (m : gmap addr A) : iProp Σ :=
    ([∗ map] a↦_ ∈ m,
        token_exchanger a txn γ γ' ∗
        ephemeral_txn_val_exchanger a txn γ γ')%I.

  Definition sep_txn_exchanger γ γ' : iProp Σ :=
    ∃ logm crash_txn,
       "Hcrash_point" ∷ crash_point γ logm crash_txn ∗
       "Hdurable_exchanger" ∷ txn_durable_exchanger γ crash_txn ∗
       "#Hcrash_txn_durable" ∷ txn_durable γ' crash_txn ∗
       "Hexchanger" ∷ addr_exchangers crash_txn γ γ' (latest logm)
  .

  (* TODO: note that we don't promise γ'.(jrnl_txn_names).(txn_kinds) =
  γ.(jrnl_txn_names).(txn_kinds), even though txn_cfupd_res has this fact *)
  Definition txn_cinv γ γ' : iProp Σ :=
    (□ |C={⊤}=> inv N (sep_txn_exchanger γ γ')) ∗
    ⌜γ.(jrnl_txn_names).(txn_kinds) = γ'.(jrnl_txn_names).(txn_kinds)⌝.

  (* this is for the entire txn manager, and relates it to some ghost state *)

  Definition is_txn_system γ : iProp Σ :=
    "Htxn_inv" ∷ ncinv N (txn_system_inv γ) ∗
    "His_txn" ∷ ncinv invN (is_txn_always γ.(jrnl_txn_names)).

  Definition is_txn_system_full γ γ' : iProp Σ :=
    "His_txn_system" ∷ is_txn_system γ ∗
    "Htxn_cinv" ∷ txn_cinv γ γ'.

  (*
  Lemma init_txn_system {E} l_txn γUnified dinit σs :
    is_txn l_txn γUnified dinit ∗ ghost_var γUnified.(txn_crashstates) (3/4) σs ={E}=∗
    ∃ γ, ⌜γ.(jrnl_txn_names) = γUnified⌝ ∗
         is_txn_system γ.
  Proof.
    iIntros "[#Htxn Hasync]".
    iMod (async_ctx_init σs) as (γasync) "H●async".
    set (γ:={|jrnl_txn_names := γUnified; jrnl_async_name := γasync; |}).
    iExists γ.
    iMod (ncinv_alloc N E (txn_system_inv γ) with "[-]") as "($&Hcfupd)".
    { iNext.
      iExists _; iFrame. }
    iModIntro.
    simpl.
    iSplit; first by auto.
    iNamed "Htxn"; iFrame "#".
  Qed.
   *)

  Definition is_jrnl_mem l γ dinit γtxn γdurable : iProp Σ :=
    ∃ (mT: gmap addr versioned_object) anydirty,
      "#Htxn_system" ∷ is_txn_system γ ∗
      "Hjrnl" ∷ mspec.is_jrnl l mT γ.(jrnl_txn_names) dinit anydirty ∗
      "Htxn_ctx" ∷ map_ctx γtxn 1 (mspec.modified <$> mT) ∗
      "%Hanydirty" ∷ ⌜anydirty=false →
                      mspec.modified <$> mT = mspec.committed <$> mT⌝ ∗
      "Hdurable" ∷ map_ctx γdurable (1/2) (mspec.committed <$> mT)
  .

  (* To make work with 2PL:
     Consider is_jrnl_mem' that has Hdurable removed and adds mT as an explicit parameter.
     Right before commit, we
     convert is_jrnl_mem' .. .. mT ∗ ([∗ map] a ↦ o ∈ mT durable_mapsto a o) into an is_jrnl. *)

  (* Alternative is define is_jrnl_durable' mT which is just Hdurable and then prove that
     from is_jrnl_mem ∗ ([∗ map] a ↦ o ∈ mT, durable_mapsto a o) ∗ is_jrnl_durable' mT
     can be converted into an is_jrnl

    This seems better.
  *)

  Definition is_jrnl_durable γ γdurable (P0 : (_ -> _ -> iProp Σ) -> iProp Σ) : iProp Σ :=
    ∃ committed_mT,
      "Hdurable_frag" ∷ map_ctx γdurable (1/2) committed_mT ∗
      "Hold_vals" ∷ ([∗ map] a↦v ∈ committed_mT,
                     durable_mapsto γ a v) ∗
      "#HrestoreP0" ∷ □ (∀ mapsto,
                         ([∗ map] a↦v ∈ committed_mT,
                          mapsto a v) -∗
                         P0 mapsto)
  .

  Definition is_jrnl l γ dinit γtxn P0 : iProp Σ :=
    ∃ γdurable,
      "Hjrnl_mem" ∷ is_jrnl_mem l γ dinit γtxn γdurable ∗
      "Hjrnl_durable" ∷ is_jrnl_durable γ γdurable P0.

  Global Instance: Params (@is_jrnl) 4 := {}.

  Global Instance is_jrnl_durable_proper γ γdurable :
    Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (is_jrnl_durable γ γdurable).
  Proof.
    intros P1 P2 Hequiv.
    rewrite /is_jrnl_durable.
    setoid_rewrite Hequiv.
    reflexivity.
  Qed.

  Global Instance is_jrnl_durable_mono γ γdurable :
    Proper (pointwise_relation _ (⊢) ==> (⊢)) (is_jrnl_durable γ γdurable).
  Proof.
    intros P1 P2 Hequiv.
    rewrite /is_jrnl_durable.
    setoid_rewrite Hequiv.
    reflexivity.
  Qed.

  Theorem is_jrnl_durable_wand γ γdurable P1 P2 :
    is_jrnl_durable γ γdurable P1 -∗
    □(∀ mapsto, P1 mapsto -∗ P2 mapsto) -∗
    is_jrnl_durable γ γdurable P2.
  Proof.
    iIntros "Htxn #Hwand".
    iNamed "Htxn".
    iExists _; iFrame "∗#%".
    iIntros (mapsto) "!> Hm".
    iApply "Hwand". iApply "HrestoreP0". iFrame.
  Qed.

  Global Instance is_jrnl_proper l γ dinit γtxn :
    Proper (pointwise_relation _ (⊣⊢) ==> (⊣⊢)) (is_jrnl l γ dinit γtxn).
  Proof.
    intros P1 P2 Hequiv.
    rewrite /is_jrnl.
    setoid_rewrite Hequiv.
    done.
  Qed.

  Global Instance is_jrnl_mono l γ dinit γtxn :
    Proper (pointwise_relation _ (⊢) ==> (⊢)) (is_jrnl l γ dinit γtxn).
  Proof.
    intros P1 P2 Hequiv.
    rewrite /is_jrnl.
    setoid_rewrite Hequiv.
    done.
  Qed.

  Theorem is_jrnl_wand l γ dinit γtxn P1 P2 :
    is_jrnl l γ dinit γtxn P1 -∗
    □(∀ mapsto, P1 mapsto -∗ P2 mapsto) -∗
    is_jrnl l γ dinit γtxn P2.
  Proof.
    iIntros "Htxn #Hwand".
    iNamed "Htxn".
    iDestruct (is_jrnl_durable_wand with "Hjrnl_durable Hwand") as "Hjrnl_durable".
    iExists _; iFrame.
  Qed.

  Theorem is_jrnl_durable_to_old_pred γ γdurable P0 :
    is_jrnl_durable γ γdurable P0 -∗ P0 (durable_mapsto γ).
  Proof.
    iNamed 1.
    iApply "HrestoreP0". iFrame.
  Qed.

  Theorem is_jrnl_to_old_pred' l γ dinit γtxn γdurable committed_mT :
    "Hjrnl_mem" ∷ is_jrnl_mem l γ dinit γtxn γdurable -∗
    "Hdurable_frag" ∷ map_ctx γdurable (1/2) committed_mT -∗
    "Hold_vals" ∷ ([∗ map] a↦v ∈ committed_mT, durable_mapsto γ a v) -∗
    "Hold_vals" ∷ ([∗ map] a↦v ∈ committed_mT, durable_mapsto_own γ a v).
  Proof.
    iIntros "???".
    iNamed.
    iNamed "Hjrnl_mem".
    iDestruct (map_ctx_agree with "Hdurable_frag Hdurable") as %->.
    iApply big_sepM_sep. iFrame.
    iDestruct (mspec.is_jrnl_to_committed_mapsto_txn with "Hjrnl") as "Hmod".
    iApply (big_sepM_mono with "Hmod").
    iIntros (k x Hkx) "H".
    iExists _; iFrame.
  Qed.

  Theorem is_jrnl_to_old_pred l γ dinit γtxn P0 :
    is_jrnl l γ dinit γtxn P0 -∗ P0 (durable_mapsto_own γ).
  Proof.
    iNamed 1.
    iNamed "Hjrnl_durable".
    iApply "HrestoreP0".
    iApply (
      is_jrnl_to_old_pred' with "Hjrnl_mem Hdurable_frag Hold_vals"
    ).
  Qed.

  Definition jrnl_maps_to γtxn (a: addr) obj : iProp Σ :=
     ptsto_mut γtxn a 1 obj.

  (* TODO: prove this instance for ptsto_mut 1 *)
  Global Instance jrnl_maps_to_conflicting γtxn :
    Conflicting (jrnl_maps_to γtxn).
  Proof.
    rewrite /jrnl_maps_to.
    iIntros (????) "Ha1 Ha2".
    destruct (decide (a0 = a1)); subst; auto.
    iDestruct (ptsto_conflict with "Ha1 Ha2") as %[].
  Qed.

  Definition object_to_versioned (obj: object): versioned_object :=
    existT (objKind obj) (objData obj, objData obj).

  Lemma committed_to_versioned obj :
    mspec.committed (object_to_versioned obj) = obj.
  Proof. destruct obj; reflexivity. Qed.

  Lemma modified_to_versioned obj :
    mspec.modified (object_to_versioned obj) = obj.
  Proof. destruct obj; reflexivity. Qed.

  Lemma durable_mapsto_mapsto_txn_agree' E γ a obj1 obj2 k q :
    ↑N ⊆ E →
    ↑invN ⊆ E →
    N ## invN →
    is_txn_system γ -∗
    durable_mapsto γ a obj1 -∗
    mapsto_txn γ.(jrnl_txn_names) a obj2 -∗
    NC q -∗
    |k={E}=> (⌜obj1 = obj2⌝ ∗ durable_mapsto γ a obj1 ∗ mapsto_txn γ.(jrnl_txn_names) a obj2) ∗ NC q.
  Proof.
    iIntros (???) "#Hinv Ha_i Ha HNC".
    iNamed "Hinv".
    iMod (ncinv_acc_k with "His_txn [$]") as "(>Hinner1&HNC&Hclose1)"; first by auto.
    iMod (ncinv_acc_k with "Htxn_inv [$]") as "(>Hinner2&HNC&Hclose2)"; first by set_solver.
    iAssert (⌜obj1 = obj2⌝)%I as %?; last first.
    { iMod ("Hclose2" with "[$] [$]") as "HNC".
      iMod ("Hclose1" with "[$] [$]") as "HNC".
      iFrame. auto. }
    iNamed "Hinner1".
    iClear "Hheapmatch Hcrashheapsmatch Hmetactx".
    iNamed "Hinner2".
    iDestruct (ghost_var_agree with "Hcrashstates [$]") as %->.
    iDestruct (mapsto_txn_cur with "Ha") as "[Ha _]".
    iDestruct "Ha_i" as (i) "[Ha_i _]".
    iDestruct (ephemeral_val_from_agree_latest with "H●latest Ha_i") as %Hlookup_obj.
    iDestruct (ghost_map_lookup with "Hlogheapctx [$]") as %Hlookup_obj0.
    iPureIntro.
    congruence.
  Qed.

  Lemma durable_mapsto_mapsto_txn_agree E γ a obj1 obj2 :
    ↑N ⊆ E →
    ↑invN ⊆ E →
    N ## invN →
    is_txn_system γ -∗
    durable_mapsto γ a obj1 -∗
    mapsto_txn γ.(jrnl_txn_names) a obj2 -∗
    |NC={E}=> ⌜obj1 = obj2⌝ ∗ durable_mapsto γ a obj1 ∗ mapsto_txn γ.(jrnl_txn_names) a obj2.
  Proof.
    iIntros (???) "#Hinv Ha_i Ha".
    rewrite ncfupd_eq /ncfupd_def.
    iIntros. iApply (fupd_level_fupd _ _ _ O).
    iMod (durable_mapsto_mapsto_txn_agree' with "[$] [$] [$] [$]"); auto.
  Qed.

  Theorem is_jrnl_durable_not_in_map γ a obj γdurable P0 committed_mT :
    durable_mapsto γ a obj -∗
    is_jrnl_durable γ γdurable P0 -∗
    map_ctx γdurable (1 / 2) committed_mT -∗
    ⌜committed_mT !! a = None⌝.
  Proof.
    iIntros "Ha Hdur Hctx".
    destruct (committed_mT !! a) eqn:He; try eauto.
    iNamed "Hdur".
    iDestruct (map_ctx_agree with "Hctx Hdurable_frag") as %->.
    iDestruct (big_sepM_lookup with "Hold_vals") as "Ha2"; eauto.
    iDestruct "Ha" as (i) "[Ha _]".
    iDestruct "Ha2" as (i2) "[Ha2 _]".
    iDestruct (ephemeral_val_from_conflict with "Ha Ha2") as "H".
    done.
  Qed.

  Theorem lift_into_txn' E l γ dinit γtxn γdurable committed_mT a obj :
    ↑N ⊆ E →
    ↑invN ⊆ E →
    N ## invN →
    "Hjrnl_mem" ∷ is_jrnl_mem l γ dinit γtxn γdurable -∗
    "Hdurable_frag" ∷ map_ctx γdurable (1/2) committed_mT -∗
    "Hdurable_maps_to" ∷ durable_mapsto_own γ a obj -∗
    |NC={E}=>
    "Hjrnl_maps_to" ∷ jrnl_maps_to γtxn a obj ∗
    "Hjrnl_mem" ∷ is_jrnl_mem l γ dinit γtxn γdurable ∗
    "Hdurable_frag" ∷ map_ctx γdurable (1/2) (<[a:=obj]>committed_mT) ∗
    "Hdurable_maps_to" ∷ durable_mapsto γ a obj ∗
    "%Hnew" ∷ ⌜committed_mT !! a = None⌝.
  Proof.
    iIntros (HN HinvN HNdisj) "? ? [Ha Ha_i]".
    iNamed.
    iNamed "Hjrnl_mem".

    iDestruct "Ha" as (obj0) "Ha".

    iMod (durable_mapsto_mapsto_txn_agree with "[$] Ha_i Ha") as "(%Heq & Ha_i & Ha)";
      [ solve_ndisj.. | subst obj0 ].

    iDestruct (mspec.is_jrnl_not_in_map with "Hjrnl Ha") as %Hnotin.
    assert ((mspec.modified <$> mT) !! a = None).
    { rewrite lookup_fmap Hnotin //. }
    assert ((mspec.committed <$> mT) !! a = None).
    { rewrite lookup_fmap Hnotin //. }
    iMod (mspec.Op_lift_one _ _ _ _ _ _ E with "[$Ha $Hjrnl]") as "Hjrnl"; auto.
    iMod (map_alloc a obj with "Htxn_ctx") as "[Htxn_ctx Ha]"; eauto.

    iDestruct (map_ctx_agree with "Hdurable Hdurable_frag") as %<-.
    iCombine "Hdurable Hdurable_frag" as "Hdurable".
    iMod (map_alloc a obj with "Hdurable") as "[Hdurable _]"; eauto.
    iDestruct "Hdurable" as "[Hdurable Hdurable_frag]".

    iModIntro.
    iFrame "Ha".
    iSplitR "Hdurable_frag Ha_i".
    {
      iExists (<[a:=object_to_versioned obj]> mT), anydirty.
      iFrame "Htxn_system".
      rewrite !fmap_insert committed_to_versioned modified_to_versioned.
      iFrame.
      iPureIntro. destruct anydirty; intuition congruence.
    }
    iFrame "Hdurable_frag".
    iFrame "∗ %".
  Qed.

  Theorem lift_into_txn E l γ dinit γtxn P0 a obj :
    ↑N ⊆ E →
    ↑invN ⊆ E →
    N ## invN →
    is_jrnl l γ dinit γtxn P0 -∗
    durable_mapsto_own γ a obj
    -∗ |NC={E}=>
    jrnl_maps_to γtxn a obj ∗
    is_jrnl l γ dinit γtxn (λ mapsto, mapsto a obj ∗ P0 mapsto).
  Proof.
    iIntros (HN HinvN HNdisj) "Hctx Hnew".
    iNamed "Hctx".
    iNamed "Hjrnl_durable".
    iDestruct (
      lift_into_txn' _ _ _ _ _ _ _ _ _ HN HinvN HNdisj
      with "Hjrnl_mem Hdurable_frag Hnew"
    ) as "> (?&?&?&?&?)".
    iNamed.
    iFrame "Hjrnl_maps_to".
    iExists _.
    iFrame.
    iExists _.
    iFrame.

    iModIntro.
    iSplit.
    {
      iApply big_sepM_insert; first by assumption.
      iFrame.
    }
    iModIntro.
    iIntros (mapsto) "H".
    iDestruct (big_sepM_insert with "H") as "[Ha H]"; eauto. iFrame.
    iApply "HrestoreP0"; iFrame.
  Qed.

  Theorem lift_map_into_txn' E l γ dinit γtxn γdurable committed_mT m :
    ↑invN ⊆ E →
    ↑N ⊆ E →
    N ## invN →
    "Hjrnl_mem" ∷ is_jrnl_mem l γ dinit γtxn γdurable -∗
    "Hdurable_frag" ∷ map_ctx γdurable (1/2) committed_mT -∗
    "Hm" ∷ ([∗ map] a↦v ∈ m, durable_mapsto_own γ a v)
    -∗ |NC={E}=>
    "Hjrnl_maps_to" ∷ ([∗ map] a↦v ∈ m, jrnl_maps_to γtxn a v) ∗
    "Hjrnl_mem" ∷ is_jrnl_mem l γ dinit γtxn γdurable ∗
    "Hdurable_frag" ∷ map_ctx γdurable (1/2) (m ∪ committed_mT) ∗
    "Hdurable_mapstos" ∷ ([∗ map] a↦v ∈ m, durable_mapsto γ a v) ∗
    "%Hall_new" ∷ ⌜m ##ₘ committed_mT⌝.
  Proof.
    iIntros (???) "???".
    iNamed.
    iInduction m as [|a v m] "IH" using map_ind forall (committed_mT).
    - setoid_rewrite big_sepM_empty.
      rewrite !left_id.
      iModIntro.
      iFrame.
      iPureIntro.
      apply map_disjoint_empty_l.
    - rewrite !big_sepM_insert //.
      iDestruct "Hm" as "[[Ha_mod Ha_dur] Hm]".
      iAssert (durable_mapsto_own γ a v) with "[Ha_mod Ha_dur]" as "Ha".
      { iFrame. }
      iMod (lift_into_txn' with "Hjrnl_mem Hdurable_frag Ha")
        as "(?&?&?&?&?)"; [ solve_ndisj .. | ].
      iNamed.
      iMod ("IH" with "Hjrnl_mem Hdurable_frag Hm") as "(?&?&?&?&?)".
      iNamed.
      iModIntro.
      rewrite -insert_union_r.
      2: assumption.
      rewrite insert_union_l.
      iFrame.
      iPureIntro.
      apply map_disjoint_insert_r in Hall_new.
      apply map_disjoint_insert_l_2; intuition.
  Qed.

  Theorem lift_map_into_txn E l γ dinit γtxn P0 m :
    ↑invN ⊆ E →
    ↑N ⊆ E →
    N ## invN →
    is_jrnl l γ dinit γtxn P0 -∗
    ([∗ map] a↦v ∈ m, durable_mapsto_own γ a v)
    -∗ |NC={E}=>
    ([∗ map] a↦v ∈ m, jrnl_maps_to γtxn a v) ∗
    is_jrnl l γ dinit γtxn (λ mapsto,
      ([∗ map] a↦v ∈ m, mapsto a v) ∗ P0 mapsto
    ).
  Proof.
    iIntros (???) "Hctx Hm".
    iNamed "Hctx".
    iNamed "Hjrnl_durable".
    iMod (lift_map_into_txn' with "Hjrnl_mem Hdurable_frag Hm")
      as "(?&?&?&?&?)"; [ solve_ndisj.. | ].
    iNamed.
    iModIntro.
    iFrame "Hjrnl_maps_to".
    iExists _.
    iFrame "Hjrnl_mem".
    iExists _.
    iFrame "Hdurable_frag".
    iSplit.
    {
      iApply big_sepM_union; first by assumption.
      iFrame.
    }

    iModIntro.
    iIntros (?) "Hmapsto".
    iDestruct (big_sepM_union with "Hmapsto") as "[Hnew Hold]".
    1: assumption.
    iFrame.
    iApply "HrestoreP0".
    iFrame.
  Qed.

  Lemma conflicting_exists {PROP:bi} (A L V : Type) (P : A → L → V → PROP) :
    (∀ x1 x2, ConflictsWith (P x1) (P x2)) →
    Conflicting (λ a v, ∃ x, P x a v)%I.
  Proof.
    intros.
    hnf; intros a1 v1 a2 v2.
    iIntros "H1 H2".
    iDestruct "H1" as (?) "H1".
    iDestruct "H2" as (?) "H2".
    iApply (H with "H1 H2").
  Qed.

  Theorem lift_liftable_into_txn E `{!Liftable P}
          l γ dinit γtxn P0 :
    ↑invN ⊆ E →
    ↑N ⊆ E →
    N ## invN →
    is_jrnl l γ dinit γtxn P0 -∗
    P (λ a v, durable_mapsto_own γ a v)
    -∗ |NC={E}=>
    P (jrnl_maps_to γtxn) ∗
    is_jrnl l γ dinit γtxn
      (λ mapsto,
       P mapsto ∗ P0 mapsto).
  Proof.
    iIntros (???) "Hctx HP".
    iDestruct (liftable_restore_elim with "HP") as (m) "[Hm #HP]".
    iMod (lift_map_into_txn with "Hctx Hm") as "[Hm Hctx]";
      [ solve_ndisj .. | ].
    iModIntro.
    iFrame.
    iSplitR "Hctx".
    - iApply "HP"; iFrame.
    - iApply (is_jrnl_wand with "Hctx").
      iIntros (mapsto) "!> [Hm $]".
      iApply "HP"; auto.
  Qed.

  Lemma exchange_big_sepM_addrs γ γ' (m0 m1 : gmap addr object) crash_txn :
    dom m0 ⊆ dom m1 →
    txn_durable γ' crash_txn -∗
    addr_exchangers crash_txn γ γ' m1 -∗
    ([∗ map] k0↦x ∈ m0, ephemeral_txn_val γ.(jrnl_async_name) crash_txn k0 x ∗
                        (∃ i v, ephemeral_val_from γ.(jrnl_async_name) i k0 v)) -∗
    addr_exchangers crash_txn γ γ' m1 ∗
    [∗ map] k0↦x ∈ m0, durable_mapsto_own γ' k0 x.
  Proof.
    iIntros (Hdom) "#Hdur H1 H2".
    rewrite /addr_exchangers.
    iCombine "Hdur H1" as "H1".
    iDestruct (big_sepM_mono_with_inv with "H1 H2") as "((_&$)&H)"; last iApply "H".
    iIntros (k o Hlookup) "((#Hdur&Hm)&Hephem)".
    assert (is_Some (m1 !! k)) as (v&?).
    { apply elem_of_dom, Hdom, elem_of_dom. eauto. }
    iDestruct (big_sepM_lookup_acc with "Hm") as "(H&Hm)"; first eassumption.
    iDestruct "Hephem" as "(#Hval0&Hephem)".
    iDestruct "Hephem" as (??) "(_&Htok0)".
    iDestruct "H" as "(Htok&#Hval)".
    iDestruct "Hval" as (?) "(Hval1&Hval2)".
    iDestruct (ephemeral_txn_val_agree with "Hval0 Hval1") as %Heq. subst.
    iDestruct "Htok" as "[Hl|(Hr1&Hr2)]".
    { iExFalso. iDestruct "Hl" as (?) "H".
      iApply (own_last_frag_conflict with "[$] [$]"). }
    iSpecialize ("Hm" with "[Htok0]").
    { iSplitL "Htok0".
      - iLeft. eauto.
      - iExists _. iFrame "#". }
    iFrame "# ∗". iExists _. iFrame "# ∗".
  Qed.

  Lemma exchange_durable_mapsto γ γ' m :
    ("#Htxn_cinv" ∷ txn_cinv γ γ' ∗
     "Hm" ∷ [∗ map] a↦v ∈ m, durable_mapsto γ a v) -∗
    |C={⊤}=> ([∗ map] a↦v ∈ m, durable_mapsto_own γ' a v).
  Proof.
    iNamed 1.
    iDestruct "Htxn_cinv" as "[#Hinv %kinds]".
    iMod ("Hinv").
    iIntros "HC".
    iInv ("Hinv") as ">H" "Hclo".
    iNamed "H".
    iDestruct "Hcrash_point" as "(Hasync&%Heq)".
    iAssert (⌜dom m ⊆ dom logm.(latest)⌝)%I with "[Hm Hasync]" as "%Hdom2".
    {
      iInduction m as [| i x m] "IH" using map_ind.
      { iPureIntro; set_solver. }
      rewrite big_sepM_insert //.
      iDestruct "Hm" as "(Hval1&Hval)".
      iDestruct ("IH" with "[$] [$]") as %Hdom.
      iDestruct "Hval1" as (?) "((?&?)&?)".
      iDestruct (ephemeral_val_from_agree_latest with "[$] [$]") as %Hlookup.
      iPureIntro. rewrite dom_insert.
      assert (i ∈ dom (logm.(latest))).
      { apply elem_of_dom. eauto. }
      set_solver.
    }

    iAssert ((txn_durable_exchanger γ crash_txn ∗ async_ctx γ.(jrnl_async_name) 1 logm) ∗
              ([∗ map] k0↦x ∈ m, ephemeral_txn_val γ.(jrnl_async_name) crash_txn k0 x
                  ∗ (∃ (i : nat) (v : object), ephemeral_val_from γ.(jrnl_async_name) i k0 v)))%I
            with "[Hasync Hdurable_exchanger Hm]" as "[[Hdurable_exchanger Hasync] Hm]".
    {
      iCombine "Hdurable_exchanger Hasync" as "H".
      iDestruct (big_sepM_mono_with_inv with "H Hm") as "($&H)"; last iApply "H".
      iIntros (? ? Hlookup) "((Hdurable_exchanger&Hasync)&Hm)".
      iDestruct "Hm" as (?) "(?&?)".
      iDestruct (txn_durable_exchanger_use with "[$] [$]") as %Hlb.
      iDestruct (ephemeral_val_from_val with "Hasync [$]") as "#$".
      { lia. }
      { lia. }
      iFrame. iExists _, _; eauto.
    }
    iDestruct (exchange_big_sepM_addrs with "[$] [$] Hm") as "(Hexchanger&Hval)".
    { eauto. }
    iMod ("Hclo" with "[Hexchanger Hdurable_exchanger Hasync]").
    { iNext. iExists _, _. iFrame "# ∗". eauto. }
    iModIntro. eauto.
  Qed.

  Lemma exchange_durable_mapsto1 γ γ' a v :
    ("#Htxn_cinv" ∷ txn_cinv γ γ' ∗
     "Hm" ∷ durable_mapsto γ a v) -∗
    |C={⊤}=> durable_mapsto_own γ' a v.
  Proof.
    iIntros "H".
    iMod (exchange_durable_mapsto γ γ' {[ a := v ]} with "[-]").
    { iNamed "H". iFrame "Htxn_cinv". rewrite big_sepM_singleton. eauto. }
    iModIntro. rewrite big_sepM_singleton. eauto.
  Qed.

  Lemma exchange_mapsto_commit γ γ' m0 m txn_id :
    dom m0 ⊆ dom m →
    ("#Htxn_cinv" ∷ txn_cinv γ γ' ∗
    "Hold_vals" ∷ ([∗ map] k↦x ∈ m0,
          ∃ i : nat, txn_durable γ i ∗
                     ephemeral_txn_val_range γ.(jrnl_async_name) i txn_id k x) ∗
    "Hval" ∷ [∗ map] k↦x ∈ m, ephemeral_val_from γ.(jrnl_async_name) txn_id k x) -∗
    |C={⊤}=> ([∗ map] a↦v ∈ m0, durable_mapsto_own γ' a v) ∨
                  ([∗ map] a↦v ∈ m, durable_mapsto_own γ' a v).
  Proof.
    iIntros (Hdom1) "H". iNamed "H".
    iDestruct "Htxn_cinv" as "[#Hinv %kinds]".
    iMod ("Hinv").
    iIntros "HC".
    iInv ("Hinv") as ">H" "Hclo".
    iNamed "H".
    iDestruct "Hcrash_point" as "(Hasync&%Heq)".
    iAssert (⌜dom m ⊆ dom logm.(latest)⌝)%I with "[Hval Hasync]" as "%Hdom2".
    {
      clear Hdom1.
      iInduction m as [| i x m] "IH" using map_ind.
      { iPureIntro; set_solver. }
      rewrite big_sepM_insert //.
      iDestruct "Hval" as "(Hval1&Hval)".
      iDestruct ("IH" with "[$] [$]") as %Hdom.
      iDestruct (ephemeral_val_from_agree_latest with "[$] [$]") as %Hlookup.
      iPureIntro. rewrite dom_insert.
      assert (i ∈ dom (logm.(latest))).
      { apply elem_of_dom. eauto. }
      set_solver.
    }

    destruct (decide (crash_txn < txn_id)).
    - (* We roll back, txn_id is not durable *)
      iAssert (txn_durable_exchanger γ crash_txn ∗
               ([∗ map] k0↦x ∈ m0, ephemeral_txn_val γ.(jrnl_async_name) crash_txn k0 x))%I
        with "[Hold_vals Hdurable_exchanger]" as "(Hdurable_exchanger&#Hold)".
      {
        iDestruct (big_sepM_mono_with_inv with "Hdurable_exchanger Hold_vals") as "($&H)"; last iApply "H".
        iIntros (?? Hlookup) "(Hdurable_exchanger&H)".
        iDestruct "H" as (i) "(Hdurable&Hrange)".
        iDestruct (txn_durable_exchanger_use with "[$] [$]") as %Hlb.
        iFrame. iApply (ephemeral_txn_val_range_acc with "[$]").
        lia.
      }
      iAssert ([∗ map] k0↦_ ∈ m, ∃ txn_id x, ephemeral_val_from γ.(jrnl_async_name) txn_id k0 x)%I
       with "[Hval]" as "Hval".
      { iApply (big_sepM_mono with "Hval"); eauto. }
      iDestruct (big_sepM_dom with "Hval") as "Hval".
      iDestruct (big_sepS_subseteq with "Hval") as "Hval"; eauto.
      iDestruct (big_sepM_dom with "Hval") as "Hval".
      iCombine "Hold Hval" as "Hval".
      iEval (rewrite -big_sepM_sep) in "Hval".
      iDestruct (exchange_big_sepM_addrs with "[$] [$] Hval") as "(Hexchanger&Hval)".
      { etransitivity; last eassumption; eauto. }
      iMod ("Hclo" with "[Hexchanger Hdurable_exchanger Hasync]").
      { iNext. iExists _, _. iFrame "# ∗". eauto. }
      iModIntro. eauto.
    - (* We go forward, txn_id is durable *)
      iAssert (async_ctx γ.(jrnl_async_name) 1 logm ∗
                ([∗ map] k0↦x ∈ m, ephemeral_txn_val γ.(jrnl_async_name) crash_txn k0 x
                    ∗ (∃ (i : nat) (v : object), ephemeral_val_from γ.(jrnl_async_name) i k0 v)))%I
              with "[Hasync Hval]" as "[Hasync Hval]".
      {iDestruct (big_sepM_mono_with_inv with "Hasync Hval") as "($&H)"; last iApply "H".
       iIntros (? ? Hlookup) "(Hasync&Hval)".
       iDestruct (ephemeral_val_from_val with "Hasync Hval") as "#$".
       { lia. }
       { lia. }
       iFrame. iExists _, _; eauto.
      }
      iDestruct (exchange_big_sepM_addrs with "[$] [$] Hval") as "(Hexchanger&Hval)".
      { eauto. }
      iMod ("Hclo" with "[Hexchanger Hdurable_exchanger Hasync]").
      { iNext. iExists _, _. iFrame "# ∗". eauto. }
      iModIntro. eauto.
  Qed.

End goose_lang.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RealmTimerHandler.Specs.handle_vtimer_sysreg_write.
Require Import RealmTimerHandler.LowSpecs.handle_vtimer_sysreg_write.
Require Import RealmTimerHandler.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       ESR_EL2_SYSREG_ISS_RT_spec
       get_rec_regs_spec
       sysreg_write_spec
       set_rec_vtimer_masked_spec
       sysreg_read_spec
       get_rec_vtimer_masked_spec
       get_rec_vtimer_spec
       timer_condition_met_spec
       set_rec_vtimer_asserted_spec
       get_rec_sysregs_spec
       set_rec_sysregs_spec
    .

  Lemma handle_vtimer_sysreg_write_spec_exists:
    forall habd habd'  labd rec esr
           (Hspec: handle_vtimer_sysreg_write_spec rec esr habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', handle_vtimer_sysreg_write_spec0 rec esr labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. destruct rec.
    unfold handle_vtimer_sysreg_write_spec, handle_vtimer_sysreg_write_spec0 in *.
    repeat autounfold in *. simpl in *; unfold ref_accessible in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; simpl in *; srewrite;
        repeat (repeat grewrite; simpl; repeat simpl_update_reg; simpl; try rewrite ZMap.gss; simpl;
                repeat (extract_if; [bool_rel_all; apply andb_true_iff; split; bool_rel;
                                     match goal with
                                     | [|- Z.lor ?a ?b <= ?x] => apply or_le_64; somega
                                     | _ => somega
                                     end | idtac]; grewrite; simpl));
        try solve[eexists; split;
                  [reflexivity|
                   constructor; simpl;
                   repeat (repeat simpl_field; repeat swap_fields; repeat rewrite ZMap.set2; simpl);
                   reflexivity]].
  Qed.

End Refine.