(** Proof the causal memory implementation w.r.t. modular specification. *)
From iris.algebra Require Import agree auth excl gmap.
From iris.base_logic Require Import invariants.

From iris.base_logic Require Export gen_heap.
From iris.proofmode Require Import tactics.
From aneris.aneris_lang Require Import
     lang network tactics proofmode lifting.
From aneris.prelude Require Import misc.
From aneris.aneris_lang.lib Require Import list_proof map_proof lock_proof network_util_proof inject.
From aneris.aneris_lang.program_logic Require Import lightweight_atomic.
From aneris.aneris_lang.lib.vector_clock Require Import vector_clock_proof.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.examples.rcb Require Import rcb_code.
From aneris.examples.rcb.spec Require Import base.
From aneris.examples.rcb.model Require Import
     model_lst model_gst model_update_system model_update_lst model_update_gst.
From aneris.examples.rcb.resources Require Import
     base resources_global resources_lhst resources_local_inv resources_global_inv.

Section proof.
  Context `{!anerisG Mdl Σ, !RCB_params, !internal_RCBG Σ}.
  Context (γGauth γGsnap : gname) (γLs : list gname).

  Lemma wp_is_causally_next n (vt : val) (t : vector_clock) (i : nat) :
    {{{ ⌜is_vc vt t⌝ ∗ ⌜length t = length RCB_addresses⌝ }}}
      is_causally_next vt #i @[n]
    {{{(f : val), RET f;
       ∀ (w : global_event),
         {{{ True }}}
           f ($ w) @[n]
         {{{(b : bool), RET #b;
            if b then
              ⌜w.(ge_orig) ≠ i ∧
              length w.(ge_time) = length t ∧
              w.(ge_time) !! w.(ge_orig) =
              Some (S (default 0 (t !! w.(ge_orig)))) ∧
              (∀ j, j < length RCB_addresses → j ≠ w.(ge_orig) →
                    default 0 (w.(ge_time) !! j) <= default 0 (t !! j))⌝
            else True
         }}}
    }}}.
  Proof.
    iIntros (Φ) "[Ht Htlen] HΦ".
    iDestruct "Ht" as %Ht.
    iDestruct "Htlen" as %Htlen.
    rewrite /is_causally_next.
    wp_pures.
    wp_apply wp_list_length; first done.
    iIntros (k Hk).
    wp_pures.
    iApply "HΦ".
    clear Φ.
    iIntros (w vw Φ) "!# HΦ".
    wp_pures.
    destruct (decide (i = w.(ge_orig))) as [->|Hioe].
    { rewrite bool_decide_eq_true_2; last lia.
      wp_pures.
      iApply "HΦ"; done. }
    rewrite bool_decide_eq_false_2; last lia.
    wp_pures.
    destruct (decide (w.(ge_orig) < length RCB_addresses)) as [Hlt|]; last first.
    { rewrite bool_decide_eq_false_2; last lia.
      wp_pures.
      iApply "HΦ"; done. }
    rewrite bool_decide_eq_true_2; last lia.
    wp_pures.
    wp_apply (wp_vect_applicable _ _ _ w.(ge_time) t with "[]");
      [by iSplit; iPureIntro; first apply vector_clock_to_val_is_vc|].
    iIntros (b) "Hb".
    iApply ("HΦ" with "[Hb]").
    destruct b; last done.
    iDestruct "Hb" as %(Hb1 & Hb2 & Hb3).
    iPureIntro.
    split_and!; [lia|lia| |].
    - destruct (lookup_lt_is_Some_2 w.(ge_time) w.(ge_orig))
        as [wto Hwto]; first lia.
      destruct (lookup_lt_is_Some_2 t w.(ge_orig))
        as [two Htwo]; first lia.
      rewrite Hwto Htwo in Hb2.
      inversion Hb2 as [? ? ->|]; simplify_eq; simpl.
      rewrite Htwo Hwto /=.
      f_equal; lia.
    - intros j Hj1 Hj2.
      destruct (lookup_lt_is_Some_2 w.(ge_time) j) as [wj Hwj]; first lia.
      destruct (lookup_lt_is_Some_2 t j) as [tj Htj]; first lia.
      rewrite Htj Hwj /=.
      assert (ge_orig w ≠ j) as Hj2' by done.
      specialize (Hb3 j wj tj Hj2' Hwj Htj).
      eauto with lia.
  Qed.

  Definition internal_deliver_spec (deliver_fn : val) (i : nat) (z : socket_address) : iProp Σ :=
         ⌜RCB_addresses !! i = Some z⌝ -∗
         <<< ∀∀ (s : gset local_event), lhst_user γLs i s >>>
           deliver_fn #() @[ip_of_address z] ↑RCB_InvName
           <<<▷ ∃∃ s' vo, RET vo;
                         lhst_user γLs i s' ∗
                         ((⌜s' = s⌝ ∗ ⌜vo = NONEV⌝) ∨
                          (∃ a ,
                           ⌜s' = s ∪ {[ a ]}⌝ ∗
                           ⌜a ∉ s⌝ ∗
                           ⌜a ∈ compute_maximals le_time s'⌝ ∗
                           ⌜not (a.(le_orig) = i)⌝ ∗
                           own_global_snap γGsnap {[ erase a ]} ∗
                           ∃ v, ⌜vo = SOMEV v⌝ ∗ ⌜is_lev v a⌝)) >>>.

  Lemma internal_deliver_spec_holds
        (i : nat) (z : socket_address) (T SeenLoc IQ OQ : loc) (lk : val)
        (γlk : gname) :
    {{{ Global_Inv γGauth γGsnap γLs ∗
        local_invariant γGsnap γLs i T SeenLoc IQ OQ lk γlk z ∗
        ⌜ip_of_address <$> RCB_addresses !! i = Some (ip_of_address z)⌝ }}}
      deliver #T lk #IQ #i @[ip_of_address z]
    {{{ (fv : val), RET fv;
        internal_deliver_spec fv i z
    }}}.
  Proof.
    rewrite /deliver /local_invariant.
    remember (ip_of_address z) as ip.
    iIntros (Φ) "(#Ginv & #Linv & %Hip) HΦ".
    wp_pures.
    iApply "HΦ"; clear Φ.
    iIntros "#Haddr". iIntros "!>" (Φ) "Hvs".
    wp_pures.
    rewrite Heqip.
    wp_apply acquire_spec; first iExact "Linv".
    iIntros (?) "(-> & Hlk & Hli)".
    rewrite /local_inv_def.
    iDestruct "Hli" as (vt vseen viq voq t seenv liq loq s' ip')
     "(%Hip'& HT & %Hvc & Hseen & %Hseen_vc & %Hseen_len & HIQ & HOQ & Hlhst & %Hlstv)".
    assert (ip = ip') as ->.
    { rewrite Hip in Hip'. inversion Hip'; done. }
    clear Hip'.
    subst.
    iDestruct "HIQ" as "(HIQ & %Hviq & Hliq)".
    wp_pures.
    wp_load.
    wp_load.
    wp_apply wp_is_causally_next.
    { iSplit; first done.
      rewrite (RCBM_LSTV_time_length Hlstv); done. }
    iIntros (f) "#Hf /=".
    wp_apply (wp_find_remove); [|done|].
    { iIntros (? ? _) "!> HΦ".
      iApply "Hf"; first done.
      iNext. iIntros (b) "Hb".
      iApply "HΦ".
      destruct b; first iExact "Hb"; done. }
    iIntros (v) "[->|Hv]".
    { wp_pures.
      wp_apply (release_spec with "[$Hlk HT Hseen HOQ HIQ Hliq Hlhst]").
      { eauto 20 with iFrame. }
      iIntros (v ->).
      wp_bind (Rec _ _ _).
      iApply (aneris_wp_atomic _ _ (↑RCB_InvName)).
      iMod "Hvs". iModIntro.
      wp_pure _.
      iDestruct "Hvs" as (x) "[Hu Hupd]".
      iMod ("Hupd" with "[$Hu]") as "HΦ".
      { iLeft. eauto. }
      iModIntro. wp_pures.
      iApply "HΦ". }
    iDestruct "Hv" as (a lv' l1 l2) "((->&->&%Hlv')&%Honi&%Hwtlen&%Hwtoa&%Hwtnoa)".
    wp_pures.
    wp_store.
    wp_load.
    assert (a.(ge_orig) < length t).
    { apply lookup_lt_Some in Hwtoa; lia. }
    destruct (lookup_lt_is_Some_2 t a.(ge_orig)); first done.
    wp_apply wp_vect_inc; [|done|done|]; first lia.
    iIntros (vt' Hvt'); simpl.
    wp_store.
    iDestruct "Hliq" as "(Hliq1 & (%Hne & #Ha) & Hliq2)".
    iCombine "Hliq1" "Hliq2" as "Hliq".
    rewrite -big_sepL_app.
    set (e := LocalEvent a.(ge_payload)
                         a.(ge_time)
                         a.(ge_orig)
                             (S (length (elements s')))).
    assert (a = erase e) as Herase.
    { destruct a; done. }
    pose proof (RCBM_LSTV_at Hlstv).
    pose proof (RCBM_LSTV_time_length Hlstv) as Htlen;
      rewrite /= /RCBM_lst_time_length in Htlen.
    assert (e ∉ s') as Hes'.
    { apply (RCBM_system_local_event_fresh_lhst e i t); eauto with lia. }
    wp_bind (InjR _).
    do 2 wp_pure _.
    iApply (aneris_wp_atomic _ _ (↑RCB_InvName)).
    iMod "Hvs". iModIntro. wp_pures.
    iDestruct "Hvs" as (s) "[Hu Himpl]".
    iDestruct (lhst_user_lock_agree with "Hu Hlhst") as %->.
    iInv RCB_InvName as
        (G Ss) "(>% & >Hgsys & >Hl & >%Hvl)" "Hclos_inv".
    iDestruct (own_global_snap_lookup with "Hgsys Ha") as "%Hina".
    iDestruct (lhst_user_lookup with "Hl Hu") as %His'.
    iDestruct (lhst_lock_lookup with "Hl Hlhst") as %His''.
    assert (e ∈ compute_maximals le_time (s' ∪ {[ e ]})) as Hemax.
    { remember {| Lst_time := t; Lst_hst := s' |} as lst.
      replace s' with lst.(Lst_hst); [ | by rewrite Heqlst ].
      eapply RCBM_Lst_valid_compute_maximals; [done |].
      rewrite /e; simpl.
      replace (Lst_time lst) with t; [eauto | ].
      rewrite Heqlst; done. }
    assert (RCBM_Lst_valid i
                 {| Lst_time := incr_time t (ge_orig a);
                    Lst_hst := s' ∪ {[e]} |}).
    { apply (RCBM_lst_update_apply i {| Lst_time := t; Lst_hst := s' |} (erase e));
        rewrite /e; [done | done |].
      split_and!; simpl; auto with lia. }
    assert (RCBM_Gst_valid {| Gst_ghst := G; Gst_hst := <[i := s' ∪ {[e]} ]>Ss |}).
    { rewrite /e.
      apply (RCBM_system_apply_update_gst
               i {| Gst_ghst := G |} {| Lst_time := t; Lst_hst := s' |} a );
        simpl; eauto with set_solver.
      split_and!; simpl; eauto with lia. }
    iMod (lhst_update _ _ _ _ e with "Hu Hlhst Hl") as "(Hu & Hlhst & Hl)".
    iMod ("Hclos_inv" with "[Hgsys Hl]") as "_".
    { eauto 15 with iFrame. }
    rewrite Herase.
    iMod ("Himpl" with "[$Hu]") as "HΦ".
    { iRight. iExists e.
      iFrame "#".
      repeat iSplit; eauto.
      iExists $(erase e).
      iSplit; eauto.
      iPureIntro.
      simpl.
      eexists _, _, _.
      eauto using vector_clock_to_val_is_vc. }
    iModIntro. wp_pures.
    wp_apply (release_spec with "[$Hlk HT Hseen HOQ HIQ Hliq Hlhst]").
    { iFrame "Linv".
      iExists _, _, _, _, _, _, _, _.
      iExists _, _.
      iSplitL ""; [by iPureIntro |].
      iSplitL "HT"; [iFrame |].
      iSplitL ""; [by iPureIntro|].
      iFrame; iFrame "#".
      repeat iSplit; eauto.
      iPureIntro.
      rewrite Hseen_len.
      symmetry.
      apply incr_time_length. }
    iIntros (? ->).
    wp_seq.
    iApply "HΦ".
  Qed.

End proof.


Require Import UNIVERSE.
(* Require Import Events. *)
(* Require Import ValuesC. *)
(* Require Import AST. *)
(* Require Import Memory. *)
(* Require Import Globalenvs. *)
Require Import Smallstep.
Require Import CoqlibC.
(* Require Import Skeleton. *)
(* Require Import Integers. *)
(* Require Import ASTC. *)
Require Import LinkingC.
(* Require Import Maps. *)

Require Import SimMem.
Require Import System.
Require Import ModSem.

Set Implicit Arguments.

Module SimSymb.

  Inductive sim_skenv_weak (sim_val: val -> val -> Prop) (skenv_src skenv_tgt: SkEnv.t): Prop :=
  | sim_skenv_weak_intro
      (FUNCFSIM: forall fptr_src fptr_tgt def_src
          (SIMFPTR: sim_val fptr_src fptr_tgt)
          (FUNCSRC: (Genv.find_funct skenv_src) fptr_src = Some def_src),
          exists def_tgt, <<FUNCSRC: (Genv.find_funct skenv_tgt) fptr_tgt = Some def_tgt>> /\ <<SIM: def_src = def_tgt>>)
      (* (FUNCBSIM: forall fptr_src fptr_tgt def_tgt *)
      (*     (SIMFPTR: sim_val fptr_src fptr_tgt) *)
      (*     (FUNCTGT: (Genv.find_funct skenv_tgt) fptr_tgt = Some def_tgt) *)
      (*     (SAFESRC: fptr_src <> Vundef) *)
      (*   , *)
      (*     exists def_src, (<<FUNCSRC: (Genv.find_funct skenv_src) fptr_src = Some def_src>>) /\ (<<SIM: def_src = def_tgt>>)) *)
  .

  Class class (SM: SimMem.class) :=
    { t: Type;
      le: t -> t -> Prop;
      src: t -> Sk.t;
      tgt: t -> Sk.t;

      le_PreOrder :> PreOrder le;

      wf: t -> Prop;
      wf_preserves_wf: forall ss0
          (SIMSK: wf ss0)
          (WFSRC: Sk.wf ss0.(src)),
          <<WFTGT: Sk.wf ss0.(tgt)>>;

      wf_link: forall ss0 ss1 sk_src
          (SIMSK: wf ss0)
          (SIMSK: wf ss1)
          (LINKSRC: link ss0.(src) ss1.(src) = Some sk_src)
          (WFSRC0: Sk.wf ss0.(src))
          (WFSRC1: Sk.wf ss1.(src))
          (WFTGT0: Sk.wf ss0.(tgt))
          (WFTGT1: Sk.wf ss1.(tgt)),
          exists ss sk_tgt,
            <<LINKTGT: link ss0.(tgt) ss1.(tgt) = Some sk_tgt>> /\
            <<SKSRC: ss.(src) = sk_src>> /\
            <<SKTGT: ss.(tgt) = sk_tgt>> /\
            <<LE0: le ss0 ss>> /\
            <<LE1: le ss1 ss>> /\
            <<SIMSK: wf ss>>;

      sim_skenv: SimMem.t -> t -> SkEnv.t -> SkEnv.t -> Prop;

      sim_skenv_public_symbols: forall sm0 ss0 skenv_src skenv_tgt
          (SIMSKE: sim_skenv sm0 ss0 skenv_src skenv_tgt),
          (Genv.public_symbol skenv_src) = (Genv.public_symbol skenv_tgt);

      wf_load_sim_skenv: forall ss skenv_src skenv_tgt m_src
          (SIMSK: wf ss)
          (LOADSRC: (Sk.load_skenv ss.(src)) = skenv_src)
          (LOADTGT: (Sk.load_skenv ss.(tgt)) = skenv_tgt)
          (LOADMEMSRC: (Sk.load_mem ss.(src)) = Some m_src),
          exists m_tgt sm,
            (<<LOADMEMTGT: (Sk.load_mem ss.(tgt)) = Some m_tgt>>) /\
            (<<SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt>>) /\
            (<<MEMSRC: sm.(SimMem.src) = m_src>>) /\
            (<<MEMTGT: sm.(SimMem.tgt) = m_tgt>>) /\
            (<<MWF: sm.(SimMem.wf)>>) /\
            (<<MAINSIM: SimMem.sim_val sm (Genv.symbol_address skenv_src (prog_main ss.(src)))
                                       (Genv.symbol_address skenv_tgt (prog_main ss.(tgt)))>>);

      mlepriv_preserves_sim_skenv: forall sm0 sm1 ss skenv_src skenv_tgt
          (MLE: SimMem.lepriv sm0 sm1)
          (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt),
          <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>;

      sim_skenv_monotone: forall
          sm ss_link skenv_link_src skenv_link_tgt
          ss skenv_src skenv_tgt
          (WFSRC: SkEnv.wf skenv_link_src)
          (WFTGT: SkEnv.wf skenv_link_tgt)
          (SIMSKENV: sim_skenv sm ss_link skenv_link_src skenv_link_tgt)
          (SIMSK: wf ss)
          (LE: le ss ss_link)
          (INCLSRC: SkEnv.includes skenv_link_src ss.(src))
          (INCLTGT: SkEnv.includes skenv_link_tgt ss.(tgt))
          (LESRC: SkEnv.project skenv_link_src ss.(src) = skenv_src)
          (LETGT: SkEnv.project skenv_link_tgt ss.(tgt) = skenv_tgt),
          <<SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt>>;

      sim_skenv_sim_skenv_weak: forall sm ss,
              sim_skenv sm ss <2= sim_skenv_weak sm.(SimMem.sim_val);

      system_sim_skenv: forall sm ss skenv_src skenv_tgt
          (SIMSKENV: sim_skenv sm ss skenv_src skenv_tgt),
          <<SIMSKENV: sim_skenv sm ss (System.skenv skenv_src) (System.skenv skenv_tgt)>>;
      system_axiom: forall
          sm0 ss_sys skenv_sys_src skenv_sys_tgt
          args_src args_tgt tr retv_src ef
          (SIMSKENV: sim_skenv sm0 ss_sys skenv_sys_src skenv_sys_tgt)
          (MWF: SimMem.wf sm0)
          (CSTYLE: Args.is_cstyle args_src)
          (CSTYLE: Retv.is_cstyle retv_src)
          (ARGS: SimMem.sim_args args_src args_tgt sm0)
          (SYSSRC: external_call ef skenv_sys_src (Args.vs (args_src)) (Args.m (args_src))
                                 tr
                                 (Retv.v (retv_src)) (Retv.m (retv_src))),
          exists sm1 retv_tgt,
            (<<SYSTGT: external_call ef skenv_sys_tgt (Args.vs (args_tgt)) (Args.m (args_tgt))
                                     tr
                                     (Retv.v (retv_tgt)) (Retv.m (retv_tgt))>>)
            /\ (<<RETV: SimMem.sim_retv retv_src retv_tgt sm1>>)
            /\ (<<MLE0: SimMem.le sm0 sm1>>)
            /\ (<<MWF: SimMem.wf sm1>>);
    }.

  Lemma mle_preserves_sim_skenv: forall
      `{SM: SimMem.class} `{SS: @class SM}
      sm0 sm1 ss skenv_src skenv_tgt
      (MLE: SimMem.le sm0 sm1)
      (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt),
      <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>.
  Proof. ii. eapply mlepriv_preserves_sim_skenv; et. Qed.

  Lemma mfuture_preserves_sim_skenv
        `{SM: SimMem.class} `{SS: @class SM}
        sm0 sm1 ss skenv_src skenv_tgt
        (MFUTURE: SimMem.future sm0 sm1)
        (SIMSKENV: sim_skenv sm0 ss skenv_src skenv_tgt):
      <<SIMSKENV: sim_skenv sm1 ss skenv_src skenv_tgt>>.
  Proof.
    induction MFUTURE; ss. des.
    - eapply IHMFUTURE; eauto. eapply mlepriv_preserves_sim_skenv; eauto.
    - eapply IHMFUTURE; eauto. eapply mle_preserves_sim_skenv; eauto.
  Qed.

End SimSymb.


From cap_machine.binary_model.ftlr_binary Require Export Mov_binary Jmp_binary Jnz_binary Load_binary Store_binary AddSubLt_binary Lea_binary Restrict_binary Subseg_binary IsPtr_binary Get_binary StoreU_binary LoadU_binary PromoteU_binary.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine.binary_model Require Export logrel_binary region_invariants_binary.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {stsg : STSG Addr region_type Σ} {heapg : heapG Σ}
          {nainv: logrel_na_invs Σ} {cfgg : cfgSG Σ}
          `{MP: MachineParameters}.

  Notation STS := (leibnizO (STS_states * STS_rels)).
  Notation STS_STD := (leibnizO (STS_std_states Addr region_type)).
  Notation WORLD := (prodO STS_STD STS).
  Implicit Types W : WORLD.

  Notation D := (WORLD -n> (prodO (leibnizO Word) (leibnizO Word)) -n> iPropO Σ).
  Notation R := (WORLD -n> (prodO (leibnizO Reg) (leibnizO Reg)) -n> iPropO Σ).
  Implicit Types v : (prodO (leibnizO Word) (leibnizO Word)).
  Implicit Types interp : (D).

  Lemma extract_r_ex r (reg : RegName) :
    (∃ w, r !! reg = Some w) →
    ⊢ (([∗ map] r0↦w ∈ r, r0 ↦ᵣ w) → ∃ w, reg ↦ᵣ w).
  Proof.
    intros [w Hw].
    iIntros "Hmap". iExists w.
    iApply (big_sepM_lookup (λ reg' i, reg' ↦ᵣ i)%I r reg w); eauto.
  Qed.

  Lemma extract_r_ex_spec r (reg : RegName) :
    (∃ w, r !! reg = Some w) →
    ⊢ (([∗ map] r0↦w ∈ r, r0 ↣ᵣ w) → ∃ w, reg ↣ᵣ w).
  Proof.
    intros [w Hw].
    iIntros "Hmap". iExists w.
    iApply (big_sepM_lookup (λ reg' i, reg' ↣ᵣ i)%I r reg w); eauto.
  Qed.

  Lemma extract_r reg (r : RegName) w :
    reg !! r = Some w →
    ⊢ (([∗ map] r0↦w ∈ reg, r0 ↦ᵣ w) →
      (r ↦ᵣ w ∗ (∀ x', r ↦ᵣ x' -∗ [∗ map] k↦y ∈ <[r := x']> reg, k ↦ᵣ y))).
  Proof.
    iIntros (Hw) "Hmap".
    iDestruct (big_sepM_lookup_acc (λ (r : RegName) i, r ↦ᵣ i)%I reg r w) as "Hr"; eauto.
    iSpecialize ("Hr" with "[Hmap]"); eauto. iDestruct "Hr" as "[Hw Hmap]".
    iDestruct (big_sepM_insert_acc (λ (r : RegName) i, r ↦ᵣ i)%I reg r w) as "Hupdate"; eauto.
    iSpecialize ("Hmap" with "[Hw]"); eauto.
    iSpecialize ("Hupdate" with "[Hmap]"); eauto.
  Qed.

  Lemma extract_r_spec reg (r : RegName) w :
    reg !! r = Some w →
    ⊢ (([∗ map] r0↦w ∈ reg, r0 ↣ᵣ w) →
      (r ↣ᵣ w ∗ (∀ x', r ↣ᵣ x' -∗ [∗ map] k↦y ∈ <[r := x']> reg, k ↣ᵣ y))).
  Proof.
    iIntros (Hw) "Hmap".
    iDestruct (big_sepM_lookup_acc (λ (r : RegName) i, r ↣ᵣ i)%I reg r w) as "Hr"; eauto.
    iSpecialize ("Hr" with "[Hmap]"); eauto. iDestruct "Hr" as "[Hw Hmap]".
    iDestruct (big_sepM_insert_acc (λ (r : RegName) i, r ↣ᵣ i)%I reg r w) as "Hupdate"; eauto.
    iSpecialize ("Hmap" with "[Hw]"); eauto.
    iSpecialize ("Hupdate" with "[Hmap]"); eauto.
  Qed.

  Instance addr_inhabited: Inhabited Addr := populate (A 0%Z eq_refl eq_refl).

  Global Instance ifcond_pers : Persistent (if writeAllowed p then read_write_cond a interp else ∃ P : D, ⌜∀ Wv : WORLD * (prodO (leibnizO Word) (leibnizO Word)), Persistent (P Wv.1 Wv.2)⌝ ∧ read_cond a P interp)%I.
  Proof. intros. destruct (writeAllowed p);apply _. Qed.
  Global Instance ifwcond_pers : Persistent (if decide (writeAllowed_in_r_a (<[PC:=inr (p, g, b, e, a)]> r) a) then wcond P interp else emp)%I.
  Proof. intros. case_decide;apply _. Qed.
  Global Instance if_pers (P: D) : Persistent (if decide (ρ = Monotemporary)
                                               then future_pub_a_mono a (λ Wv, P Wv.1 Wv.2) w1 w2
                                               else future_priv_mono (λ Wv, P Wv.1 Wv.2) w1 w2).
  Proof. intros. case_decide;apply _. Qed.

  Theorem fundamental_binary W r p g b e (a : Addr) :
    ⊢ ((⌜p = RX⌝ ∨ ⌜p = RWX⌝ ∨ ⌜p = RWLX ∧ g = Directed⌝) →
       spec_ctx →
       region_conditions W p g b e →
       interp_expression r W (inr ((p,g),b,e,a),inr ((p,g),b,e,a))).
  Proof.
    iIntros (Hp) "#Hspec #Hinv /=".
    iIntros "[Hregs [Hmreg [Hsreg [Hr [Hsts [Hown Hj]]]]]]".
    iSplit; eauto; simpl.
    iRevert (Hp) "Hinv".
    iLöb as "IH" forall (W r p g b e a).
    iAssert (⌜∀ w, <[PC:=w]> r.1 = <[PC:=w]> r.2⌝)%I as %Heqregs.
    { iIntros (w). iDestruct (interp_reg_eq _ _ _ w with "Hregs") as %Heqregs. auto. }
    iDestruct "Hregs" as "[Hfull Hreg]".
    iIntros (Hp) "#Hinv".
    rewrite -Heqregs.
    iDestruct "Hfull" as "%". iDestruct "Hreg" as "#Hreg".
    iApply (wp_bind (fill [SeqCtx])).
    destruct (decide (isCorrectPC (inr ((p,g),b,e,a)))).
    - (* Correct PC *)
      assert ((b <= a)%a ∧ (a < e)%a) as Hbae.
      { eapply in_range_is_correctPC; eauto.
        unfold le_addr; lia. }
      iDestruct (extract_from_region_inv_regs a a with "[Hmreg] Hinv") as (P Hpers) "(#Hinva & #Hrcond & #Hwcond)";auto;[|iFrame "# %"|].
      { destruct Hp as [-> | [-> | [? ->] ] ];auto. subst;auto. }
      iDestruct (extract_from_region_inv _ _ a with "Hinv") as "[_ Hstate_a]";auto.
      iDestruct "Hstate_a" as %Hstate_a.
      assert (∃ (ρ : region_type), (std W) !! a = Some ρ ∧ ρ ≠ Revoked
                                   ∧ (∀ g, ρ ≠ Monostatic g) ∧ (∀ w, ρ ≠ Uninitialized w))
        as [ρ [Hρ [Hne_rev [Hne_mono Hne_uninit] ] ] ].
      { destruct (machine_base.pwl p); [rewrite Hstate_a;eexists;eauto|].
        destruct g; [rewrite Hstate_a|rewrite Hstate_a|destruct Hstate_a as [-> | ->] ];eexists;eauto. }
      iDestruct (region_open W a with "[$Hinva $Hr $Hsts]")
        as (w1 w2) "(Hr & Hsts & Hstate & Ha & Ha' & #Hmono & Hw) /=";[|apply Hρ|..].
      { destruct ρ;auto;[done|by specialize (Hne_mono g0)|by specialize (Hne_uninit p0)]. }
      iDestruct ((big_sepM_delete _ _ PC) with "Hmreg") as "[HPC Hmap]";
        first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
      iDestruct ((big_sepM_delete _ _ PC) with "Hsreg") as "[HsPC Hsmap]";
        first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
      iAssert (▷ ⌜w1 = w2⌝)%I as "#>Heq".
      { iNext. iApply (interp_eq W). iDestruct "Hrcond" as "[Hrcond _]". iApply "Hrcond". iFrame. }
      iDestruct "Heq" as %<-.
      destruct (decodeInstrW w1) eqn:Hi. (* proof by cases on each instruction *)
      + (* Jmp *)
        iApply (jmp_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Jnz *)
        iApply (jnz_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Mov *)
        iApply (mov_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Load *)
        iApply (load_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Store *)
        iApply (store_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Lt *)
        iApply (add_sub_lt_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Add *)
        iApply (add_sub_lt_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Sub *)
        iApply (add_sub_lt_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Lea *)
        iApply (lea_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Restrict *)
        iApply (restrict_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Subseg *)
        iApply (subseg_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* IsPtr *)
        iApply (isptr_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetL *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetL _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetP *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetP _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetB *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetB _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetE *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetE _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* GetA *)
        iApply (get_case _ _ _ _ _ _ _ _ _ _ _ (GetA _ _) with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]");
          try iAssumption; eauto.
      + (* Fail *)
        iApply (wp_fail with "[HPC Ha]"); eauto; iFrame.
        iNext. iIntros "[HPC Ha] /=".
        iApply wp_pure_step_later; auto.
        iApply wp_value.
        iNext. iIntros (Hcontr); inversion Hcontr.
      + (* Halt *)
        iApply (wp_halt with "[HPC Ha]"); eauto; iFrame.
        iNext. iIntros "[HPC Ha] /=".
        iMod (step_halt _ [SeqCtx] with "[$HsPC $Ha' $Hj $Hspec]") as "(Hj & HsPC & Ha')";eauto.
        iMod (do_step_pure _ [] with "[$Hspec $Hj]") as "Hj /=";auto.
        iDestruct (region_close _ _ _ _ _ ρ with "[$Hr $Ha $Ha' $Hstate $Hmono Hw]") as "Hr";[auto|iFrame "#"; auto|].
        { destruct ρ;auto;[|specialize (Hne_mono g0)|specialize (Hne_uninit p0)]; contradiction. }
        iApply wp_pure_step_later; auto.
        iApply wp_value.
        iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=".
        apply lookup_insert. rewrite delete_insert_delete. iFrame.
        iDestruct ((big_sepM_delete _ _ PC) with "[HsPC Hsmap]") as "Hsmap /=".
        apply lookup_insert. rewrite delete_insert_delete. iFrame.
        rewrite insert_insert. iNext. iIntros (_).
        iExists (<[PC:=inr (p, g, b, e, a)]> r.1,<[PC:=inr (p, g, b, e, a)]> r.1),W. iFrame.
        iAssert (⌜related_sts_priv_world W W⌝)%I as "#Hrefl".
        { iPureIntro. apply related_sts_priv_refl_world. }
        iFrame "#".
        iPureIntro. intros r0. destruct (reg_eq_dec PC r0).
        * subst r0; rewrite lookup_insert; eauto.
        * rewrite lookup_insert_ne//. destruct H with r0;eauto.
      + (* LoadU *)
      iApply (loadU_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]"); try iAssumption; eauto.
      + (* StoreU *)
        iApply (storeU_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]"); try iAssumption; eauto.
      + (* PromoteU *)
        iApply (promoteU_case with "[] [] [] [] [] [Hmono] [] [] [Hw] [Hsts] [Hown] [Hr] [Hstate] [Ha] [Ha'] [HPC] [Hmap] [HsPC] [Hsmap] [Hj]"); try iAssumption; eauto.
   - (* Not correct PC *)
     iDestruct ((big_sepM_delete _ _ PC) with "Hmreg") as "[HPC Hmap]";
       first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
     iApply (wp_notCorrectPC with "HPC"); eauto.
     iNext. iIntros "HPC /=".
     iApply wp_pure_step_later; auto.
     iApply wp_value.
     iNext. iIntros (Hcontr); inversion Hcontr.
     Unshelve. apply _.
  Qed.

  (* the execute condition can be regained using the FTLR on read allowed permissions *)
  Lemma interp_exec_cond_binary W p g b e a :
    p = RX ∨ p = RWX ∨ p = RWLX ->
    spec_ctx -∗
    interp W (inr (p,g,b,e,a),inr (p,g,b,e,a)) -∗ exec_cond W b e g p b e g p interp.
  Proof.
    iIntros (Hra) "#Hspec #Hw".
    iIntros (a0 r W' Hin) "#Hfuture". iModIntro.
    destruct g.
    + iDestruct (interp_monotone_nm with "Hfuture [] Hw") as "Hw'";[auto|].
      iDestruct (readAllowed_implies_region_conditions with "Hw'") as "Hread_cond";[destruct Hra as [-> | [-> | ->] ];auto|].
      iApply fundamental_binary;[|iFrame "#"|eauto]. destruct Hra as [-> | [-> | ->] ];auto.
      rewrite fixpoint_interp1_eq /=. done.
    + iDestruct (interp_monotone_nm with "Hfuture [] Hw") as "Hw'";[auto|].
      iDestruct (readAllowed_implies_region_conditions with "Hw'") as "Hread_cond";[destruct Hra as [-> | [-> | ->] ];auto|].
      iApply fundamental_binary;[|iFrame "#"|eauto]. destruct Hra as [-> | [-> | ->] ];auto.
      rewrite fixpoint_interp1_eq /=. done.
    + iDestruct (interp_monotone_a with "[Hfuture] Hw") as "Hw'";[auto|].
      2: iDestruct (readAllowed_implies_region_conditions with "Hw'") as "Hread_cond";[destruct Hra as [-> | [-> | ->] ];auto|].
      2: iApply fundamental_binary;[|iFrame "#"|eauto];destruct Hra as [-> | [-> | ->] ];auto.
      simpl. destruct Hra as [-> | [-> | ->] ];auto.
  Qed.

  Lemma fundamental_binary_from_interp_correctPC W p g b e a r (w:Word) :
    p = RX ∨ p = RWX ∨ (p = RWLX ∧ g = Directed) →
    ⊢ spec_ctx -∗ interp W (inr (p, g, b, e, a),w) -∗
      interp_expression r W (inr (p,g,b,e,a),w).
  Proof.
    iIntros (Hp) "HV Hv". iDestruct (interp_eq with "Hv") as %<-.
    iApply (fundamental_binary with "[] HV"); auto.
    iApply (readAllowed_implies_region_conditions with "Hv").
    destruct Hp as [-> | [-> | [ -> -> ] ] ]; eauto.
  Qed.

  Lemma fundamental_binary_not_correctPC r W p g b e a :
    ⊢ ⌜¬ isCorrectPC (inr ((p,g),b,e,a))⌝ →
    interp_expression r W (inr ((p,g),b,e,a),inr ((p,g),b,e,a)).
  Proof.
    iIntros (Hnvpc). iIntros "(H1 & Hmreg & H3 & H4 & H5)".
    iSplit;auto. rewrite /interp_conf.
    iDestruct ((big_sepM_delete _ _ PC) with "Hmreg") as "[HPC Hmap]";
      first apply (lookup_insert _ _ (inr (p, g, b, e, a))).
    iApply (wp_bind (fill [SeqCtx])).
    iApply (wp_notCorrectPC with "HPC"); eauto.
    iNext. iIntros "HPC /=".
    iApply wp_pure_step_later; auto.
    iApply wp_value.
    iNext. iIntros (Hcontr); inversion Hcontr.
  Qed.

  Corollary fundamental_binary_from_interp r W p g b e a (w : Word) :
    spec_ctx -∗
    interp W (inr ((p,g),b,e,a),w) -∗
    interp_expression r W (inr ((p,g),b,e,a),w).
  Proof.
    iIntros "#Hspec #Hinterp".
    iDestruct (interp_eq with "Hinterp") as %<-.
    destruct (decide (isCorrectPC (inr ((p,g),b,e,a)))).
    - assert (p = RX ∨ p = RWX ∨ p = RWLX) as Hp;[inversion i;auto|].
      iAssert (⌜p = RWLX → g = Directed⌝)%I as %Hmono.
      { iIntros (->). iDestruct (writeLocalAllowed_implies_local with "Hinterp") as %Hmono;[auto|destruct g;auto]. }
      iApply (fundamental_binary_from_interp_correctPC with "Hspec Hinterp").
      destruct Hp as [-> | [-> | ->] ];auto.
    - iApply fundamental_binary_not_correctPC. auto.
  Qed.

  Lemma updatePcPerm_RX w g b e a :
    inr (RX, g, b, e, a) = updatePcPerm w ->
    w = inr (RX, g, b, e, a) ∨ w = inr (E, g, b, e, a).
  Proof.
    intros Hperm.
    destruct w;inversion Hperm.
    destruct c,p,p,p,p;simplify_eq;auto.
  Qed.

  Lemma exec_binary_wp W p g b e a :
    isCorrectPC (inr (p, g, b, e, a)) ->
    exec_cond W b e g p b e g p interp -∗
    ∀ r W', future_world g e W W' → ▷ ((interp_expr interp r) W') (inr (p, g, b, e, a),inr (p, g, b, e, a)).
  Proof.
    iIntros (Hvpc) "Hexec".
    rewrite /exec_cond /enter_cond.
    iIntros (r W'). rewrite /future_world.
    assert (a ∈ₐ[[b,e]])%I as Hin.
    { rewrite /in_range. inversion Hvpc; subst. auto. }
    destruct g.
    - iIntros (Hrelated).
      iSpecialize ("Hexec" $! a r W' Hin Hrelated).
      iFrame.
    - iIntros (Hrelated).
      iSpecialize ("Hexec" $! a r W' Hin Hrelated).
      iFrame.
    - iIntros (Hrelated).
      iSpecialize ("Hexec" $! a r W' Hin Hrelated).
      iFrame.
  Qed.

  (* The following lemma is to assist with a pattern when jumping to unknown valid capablities *)
  Lemma jmp_or_fail_binary_spec W (w w' : Word) φ :
    spec_ctx
    -∗ (interp W (w,w')
    -∗ (if decide (isCorrectPC (updatePcPerm w)) then
          (∃ p g b e a, ⌜w = inr (p,g,b,e,a)⌝
          ∗ □ ∀ r W', future_world g e W W' → ▷ ((interp_expr interp r) W') (updatePcPerm w,updatePcPerm w'))
        else
          φ FailedV ∗ PC ↦ᵣ updatePcPerm w -∗ WP Seq (Instr Executable) {{ φ }} )).
  Proof.
    iIntros "#Hspec #Hw".
    iDestruct (interp_eq with "Hw") as %<-.
    destruct (decide (isCorrectPC (updatePcPerm w))).
    - inversion i.
      destruct w;inversion H. destruct c,p0,p0,p0; inversion H.
      destruct H1 as [-> | [-> | ->] ].
      + destruct p0; simpl in H; simplify_eq.
        * iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
          iDestruct (interp_exec_cond_binary with "Hspec Hw") as "Hexec";[auto|].
          iApply exec_binary_wp;auto.
        * iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
          rewrite /= fixpoint_interp1_eq /=.
          iDestruct "Hw" as "[_ Hw]".
          iExact "Hw".
      + destruct p0; simpl in H; simplify_eq.
        iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
        iDestruct (interp_exec_cond_binary with "Hspec Hw") as "Hexec";[auto|].
        iApply exec_binary_wp;auto.
      + destruct p0; simpl in H; simplify_eq.
        iExists _,_,_,_,_; iSplit;[eauto|]. iModIntro.
        iDestruct (interp_exec_cond_binary with "Hspec Hw") as "Hexec";[auto|].
        iApply exec_binary_wp;auto.
    - iIntros "[Hfailed HPC]".
      iApply (wp_bind (fill [SeqCtx])).
      iApply (wp_notCorrectPC with "HPC");eauto.
      iNext. iIntros "_". iApply wp_pure_step_later;auto.
      iNext. iApply wp_value. iFrame.
  Qed.

End fundamental.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RunComplete.Spec.
Require Import RunAux.Spec.
Require Import RunLoop.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition smc_rec_run_spec (rec_addr: Z64) (rec_run_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match rec_addr, rec_run_addr with
    | VZ64 _rec_addr, VZ64 _rec_run_addr =>
      rely is_int64 _rec_run_addr;
      when'' _g_rec_run_base, _g_rec_run_ofst == find_granule_spec (VZ64 _rec_run_addr) adt;
      rely is_int _g_rec_run_ofst;
      when _t'8 == is_null_spec (_g_rec_run_base, _g_rec_run_ofst) adt;
      rely is_int _t'8;
      if (_t'8 =? 1) then
        Some (adt, (VZ64 1))
      else
        rely is_int64 _rec_addr;
        when'' _g_rec_base, _g_rec_ofst, adt == find_lock_unused_granule_spec (VZ64 _rec_addr) (VZ64 3) adt;
        rely is_int _g_rec_ofst;
        when _t'7 == is_null_spec (_g_rec_base, _g_rec_ofst) adt;
        rely is_int _t'7;
        if (_t'7 =? 1) then
          Some (adt, (VZ64 1))
        else
          when adt == atomic_granule_get_spec (_g_rec_base, _g_rec_ofst) adt;
          when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
          when adt == ns_granule_map_spec 0 (_g_rec_run_base, _g_rec_run_ofst) adt;
          when _t'6, adt == ns_buffer_read_rec_run_spec 0 adt;
          rely is_int _t'6;
          if (_t'6 =? 0) then
            when adt == ns_buffer_unmap_spec 0 adt;
            when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
            Some (adt, (VZ64 1))
          else
            when'' _rec_base, _rec_ofst, adt == granule_map_spec (_g_rec_base, _g_rec_ofst) 3 adt;
            rely is_int _rec_ofst;
            when adt == granule_lock_spec (_g_rec_base, _g_rec_ofst) adt;
            when _t'5 == get_rec_runnable_spec (_rec_base, _rec_ofst) adt;
            rely is_int _t'5;
            if (_t'5 =? 0) then
              when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
              when adt == buffer_unmap_spec (_rec_base, _rec_ofst) adt;
              when adt == ns_buffer_unmap_spec 0 adt;
              when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
              Some (adt, (VZ64 1))
            else
              when _t'4, adt == complete_mmio_emulation_spec (_rec_base, _rec_ofst) adt;
              rely is_int _t'4;
              if (_t'4 =? 0) then
                when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
                when adt == buffer_unmap_spec (_rec_base, _rec_ofst) adt;
                when adt == ns_buffer_unmap_spec 0 adt;
                when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
                Some (adt, (VZ64 1))
              else
                when adt == complete_hvc_exit_spec (_rec_base, _rec_ofst) adt;
                when adt == reset_last_run_info_spec (_rec_base, _rec_ofst) adt;
                when adt == reset_disposed_info_spec (_rec_base, _rec_ofst) adt;
                when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
                when adt == rec_run_loop_spec (_rec_base, _rec_ofst) adt;
                Some (adt, (VZ64 2))
     end.

End Spec.


(*
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     Classical
     Morphisms
     JMeq
     List
     Lia.

From SPICY Require Import
     MyPrelude
     Automation
     Maps
     Keys
     Messages
     MessageEq
     Tactics
     Simulation
     RealWorld
     AdversaryUniverse
     AdversarySafety
     SafetyAutomation
     SyntacticallySafe

     Theory.CipherTheory
     Theory.InvariantsTheory
     Theory.KeysTheory
     Theory.MessagesTheory
     Theory.MessageEqTheory
     Theory.UsersTheory

     ModelCheck.ModelCheck
     ModelCheck.Commutation
     ModelCheck.LabelsAlign
     ModelCheck.NoResends
     ModelCheck.RealWorldStepLemmas
     ModelCheck.SafeProtocol
.

From Frap Require Import
     Invariant.

From Frap Require
     Sets.

From SPICY Require
     IdealWorld.

Import SafetyAutomation.

(* For later import of set notations inside sections *)
Module Foo <: Sets.EMPTY.
End Foo.
Module SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Section NextSteps.

  Inductive nextStepSS {A B} (u_id : user_id) (userData : user_data A)
    : universe A B (* -> universe A B *) -> Prop :=

  | NextSilent : forall U U',
      U.(users) $? u_id = Some userData
      -> indexedRealStep u_id Silent U U'
      -> (forall uid' U', uid' > u_id -> ~ indexedRealStep uid' Silent U U')
      -> nextStepSS u_id userData U

  | NoSilents : forall U U' a,
      U.(users) $? u_id = Some userData

      (* No one can silently step *)
      -> (forall uid' U', ~ indexedRealStep uid' Silent U U')

      -> indexedRealStep u_id (Action a) U U'
      -> nextStepSS u_id userData U.

  Inductive stepSS (t__hon t__adv : type) :
      @ModelState t__hon t__adv
    -> @ModelState t__hon t__adv
    -> Prop :=

  | StepNextSS : forall ru ru' iu iu' u_id ud st st' v v',
      nextStepSS u_id ud ru
      -> st = (ru,iu,v)
      -> st' = (ru',iu',v')
      -> indexedModelStep u_id st st'
      -> stepSS st st'.

End NextSteps.

(* Load the set notations *)
Import SN.

Definition TrSS {t__hon t__adv} (ru0 : RealWorld.universe t__hon t__adv) (iu0 : IdealWorld.universe t__hon) :=
  {| Initial := {(ru0, iu0, true)};
     Step    := @stepSS t__hon t__adv |}.

#[export] Hint Resolve adversary_remains_lame_step : core.
#[export] Hint Constructors stepSS nextStepSS : core.

(* #[export] Hint Resolve indexedIdealSteps_ideal_steps : core. *)
#[export] Hint Constructors indexedModelStep indexedIdealStep indexedRealStep : core.
#[export] Hint Resolve action_matches_other_user_silent_step_inv : core.

Lemma step_then_step' :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}
      -> message_queues_ok cs usrs gks
      -> user_cipher_queues_ok cs (findUserKeys usrs) usrs
      -> forall usrs'' (adv'' : user_data B) cs'' gks'' ms,
          usrs'' $? uid1 = Some {| key_heap := ks;
                                   protocol := cmdc;
                                   msg_heap := qmsgs ++ ms;
                                   c_heap   := mycs;
                                   from_nons := froms;
                                   sent_nons := sents;
                                   cur_nonce := cur_n |}
          -> (forall uid u, usrs $? uid = Some u -> exists u', usrs'' $? uid = Some u')
          -> (forall cid c, cs $? cid = Some c -> cs'' $? cid = Some c)
          -> (forall cid c, cs'' $? cid = Some c -> cs $? cid = Some c \/ cs $? cid = None)
          -> (forall kid k, gks $? kid = Some k -> gks'' $? kid = Some k)
          -> exists bd'',
              step_user lbl suid
                        (usrs'', adv'', cs'', gks'', ks, qmsgs ++ ms, mycs, froms, sents, cur_n, cmd)
                        bd''.
Proof.
  induction 1; inversion 1; inversion 1
  ; intros
  ; subst
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  - eapply IHstep_user in H26; eauto.
    split_ex.
    dt x; eexists; econstructor; eauto.

  - rewrite <- app_assoc,
            <- app_comm_cons.
    eexists; econstructor; eauto.
    invert H6;
      [ econstructor 1
      | econstructor 2
      | econstructor 3
      ]; eauto.

    rewrite Forall_forall in H7|- *
    ; intros.

    generalize (H7 _ H)
    ; intros
    ; destruct x
    ; eauto.

    unfold not
    ; intros MAP
    ; apply H0.

    msg_queue_prop.
    apply List.Forall_app in H2
    ; split_ex
    ; rewrite Forall_forall in H2
    ; apply H2 in H
    ; split_ex.

    invert MAP;
      [ econstructor 1
      | econstructor 2
      | econstructor 3
      ]
      ; eauto
      ; specialize (H8 _ eq_refl).

    apply H39 in H11; split_ors; clean_map_lookups; eauto.
    apply H39 in H11; split_ors; clean_map_lookups; eauto.

  - apply H36 in H2; split_ex; eauto.
    eexists; econstructor; eauto.
    unfold keys_mine in H0 |- *; intros.
    apply H0.
    unfold findKeysCrypto in H2 |- *.
    destruct msg; eauto.
    assert (List.In c_id mycs') by eauto.
    user_cipher_queues_prop.
    generalize (H37 _ _  H5); intros; context_map_rewrites; trivial.

  - eexists.
    eapply StepEncrypt with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - eexists.
    eapply StepSign with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - eexists.
    eapply StepGenerateKey with (k_id0 := next_key gks''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.
    Unshelve.
    auto.
Qed.

Lemma step_then_silent_step :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}
      (* -> forall ctx styp, syntactically_safe uid1 (compute_ids usrs) ctx cmd styp *)
      (* -> typingcontext_sound ctx usrs cs uid1 *)
      -> message_queues_ok cs usrs gks
      -> user_cipher_queues_ok cs (findUserKeys usrs) usrs
      -> forall uid2 bd2 bd2',
          step_user Silent (Some uid2) bd2 bd2'

          -> forall cmd2 ks2 qmsgs2 mycs2 froms2 sents2 cur_n2 usrs'' cmdc' ud2,

            uid1 <> uid2
            -> usrs $? uid2 = Some ud2
            -> bd2 = build_data_step (mkUniverse usrs adv cs gks) ud2
            -> usrs' $? uid2 = Some {| key_heap := ks2;
                                      protocol := cmd2;
                                      msg_heap := qmsgs2;
                                      c_heap   := mycs2;
                                      from_nons := froms2;
                                      sent_nons := sents2;
                                      cur_nonce := cur_n2 |}
            -> usrs'' = usrs' $+ (uid1, {| key_heap := ks';
                                          protocol := cmdc';
                                          msg_heap := qmsgs';
                                          c_heap   := mycs';
                                          from_nons := froms';
                                          sent_nons := sents';
                                          cur_nonce := cur_n' |})
            -> exists bd2'',
                step_user Silent (Some uid2)
                          (usrs'', adv', cs', gks', ks2, qmsgs2, mycs2, froms2, sents2, cur_n2, cmd2)
                          bd2''
.
Proof.

  Ltac ss :=
    clean_map_lookups
    ; unfold build_data_step in *
    ; simpl in *
    ; eauto
    ; match goal with
      | [ H : step_user Silent (Some ?uid) _ ?bd
          |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
        dt bd
        ; eapply step_then_step' with (ms := []) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
      end
    ; eauto
    ; try rewrite app_nil_r in *
    ; eauto
    ; try
        match goal with
        | [ |- forall _ _, ?usrs $? _ = Some _ -> exists _, ?usrs $+ (?uid,_) $? _ = Some _ ] =>
          let UID := fresh "UID"
          in intros UID *; destruct (UID ==n uid); subst; eexists; clean_map_lookups; eauto
        end.

  induction 1; inversion 1; inversion 1; intros; subst
  ; try solve [ ss ]; clean_context.

  - destruct (rec_u_id ==n uid2); subst; clean_map_lookups.
    + destruct ud2
      ; clean_map_lookups
      ; unfold build_data_step in *
      ; simpl in *
      ; eauto
      ; match goal with
        | [ H : step_user Silent (Some ?uid) _ ?bd
            |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
          dt bd
          ; eapply step_then_step' with (ms := [existT _ _ msg]) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
        end
      ; eauto
      ; try rewrite app_nil_r in *
      ; eauto
      ; try
          match goal with
          | [ |- forall _ _, ?usrs $? _ = Some _ -> exists _, ?usrs $+ (?uid,_) $? _ = Some _ ] =>
            let UID := fresh "UID"
            in intros UID *; destruct (UID ==n uid); subst; eexists; clean_map_lookups; eauto
          end.

      intros.
      destruct (uid ==n uid1); destruct (uid ==n uid2); subst; eexists; clean_map_lookups; eauto.

    + ss.
      intros.
      destruct (uid ==n uid1); destruct (uid ==n rec_u_id); subst; eexists; clean_map_lookups; eauto.

  - unfold build_data_step in *
    ; clean_map_lookups
    ; simpl in *.

    match goal with
    | [ H : step_user Silent (Some ?uid) _ ?bd
        |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
      dt bd
      ; eapply step_then_step' with (ms := []) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
    end
    ; try rewrite app_nil_r in *
    ; split_ex; eauto.

    intros.
    destruct (uid ==n uid1); destruct (uid ==n uid2); subst; eexists; clean_map_lookups; eauto.

    intros.
    destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

  - unfold build_data_step in *
    ; clean_map_lookups
    ; simpl in *.

    match goal with
    | [ H : step_user Silent (Some ?uid) _ ?bd
        |- exists _, step_user _ (Some ?uid) (?us,_,?cs,?gks,_,_,_,_,_,_,_) _ ] =>
      dt bd
      ; eapply step_then_step' with (ms := []) (usrs'' := us) (cs'' := cs) (gks'' := gks) in H
    end
    ; try rewrite app_nil_r in *
    ; split_ex; eauto.

    intros.
    destruct (uid ==n uid1); destruct (uid ==n uid2); subst; eexists; clean_map_lookups; eauto.

    intros.
    destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

    Unshelve.
    all: eauto.
Qed.

Lemma step_limited_change_other_user_qmsgs :
  forall A B cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
    (cmd cmd' : user_cmd (Base A)) ks ks' qmsgs qmsgs' mycs mycs'
    froms froms' sents sents' cur_n cur_n' uid uid' lbl
    ks1 cmd1 qmsgs1 mycs1 froms1 sents1 cur_n1,

    usrs $? uid = Some (mkUserData ks1 cmd1 qmsgs1 mycs1 froms1 sents1 cur_n1)
    -> uid <> uid'
    -> usrs $? uid' = Some (mkUserData ks cmd qmsgs mycs froms sents cur_n)
    -> step_user lbl (Some uid')
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
    -> exists qmsgs1',
        (usrs' $+ (uid', mkUserData ks' cmd' qmsgs' mycs' froms' sents' cur_n')) $? uid
        = Some (mkUserData ks1 cmd1 qmsgs1' mycs1 froms1 sents1 cur_n1)
        /\ (qmsgs1' = qmsgs1 \/ exists m, qmsgs1' = qmsgs1 ++ [m])
.
Proof.
  intros.
  specialize (user_step_adds_no_users H2 eq_refl eq_refl); intros.
  generalize H2; intros STEP.
  eapply step_limited_change_other_user with (u_id2 := uid) in STEP; eauto; split_ex.

  split_ors; split_ex; eauto.
Qed.

Definition useless_summary : summary :=
  {| sending_to := Sets.scomp (fun (n : nat) => True) |}.

Lemma useless_summary_summarizes :
  forall t cmd,
    @summarize t cmd useless_summary.
Proof.
  induction cmd; econstructor; eauto; simpl.
  unfold Sets.scomp, Sets.In; simpl; trivial.
Qed.

Lemma silent_step_na_commuting :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'

    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n',

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> lbl = Silent
      -> forall s,
          exists t cmd__n,
            @nextAction _ t cmd cmd__n
            /\ commutes cmd__n s.
Proof.
  #[export] Hint Constructors nextAction : core.
  induction 1; inversion 1; inversion 1; intros; subst; simpl; try discriminate
  ; try solve [ (do 2 eexists); split; eauto; simpl; trivial ].

  specialize (IHstep_user _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ eq_refl eq_refl eq_refl s)
  ; split_ex
  ; (do 2 eexists)
  ; split
  ; [ econstructor |]
  ; eauto.
Qed.

Lemma step_didnt_appear :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs' ms
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs ++ ms, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> lbl = Silent
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs ++ ms;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}
      -> forall usrs'' (adv'' : user_data B) cs'' gks'',
          usrs'' $? uid1 = Some {| key_heap := ks;
                                   protocol := cmdc;
                                   msg_heap := qmsgs;
                                   c_heap   := mycs;
                                   from_nons := froms;
                                   sent_nons := sents;
                                   cur_nonce := cur_n |}
          -> forall ctx styp, syntactically_safe uid1 (compute_ids usrs'') ctx cmd styp
          -> typingcontext_sound ctx usrs'' cs'' uid1
          -> keys_and_permissions_good gks'' usrs'' adv''.(key_heap)
          -> user_cipher_queues_ok cs'' (findUserKeys usrs'') usrs''
          -> (forall uid u, usrs'' $? uid = Some u -> exists u', usrs $? uid = Some u')
          -> (forall cid c, cs'' $? cid = Some c -> cs $? cid = Some c)
          -> (forall cid c, cs $? cid = Some c -> cs'' $? cid = Some c \/ cs'' $? cid = None)
          -> (forall kid k, gks'' $? kid = Some k -> gks $? kid = Some k)
          -> exists bd'',
              step_user Silent suid
                        (usrs'', adv'', cs'', gks'', ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                        bd''.
Proof.
  induction 1; inversion 1; inversion 1
  ; intros
  ; subst
  ; try discriminate
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  - invert H28.
    eapply IHstep_user in H27; eauto.
    split_ex.
    dt x; eexists; econstructor; eauto.

  - unfold typingcontext_sound in *
    ; split_ex
    ; invert H38
    ; process_ctx.
    keys_and_permissions_prop.

    generalize (H13 _ _ H9)
    ; generalize (H13 _ _ H10)
    ; intros; split_ex.

    generalize (H45 _ _ H19)
    ; generalize (H45 _ _ H20)
    ; intros
    ; clean_map_lookups.

    eapply StepEncrypt with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - eexists.
    assert (List.In c_id mycs'0) by eauto.
    user_cipher_queues_prop.
    eapply H42 in H; split_ors; clean_map_lookups; eauto.
    keys_and_permissions_prop.

    generalize (H11 _ _ H2)
    ; generalize (H11 _ _ H3)
    ; intros
    ; clean_map_lookups
    ; clear H11.

    generalize (H43 _ _ H12)
    ; generalize (H43 _ _ H13)
    ; intros
    ; clean_map_lookups
    ; clear H43.

    econstructor; eauto.

  - keys_and_permissions_prop.

    generalize (H8 _ _ H0)
    ; intros
    ; clean_map_lookups.

    generalize (H43 _ _ H9)
    ; intros
    ; clean_map_lookups.

    eexists.
    eapply StepSign with (c_id0 := next_key cs''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

  - keys_and_permissions_prop.

    generalize (H7 _ _ H0)
    ; intros
    ; clean_map_lookups.

    generalize (H38 _ _ H8)
    ; intros
    ; clean_map_lookups.

    assert (List.In c_id mycs') by eauto.
    user_cipher_queues_prop.
    eapply H37 in H1; split_ors; clean_map_lookups; eauto.

    eexists.
    econstructor; eauto.

  - eexists.

    eapply StepGenerateKey with (k_id0 := next_key gks''); clean_map_lookups; eauto.
    eapply next_key_not_in; eauto.

    Unshelve.
    auto.
Qed.

Lemma step_then_silent_step_inv :
  forall {A B C} suid lbl bd bd',

    step_user lbl suid bd bd'
    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) uid1 ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' cmdc,

      bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')
      -> suid = Some uid1
      -> usrs $? uid1 = Some {| key_heap := ks;
                               protocol := cmdc;
                               msg_heap := qmsgs;
                               c_heap   := mycs;
                               from_nons := froms;
                               sent_nons := sents;
                               cur_nonce := cur_n |}

      -> forall uid2 bd2 bd2' cmd2 ks2 qmsgs2 mycs2 froms2 sents2 cur_n2 usrs'' cmdc' ud2,

          step_user Silent (Some uid2)
                    (usrs'', adv', cs', gks', ks2, qmsgs2, mycs2, froms2, sents2, cur_n2, cmd2)
                    bd2'
          -> uid1 <> uid2
          -> usrs $? uid2 = Some ud2
          -> bd2 = build_data_step (mkUniverse usrs adv cs gks) ud2
          -> usrs' $? uid2 = Some {| key_heap := ks2;
                                    protocol := cmd2;
                                    msg_heap := qmsgs2;
                                    c_heap   := mycs2;
                                    from_nons := froms2;
                                    sent_nons := sents2;
                                    cur_nonce := cur_n2 |}
          -> usrs'' = usrs' $+ (uid1, {| key_heap := ks';
                                        protocol := cmdc';
                                        msg_heap := qmsgs';
                                        c_heap   := mycs';
                                        from_nons := froms';
                                        sent_nons := sents';
                                        cur_nonce := cur_n' |})
          -> forall ctx styp, syntactically_safe uid2 (compute_ids usrs) ctx cmd2 styp
                        -> typingcontext_sound ctx usrs cs uid2
                        -> keys_and_permissions_good gks usrs adv.(key_heap)
                        -> user_cipher_queues_ok cs (findUserKeys usrs) usrs
                        -> exists bd2'',
                            step_user Silent (Some uid2) bd2 bd2''
.
Proof.
  induction 1; inversion 1; inversion 1; intros; subst; clean_context
  ; autorewrite with find_user_keys in *
  ; try solve [
          dt bd2'; clean_map_lookups
          ; eapply step_didnt_appear with (ms := [])
          ; try rewrite app_nil_r
          ; simpl; eauto
          ; intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto ].

  - eapply IHstep_user in H30; eauto.
  - simpl in *.
    destruct (rec_u_id ==n uid2); subst; clean_map_lookups; eauto.

    + dt bd2'; destruct ud2; clean_map_lookups.
      eapply step_didnt_appear with (ms := [existT crypto t0 msg]); simpl in *; eauto.

      intros
      ; destruct (uid1 ==n uid)
      ; destruct (uid2 ==n uid)
      ; subst; clean_map_lookups; eauto.

    + dt bd2'; clean_map_lookups
      ; eapply step_didnt_appear with (ms := [])
      ; try rewrite app_nil_r
      ; simpl in *
      ; eauto.

      intros
      ; destruct (rec_u_id ==n uid)
      ; destruct (uid1 ==n uid)
      ; subst; clean_map_lookups; eauto.

  - dt bd2'; clean_map_lookups
    ; eapply step_didnt_appear with (ms := [])
    ; try rewrite app_nil_r
    ; simpl; eauto.

    intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.

  - dt bd2'; clean_map_lookups
    ; eapply step_didnt_appear with (ms := [])
    ; try rewrite app_nil_r
    ; simpl; eauto.

    intros; destruct (uid1 ==n uid); subst; clean_map_lookups; eauto.
    intros; destruct (c_id ==n cid); subst; clean_map_lookups; eauto.
Qed.

Lemma silent_step_commutes_noblock :
  forall t__hon t__adv (usrs usrs' : honest_users t__hon) (adv adv' : user_data t__adv) cs cs' gks gks'
    ks2 ks2' qmsgs2 qmsgs2' mycs2 mycs2' froms2 froms2' sents2 sents2' cur_n2 cur_n2' cmd2 cmd2' uid2,

    usrs $? uid2 = Some (mkUserData ks2 cmd2 qmsgs2 mycs2 froms2 sents2 cur_n2)
    -> step_user Silent (Some uid2)
                (usrs, adv, cs, gks, ks2, qmsgs2, mycs2, froms2, sents2, cur_n2, cmd2)
                (usrs', adv', cs', gks', ks2', qmsgs2', mycs2', froms2', sents2', cur_n2', cmd2')
    -> forall uid1, uid1 <> uid2
    -> forall (usrs1' : honest_users t__hon) (adv1' : user_data t__adv) cs1' gks1'
        ks1 ks1' qmsgs1 qmsgs1' mycs1 mycs1' froms1 froms1' sents1 sents1' cur_n1 cur_n1' cmd1 cmd1' lbl1,

        usrs $? uid1 = Some (mkUserData ks1 cmd1 qmsgs1 mycs1 froms1 sents1 cur_n1)
        -> step_user lbl1 (Some uid1)
                  (usrs, adv, cs, gks, ks1, qmsgs1, mycs1, froms1, sents1, cur_n1, cmd1)
                  (usrs1', adv1', cs1', gks1', ks1', qmsgs1', mycs1', froms1', sents1', cur_n1', cmd1')
        -> forall ks2'' qmsgs2'' mycs2'' froms2'' sents2'' cur_n2'',
          usrs1' $? uid2 = Some (mkUserData ks2'' cmd2 qmsgs2'' mycs2'' froms2'' sents2'' cur_n2'')
        -> exists usrs2' adv2' cs2' gks2' ks2''' qmsgs2''' mycs2''' froms2''' sents2''' cur_n2''' cmd2'',
          step_user Silent (Some uid2)
                    (usrs1' $+ (uid1, mkUserData ks1' cmd1' qmsgs1' mycs1' froms1' sents1' cur_n1'),
                     adv1', cs1', gks1', ks2'', qmsgs2'', mycs2'', froms2'', sents2'', cur_n2'', cmd2)
                    (usrs2', adv2', cs2', gks2', ks2''', qmsgs2''', mycs2''', froms2''', sents2''', cur_n2''', cmd2'')
.
Proof.
  intros.

  pose proof (useless_summary_summarizes cmd1).
  generalize H0; intros SS
  ; eapply silent_step_na_commuting with (s := useless_summary) in H0; eauto
  ; split_ex.

  generalize SS; intros STEP
  ; eapply commutes_noblock with (uid1 := uid1) (uid2 := uid2) (summaries := $0 $+ (uid1,useless_summary)) in SS
  ; eauto.
Qed.

Lemma translate_trace_commute :
  forall t__hon t__adv i st st' b,
    @stepsi t__hon t__adv (1 + i) st st'
    -> lameAdv b (fst (fst st)).(adversary)
    -> syntactically_safe_U (fst (fst st))
    -> goodness_predicates (fst (fst st))
    -> (forall st'', ~ step st' st'')
    -> forall uid ud, (fst (fst st)).(users) $? uid = Some ud
    (* -> (forall uid' U', uid' > uid -> ~ indexedRealStep uid' Silent (fst (fst st)) U') *)
    -> forall bd, step_user Silent (Some uid) (build_data_step (fst (fst st)) ud) bd
    -> exists st0 st0',
          indexedModelStep uid st st0
        /\ stepsi i st0 st0'
        /\ fst st0' = fst st'
        /\ ( snd st0' = snd st' \/ (snd st0' = false /\ snd st' = true) )
.
Proof.
  induct 1; intros; eauto.
  invert H0.

  - clear IHstepsi.
    invert H; simpl in *;
      repeat
        match goal with
        | [ H : ?x = ?x |- _ ] => clear H
        | [ H : step_universe _ _ _ _ |- _ ] => invert H; dismiss_adv
        | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
        | [ H : Silent = mkULbl ?lbl _ |- _ ] => unfold mkULbl in H; destruct lbl; try discriminate
        end.

    + destruct (uid ==n u_id); subst; clean_map_lookups.

      (* equal *)
      (do 2 eexists); repeat simple apply conj; simpl; try econstructor; eauto 8.

      (* not equal *)

      unfold build_data_step in *
      ; destruct userData, ud
      ; simpl in *
      ; generalize H7; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := u_id) (u_id2 := uid) in H7
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := u_id) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id0 := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id0 := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      eapply user_step_label_deterministic in H6; eauto; discriminate.

      (* not equal *)
      unfold build_data_step in *
      ; destruct userData, ud
      ; dt bd
      ; simpl in *
      ; generalize H11; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := uid0) (u_id2 := uid) in H11
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := uid0) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      eapply user_step_label_deterministic in H6; eauto; discriminate.

      (* not equal *)
      unfold build_data_step in *
      ; destruct userData, ud
      ; dt bd
      ; simpl in *
      ; generalize H10; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := uid0) (u_id2 := uid) in H10
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := uid0) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      eapply user_step_label_deterministic in H6; eauto; discriminate.

      (* not equal *)
      unfold build_data_step in *
      ; destruct userData, ud
      ; dt bd
      ; simpl in *
      ; generalize H10; intros STEP
      ; eapply step_limited_change_other_user with (u_id1 := uid0) (u_id2 := uid) in H10
      ; eauto
      ; split_ex
      ; simpl in *.

      exfalso.
      unfold goodness_predicates in *; split_ex.

      split_ors; split_ex; clean_map_lookups
      ; eapply step_then_silent_step with (uid1 := uid0) (uid2 := uid) in STEP
      ; eauto
      ; split_ex.

      dt x
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

      dt x0
      ; eapply H4
      ; econstructor 1; eauto
      ; eapply StepUser with (u_id := uid)
      ; unfold build_data_step, buildUniverse; simpl
      ; eauto.

  - assert (LAME: lameAdv b (adversary (fst (fst st)))) by assumption.
    eapply adversary_remains_lame_step in LAME; eauto.

    assert (SS : syntactically_safe_U (fst (fst st'))) by eauto using syntactically_safe_U_preservation_step.

    assert (UNIVS : goodness_predicates (fst (fst st'))).
    eapply goodness_preservation_step; eauto.

    specialize (IHstepsi _ _ eq_refl LAME SS UNIVS H4).
    clear LAME SS UNIVS.

    dt bd; destruct ud; simpl in *.

    invert H; simpl in *;
      repeat
      match goal with
      | [ H : step_universe _ _ _ _ |- _ ] => invert H; dismiss_adv
      | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
      | [ H : Silent = mkULbl ?lbl _ |- _ ] => unfold mkULbl in H; destruct lbl; try discriminate
      end;
      (* match goal with *)
      (* | [ H : O.max_elt _ = Some _ |- _ ] => *)
      (*   let MAX := fresh "H" *)
      (*   in generalize H; intros MAX; *)
      (*        apply NatMap.O.max_elt_MapsTo in MAX; rewrite find_mapsto_iff in MAX *)
      (* end; *)
      try rename u_id into uid0.

    + destruct (uid ==n uid0); subst; clean_map_lookups.

      (* equal *)
      (do 2 eexists); repeat simple apply conj; eauto.
      econstructor; eauto.
      econstructor; eauto.

      (* not equal *)
      (* assert (LK : users ru $? uid0 = Some userData) by assumption. *)
      (* eapply H8 in LK; eauto; split_ex.     gathers summaries *)

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.
      (* specialize (H5 _ _ x H); split_ex. (* specializes summary *) *)

      generalize H9; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      Ltac clear_mislabeled_steps :=
        repeat
          match goal with
          | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
          | [ H1 : step_user (Action _) (Some ?uid) _ _
            , H2 : step_user Silent (Some ?uid) _ _ |- _ ] =>
            unfold build_data_step in *
            ; simpl in *
            ; clean_map_lookups
            ; simpl in *
            ; pose proof (user_step_label_deterministic _ _ _ _ _ _ _ _ _ H1 H2)
            ; discriminate
          end.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H14; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H14; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      (do 2 eexists); repeat simple apply conj; eauto.
      econstructor 1; eauto.
      econstructor; eauto.
      econstructor 1; eauto.
      econstructor 1; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups; clear_mislabeled_steps.

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.

      generalize H13; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H18; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H18; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      destruct (classic (labels_align (buildUniverse usrs2 adv2 cs2 gks2 uid
                {|
                key_heap := ks2;
                protocol := cmd2;
                msg_heap := qmsgs2;
                c_heap := mycs2;
                from_nons := froms2;
                sent_nons := sents2;
                cur_nonce := cur_n2 |}, iu, b0))).

      * (do 2 eexists); repeat simple apply conj; eauto.
        econstructor 1; eauto.
        econstructor; eauto.
        econstructor 2; eauto; simpl in *.

        unfold goodness_predicates in *; split_ex; simpl in *.
        specialize (H2 _ _ _ H5 eq_refl); split_ex.
        eapply action_matches_other_user_silent_step; eauto.

      * destruct x11 as [[ru1 iu1] b1].
        (do 2 eexists); repeat simple apply conj;
          [ solve [ econstructor 1; eauto ]
          | econstructor
          | ..
          ].
        econstructor 3; eauto.
        rewrite H25; eapply falsify_trace; eauto.
        eauto.
        destruct st'' as [p b2]; simpl.
        destruct b2; eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups; clear_mislabeled_steps.

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.

      generalize H12; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H17; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H17; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      eapply silent_step_labels_still_misaligned with (b := b0) (b' := b0) in H11; eauto.

      destruct x11 as [[ru1 iu1] b1].
      simpl in *.
      (do 2 eexists); repeat simple apply conj.
      econstructor 1; eauto.
      econstructor; eauto.
      econstructor 3; eauto.
      all: eauto.

    + destruct (uid ==n uid0); subst; clean_map_lookups; clear_mislabeled_steps.

      destruct userData; unfold buildUniverse, build_data_step in *; simpl in *.

      generalize H12; intros STEP
      ; eapply step_limited_change_other_user_qmsgs with (uid := uid) (uid' := uid0) in STEP
      ; eauto; split_ex.
      rename x into msg_heap'.

      specialize (IHstepsi _ _ H0); simpl in *.

      eapply silent_step_commutes_noblock with (usrs := users ru) (usrs1' := usrs0) in H6; eauto.
      2: clean_map_lookups; eauto.
      split_ex.

      generalize H6; intros SS; eapply IHstepsi in H6; eauto.
      clear IHstepsi; split_ex; subst.

      invert H6; clear_mislabeled_steps.

      pose proof (useless_summary_summarizes protocol0).
      eapply silent_step_na_commuting with (s := useless_summary) in SS; eauto
      ; split_ex.

      eapply commutes_sound with (u_id1 := uid0) (u_id2 := uid) in H17; eauto; simpl.

      split_ex; subst.
      unfold build_data_step in H17; destruct ru.
      dt x14; dt x15; destruct x16; simpl in *.

      eapply silent_step_labels_still_misaligned with (b := b0) (b' := b0) in H11; eauto.

      destruct x11 as [[ru1 iu1] b1].
      simpl in *.
      (do 2 eexists); repeat simple apply conj.
      econstructor 1; eauto.
      econstructor; eauto.
      econstructor 4; eauto.
      all: eauto.

Qed.

#[export] Hint Constructors indexedRealStep indexedIdealStep : core.

Lemma step_extra_user :
  forall A B C lbl suid bd bd',
    @step_user A B C lbl suid bd bd'

    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' uid cmdc,

      suid = Some uid
      -> usrs $? uid = Some (mkUserData ks cmdc qmsgs mycs froms sents cur_n)
      -> bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')

      -> forall uid' ud',
          ~ In uid' usrs
          -> exists bd'',
            step_user lbl (Some uid)
                      (usrs $+ (uid',ud'), adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                      bd''.
Proof.
  induction 1; inversion 3; inversion 1; intros; subst
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  eapply IHstep_user in H1; eauto.
  split_ex.
  dt x; eexists; econstructor; eauto.

  Unshelve.
  all: auto.
Qed.

Lemma silent_step_minus_user :
  forall A B C lbl suid bd bd',
    @step_user A B C lbl suid bd bd'

    -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
        (cmd cmd' : user_cmd C) ks ks' qmsgs qmsgs' mycs mycs'
        froms froms' sents sents' cur_n cur_n' uid cmdc uid' ud',

      ~ In uid' usrs
      -> suid = Some uid
      -> lbl = Silent
      -> usrs $? uid = Some (mkUserData ks cmdc qmsgs mycs froms sents cur_n)
      -> bd = (usrs $+ (uid',ud'), adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
      -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd')

      -> exists bd'',
          step_user lbl (Some uid)
                    (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
                    bd''.
Proof.
  induction 1; inversion 5; inversion 1; intros; subst
  ; try discriminate
  ; try solve [ eexists; econstructor; eauto ]
  ; clean_context.

  eapply IHstep_user in H3; eauto.
  split_ex.
  dt x; eexists; econstructor; eauto.

  Unshelve.
  all: auto.
Qed.

Lemma must_be_max_silent_step' :
  forall A B usrs adv cs gks ks qmsgs mycs froms sents cur_n cmd uid bd,
    usrs $? uid = Some (mkUserData ks cmd qmsgs mycs froms sents cur_n)
    -> @step_user A B (Base A) Silent (Some uid) (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd) bd
    -> exists uid__max U__max',
        indexedRealStep uid__max Silent
                        {| users := usrs; adversary := adv; all_ciphers := cs; all_keys := gks |} U__max'
        /\ (forall uid' U',
              uid' > uid__max ->
              ~ indexedRealStep uid' Silent
                {| users := usrs; adversary := adv; all_ciphers := cs; all_keys := gks |} U').
Proof.
  intros A B usrs.
  induction usrs using O.map_induction_max; intros.

  - unfold Empty, Raw.Empty in H.
    rewrite <- find_mapsto_iff in H0.
    unfold MapsTo in H0.
    exfalso.
    eapply H; eauto.

  - unfold Add in H0.

    destruct (x ==n uid); subst; clean_map_lookups; eauto.

    + dt bd.
      clear IHusrs1.
      exists uid; eexists.
      split.
      econstructor; eauto.
      unfold not; intros.
      invert H4; simpl in *.
      unfold O.Above in H.
      specialize (H uid').
      specialize (H0 uid'); clean_map_lookups.
      destruct (uid ==n uid'); subst; try Nat.order.
      clean_map_lookups.
      assert (usrs1 $? uid' <> None) by (clean_map_lookups; eauto).
      rewrite <- in_find_iff in H4.
      apply H in H4; lia.

    + rewrite H0 in H1; clean_map_lookups.
      assert (usrs2 = usrs1 $+ (x,e))
        by (apply map_eq_Equal; unfold Equal; eauto).
      subst.

      unfold O.Above in H.
      destruct ( classic (In x usrs1) ).
      apply H in H3; lia.

      dt bd; pose proof (silent_step_minus_user H2 H3 eq_refl eq_refl H1 eq_refl eq_refl).
      split_ex.
      dt x0.

      generalize H4; intros; eapply IHusrs1 in H4; eauto.
      clear IHusrs1.
      split_ex.

      invert H4; simpl in *.
      destruct (x ==n x0); subst; clean_map_lookups.
      destruct userData
      ; unfold build_data_step in *
      ; simpl in *.

      destruct ( classic ( exists U', indexedRealStep x Silent (mkUniverse (usrs1 $+ (x,e)) adv cs gks) U' )).
      split_ex.

      * exists x; eexists.
        split; eauto.

        unfold not; intros.
        invert H10; simpl in *.
        destruct (x ==n uid'); try lia; clean_map_lookups; eauto.
        assert (usrs1 $? uid' <> None) by (clean_map_lookups).
        rewrite <- in_find_iff in H10.
        apply H in H10; lia.

      * eapply step_extra_user in H8; split_ex; eauto.
        dt x1.
        exists x0; eexists.
        split.
        econstructor; unfold build_data_step; simpl; eauto.

        intros.
        destruct (uid' ==n x); subst; clean_map_lookups.
        ** firstorder idtac.
        ** unfold not; intros.
           invert H10.
           destruct userData; unfold build_data_step in *; simpl in *; clean_map_lookups.
           eapply silent_step_minus_user in H12; eauto.
           split_ex; eauto.
           dt x1.

           eapply H6 in H9; eauto.

Qed.

Lemma must_be_max_silent_step :
  forall A B uid U U',
    @indexedRealStep A B uid Silent U U'
    -> exists uid__max U__max',
        indexedRealStep uid__max Silent U U__max'
        /\ (forall uid' U',
              uid' > uid__max ->
              ~ indexedRealStep uid' Silent U U').
Proof.
  intros.
  invert H.
  destruct U; destruct userData
  ; simpl in *
  ; eauto using must_be_max_silent_step'.
Qed.

Lemma violations_translate :
  forall t__hon t__adv n st st' b summaries,
    stepsi n st st'
    -> lameAdv b (fst (fst st)).(adversary)
    -> goodness_predicates (fst (fst st))
    -> syntactically_safe_U (fst (fst st))
    -> summarize_univ (fst (fst st)) summaries
    -> (forall st'', step st' st'' -> False)
    -> ~ ( no_resends_U (fst (fst st')) /\ alignment st' /\ returns_align st')
    -> exists st'',
        (@stepSS t__hon t__adv)^* st st''
        /\ ~ (no_resends_U (fst (fst st'')) /\ alignment st'' /\ returns_align st'').
Proof.
  induct n; intros.

  invert H; eexists; split; eauto.

  destruct (
      classic (exists uid U', indexedRealStep uid Silent (fst (fst st)) U')
    ).

  - split_ex.

    pose proof (must_be_max_silent_step H6); split_ex; clear x x0 H6.
    invert H7.
    eapply translate_trace_commute in H; eauto.

    split_ex; subst.
    generalize H; intros; eapply progress_predicates in H; eauto; split_ex.

    eapply IHn in H7;
      eauto using model_stuck_carent_alignment_bit,
                  violated_predicates_remain_violated;
      split_ex.

    exists x2; split; eauto.
    eapply TrcFront; eauto.
    destruct st as [[ru iu] v].
    destruct x  as [[ru' iu'] v'].
    simpl in *.

    econstructor.
    2-3: reflexivity.
    econstructor 1; eauto.

    unfold build_data_step in *; simpl in *; eauto.

  - invert H.

    generalize H8; intros SS;
      eapply syntactically_safe_U_preservation_step in SS; eauto.

    assert (SSU : syntactically_safe_U (fst (fst st'0))) by eauto using syntactically_safe_U_preservation_step.
    assert (GOODNESS : goodness_predicates (fst (fst st'0))) by eauto using goodness_preservation_step.

    eapply IHn in H9; eauto using summarize_univ_step.
    repeat match goal with
           | [ H : goodness_predicates _ |- _ ] => clear H
           | [ H : syntactically_safe_U _ |- _ ] => clear H
           end.
    firstorder idtac.
    simpl in *.

    exists x.
    unfold not; split; intros; split_ex; eauto 8.
    eapply TrcFront; eauto.
    destruct st as [[ru iu] v], st'0 as [[ru0' iu0'] v0'].

    generalize H8; intros STEP; invert H8;
      match goal with
      | [ H : step_universe _ _ _ _ |- _ ] => invert H
      | [ H : indexedRealStep _ _ _ _ |- _ ] => invert H
      end.

    + specialize (H5 u_id); firstorder idtac.
      unfold mkULbl in H10; destruct lbl; try discriminate.
      exfalso.
      eapply H5; simpl.
      econstructor; eauto.

    + destruct ru; unfold build_data_step, lameAdv in *; simpl in *.
      rewrite H0 in H6; invert H6.

    + econstructor; eauto.
      econstructor 2; eauto.

    + econstructor; eauto.
      econstructor 2; eauto.

    + econstructor; eauto.
      econstructor 2; eauto.
Qed.

Lemma complete_trace :
  forall t__hon t__adv n' n st b,
    runningTimeMeasure (fst (fst st)) n
    -> n <= n'
    -> lameAdv b (fst (fst st)).(adversary)
    -> exists st',
        (@step t__hon t__adv) ^* st st'
      /\ (forall st'', step st' st'' -> False).

Proof.
  induct n'; intros.
  - invert H; simpl in *.

    exists st; split; intros; eauto.
    destruct st as [[ru iu] v].
    destruct ru; simpl in *; subst.
    destruct n__rt; try lia.

    invert H.

    + invert H7; dismiss_adv; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H9 in H3; invert H3.

    + invert H6; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H12 in H3; invert H3.

    + invert H6; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H11 in H3; invert H3.

    + invert H6; simpl in *.
      eapply boundRunningTime_for_element in H2; eauto; split_ex.
      destruct x; try lia.
      invert H2.
      unfold build_data_step in *; rewrite <- H11 in H3; invert H3.

  - destruct (classic (exists st', step st st')).
    + split_ex.
      rename x into st'.
      assert (LAME' : lameAdv b (fst (fst st')).(adversary)) by eauto using adversary_remains_lame_step.
      eapply runningTimeMeasure_step in H; eauto; split_ex.

      eapply IHn' in H; try lia; eauto.
      split_ex.
      exists x0; split; intros; eauto.

    + firstorder idtac; simpl in *.
      exists st; split; intros; eauto.
Qed.

#[export] Hint Resolve  goodness_preservation_step syntactically_safe_U_preservation_step : core.

Lemma many_steps_stays_lame :
  forall t__hon t__adv st st' b,
    (@step t__hon t__adv) ^* st st'
    -> lameAdv b (adversary (fst (fst st)))
    -> lameAdv b (adversary (fst (fst st'))).
Proof.
  induction 1;
    intros;
    simpl in *;
    eauto.
Qed.

Lemma many_steps_syntactically_safe :
  forall t__hon t__adv st st',
    (@step t__hon t__adv) ^* st st'
    -> syntactically_safe_U (fst (fst st))
    -> goodness_predicates (fst (fst st))
    -> syntactically_safe_U (fst (fst st')).
Proof.
  induction 1;
    intros;
    simpl in *;
    eauto.
Qed.

Lemma many_steps_stays_good :
  forall t__hon t__adv st st',
    (@step t__hon t__adv) ^* st st'
    -> goodness_predicates (fst (fst st))
    -> syntactically_safe_U (fst (fst st))
    -> goodness_predicates (fst (fst st')).
Proof.
  induction 1;
    intros;
    simpl in *;
    eauto.
Qed.

#[export] Hint Resolve many_steps_stays_lame many_steps_syntactically_safe many_steps_stays_good : core.

Locate safety.

Theorem step_stepSS' :
  forall {t__hon t__adv} (ru0 : RealWorld.universe t__hon t__adv) (iu0 : IdealWorld.universe t__hon) b n summaries,
    runningTimeMeasure ru0 n
    -> goodness_predicates ru0
    -> syntactically_safe_U ru0
    -> summarize_univ ru0 summaries
    -> lameAdv b ru0.(adversary)
    -> invariantFor (TrSS ru0 iu0) (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st)
    -> invariantFor (TrS ru0 iu0) (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st)
.
Proof.
  intros * RUNTIME GOOD SYN_SAFE SUMM LAME INV.

  apply NNPP; unfold not; intros INV'.
  unfold invariantFor in INV'.
  apply not_all_ex_not in INV'; split_ex.
  apply imply_to_and in H; split_ex.
  apply not_all_ex_not in H0; split_ex.
  apply imply_to_and in H0; split_ex.
  simpl in H; split_ors; try contradiction.
  destruct x0 as [[?ru ?iu] ?v].

  subst; simpl in *.

  assert (exists n', runningTimeMeasure (fst (fst (ru, iu, v))) n' /\ n' <= n)
    by eauto using runningTimeMeasure_steps; split_ex.

  eapply complete_trace in H; eauto; split_ex.
  specialize (trc_trans H0 H); intros.
  apply steps_stepsi in H4; split_ex.

  unfold invariantFor in INV; simpl in *.
  eapply violations_translate in H4; eauto; split_ex.
  apply INV in H4; eauto; split_ex.

  eapply not_and_or in H1
  ; destruct H1 as [H1 | H1]
  ; [ | eapply not_and_or in H1]
  ; split_ors
  ; simpl
  ; unfold not; intros; split_ex.

  - assert (~ no_resends_U (fst (fst x0)))
      by eauto using resend_violation_steps
    ; contradiction.

  - assert (~ alignment x0)
      by eauto using alignment_violation_steps
    ; contradiction.

  - assert (~ returns_align x0)
      by eauto using final_alignment_violation_steps
    ; contradiction.
Qed.

Lemma ss_implies_next_safe :
  forall t (cmd : user_cmd t) uid ctx uids sty cs,
    syntactically_safe uid uids ctx cmd sty
    -> forall A B (usrs usrs' : honest_users A) (adv adv' : user_data B) cmd'
        cs' gks gks' ks ks' qmsgs qmsgs' mycs mycs' froms froms' sents sents' n n' lbl,
      step_user lbl (Some uid)
                (usrs,adv,cs,gks,ks,qmsgs,mycs,froms,sents,n,cmd)
                (usrs',adv',cs',gks',ks',qmsgs',mycs',froms',sents',n',cmd')
      -> typingcontext_sound ctx usrs cs uid
      -> uids = compute_ids usrs
      -> forall t__n (cmd__n : user_cmd t__n), nextAction cmd cmd__n
      -> (forall r, cmd__n <> Return r)
      -> no_resends sents'
      -> next_cmd_safe (findUserKeys usrs) cs uid froms sents cmd.
Proof.
  induct cmd;
    unfold next_cmd_safe; intros;
      match goal with
      | [ H : nextAction _ _ |- _ ] => invert H
      end; eauto;
        try solve [ unfold typingcontext_sound in *; split_ex;
                    match goal with
                    | [ H : syntactically_safe _ _ _ _ _ |- _ ] => invert H
                    end; eauto ].

  - invert H0.
    invert H1; eauto.
    invert H4.
    eapply IHcmd in H7; eauto.
    eapply H7 in H11; eauto.

    invert H11; trivial.

  - unfold typingcontext_sound in *; split_ex; invert H.
    apply H2 in H11; split_ex; subst.
    apply H1 in H10.
    unfold msg_honestly_signed, msg_signing_key,
           msg_to_this_user, msg_destination_user,
           honest_keyb;
      context_map_rewrites.
    destruct ( cipher_to_user x0 ==n cipher_to_user x0 ); try contradiction.
    repeat simple apply conj; eauto.
    econstructor; eauto.
    unfold msg_honestly_signed, msg_signing_key, honest_keyb;
      context_map_rewrites;
      trivial.
    (do 2 eexists); repeat simple apply conj; eauto.
    invert H0.
    unfold no_resends, updateSentNonce in H5; context_map_rewrites.
    destruct (cipher_to_user x0 ==n cipher_to_user x0); try contradiction.
    invert H5; eauto.

  - unfold typingcontext_sound in *; split_ex; invert H; eauto.
    intros.
    apply H12 in H; split_ex; subst; eauto.
Qed.

Lemma step_na_recur :
  forall t t__n (cmd : user_cmd t) (cmd__n : user_cmd t__n),
    nextAction cmd cmd__n
    -> forall A B suid lbl bd bd',

      step_user lbl suid bd bd'

      -> forall cs cs' (usrs usrs': honest_users A) (adv adv' : user_data B) gks gks'
          cmd__n' ks ks' qmsgs qmsgs' mycs mycs'
          froms froms' sents sents' cur_n cur_n',

        bd = (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd__n)
        -> bd' = (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd__n')
        -> exists bd'',
            step_user lbl suid (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd) bd''.
Proof.
  induct 1; intros; subst;
    eauto.

  eapply IHnextAction in H0; eauto. split_ex.
  simpl.

  dt x; eexists; eapply StepBindRecur; eauto.
Qed.

Lemma ss_implies_next_safe_no_model_step :
  forall A B (usrs : honest_users A) (adv : user_data B) cs gks
    cmd uid ctx uids sty,

    uids = compute_ids usrs
    -> forall ks qmsgs mycs froms sents cur_n, usrs $? uid = Some (mkUserData ks cmd qmsgs mycs froms sents cur_n)
    -> forall t__n (cmd__n : user_cmd t__n), nextAction cmd cmd__n
    -> syntactically_safe uid uids ctx cmd sty
    -> typingcontext_sound ctx usrs cs uid
    -> forall ru iu, ru = mkUniverse usrs adv cs gks
    -> (forall ru' iu', indexedModelStep uid (ru,iu,true) (ru',iu',true) -> False)
    -> labels_align (ru,iu,true)
    -> next_cmd_safe (findUserKeys usrs) cs uid froms sents cmd.
Proof.
  intros.
  cases cmd__n;
    unfold next_cmd_safe; intros;
      match goal with
      | [ H1 : nextAction cmd _, H2 : nextAction cmd _ |- _ ] => eapply na_deterministic in H1; eauto
      end; split_ex; subst; trivial.

  Ltac xyz :=
    repeat
      match goal with
      | [ NA : nextAction _ (Bind _ _) |- _ ] =>
        eapply nextAction_couldBe in NA; contradiction
      | [ SS : syntactically_safe _ _ _ ?cmd _, NA : nextAction ?cmd _ |- _ ] =>
        eapply syntactically_safe_na in SS; eauto; split_ex
      | [ SS : syntactically_safe _ _ _ _ _ |- _ ] =>
        invert SS; unfold typingcontext_sound in *; split_ex; process_ctx
      end.

  all: xyz; eauto.

  - exfalso.

    assert (SEND : exists lbl bd,
               step_user lbl
                         (Some uid)
                         (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n,
                          @Send t0 (cipher_to_user x0) (SignedCiphertext x)) bd).
      (do 2 eexists); econstructor; clean_map_lookups; simpl in *; eauto.
      context_map_rewrites; eauto.
      unfold not; intros INV; invert INV; contradiction.
      split_ex.

      destruct x1.
      invert H4.

      dt x3.
      eapply step_na_recur in H4; eauto; split_ex.
      dt x1.

      assert (exists ru', indexedRealStep uid (Action a)
                                     (mkUniverse usrs adv cs gks)
                                     ru')
        by (eexists; econstructor; eauto).

      split_ex.
      generalize (H6 _ _ _ H8); intros; split_ex.
      eapply H5; clear H5.
      econstructor 2; eauto.

  - eapply H11 in H4; split_ex.
    eapply H in H4; eauto.
Qed.

Lemma indexedModelStep_step :
  forall t__hon t__adv uid st st',
    @indexedModelStep t__hon t__adv uid st st'
    -> step st st'.
Proof.
  intros.
  invert H; [
    econstructor 1
  | econstructor 2
  | econstructor 3
  | econstructor 4 ]; eauto.

  invert H0; econstructor; eauto.
Qed.

Theorem step_stepSS :
  forall {t__hon t__adv} (ru0 : RealWorld.universe t__hon t__adv) (iu0 : IdealWorld.universe t__hon) b n summaries,
    runningTimeMeasure ru0 n
    -> goodness_predicates ru0
    -> syntactically_safe_U ru0
    -> summarize_univ ru0 summaries
    -> lameAdv b ru0.(adversary)
    -> invariantFor (TrS ru0 iu0) (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st)
    -> invariantFor (TrS ru0 iu0) (fun st => safety st /\ alignment st /\ returns_align st)
.
Proof.
  unfold invariantFor; intros.
  specialize (H4 _ H5).
  generalize H6; intros STEPS; eapply H4 in H6; eauto.
  split_ex; split; eauto.

  destruct s' as [[ru' iu'] b'].
  simpl in *; split_ex; subst.
  split_ors; try contradiction; subst.

  hnf in H7; split_ex; simpl in H5; subst.
  assert (SS : syntactically_safe_U (fst (fst (ru', iu', true)))) by eauto.
  unfold honest_cmds_safe; intros.

  destruct (classic (exists st, indexedModelStep u_id (ru',iu',true) (st,true))).
  - split_ex.
    destruct x as [ru'' iu''].
    pose proof (indexedModelStep_step H10) as STEP.
    assert (STEPS' : (@step t__hon t__adv) ^* (ru',iu',true) (ru'',iu'',true)) by (eauto using TrcFront).
    pose proof (trc_trans STEPS STEPS') as MORESTEPS.

    specialize (H4 _ MORESTEPS); unfold no_resends_U in H4.
    simpl in *; split_ex.

    unfold syntactically_safe_U in SS;
      specialize (SS _ _ _ H9 eq_refl); split_ex.

    assert (exists lbl, indexedRealStep u_id lbl ru' ru'') by (invert H10; eauto).
    split_ex.
    invert H15.

    unfold build_data_step, buildUniverse in *; simpl in *.
    clean_map_lookups.

    pose proof (na_always_exists (protocol userData)); split_ex.
    destruct (classic (exists r, x3 = Return r)); split_ex; subst; eauto.
    + unfold next_cmd_safe; intros.
      eapply na_deterministic in H5; eauto.
      split_ex; subst; trivial.

    + rewrite Forall_natmap_forall in H4.
      specialize (H4 u_id).
      rewrite add_eq_o in H4 by trivial.
      specialize (H4 _ eq_refl); simpl in H4.
      eapply ss_implies_next_safe;
        eauto.

  - assert (forall st, indexedModelStep u_id (ru',iu',true) (st,true) -> False) by eauto using not_ex_all_not.

    subst.
    clear H10.
    unfold syntactically_safe_U in SS.
      specialize (SS _ _ _ H9 eq_refl); split_ex.
    simpl in *.

    pose proof (na_always_exists (protocol u)); split_ex.

    destruct ru', u;
      simpl in *;
      eapply ss_implies_next_safe_no_model_step; eauto.

Qed.

Module Type AutomatedSafeProtocolSS.
  Parameter t__hon : type.
  Parameter t__adv : type.
  Parameter b : << Base t__adv >>.
  Parameter iu0 : IdealWorld.universe t__hon.
  Parameter ru0 : RealWorld.universe t__hon t__adv.
  (* Parameter runTime : nat. *)
  (* Parameter summaries : NatMap.t summary. *)

  Notation SYS := (TrSS ru0 iu0).

  Axiom U_good : universe_starts_sane b ru0.
  Axiom universe_starts_safe : universe_ok ru0.

  Axiom finitelyRuns : exists n, runningTimeMeasure ru0 n.
  (* Axiom finitelyRuns : runningTimeMeasure ru0 runTime. *)
  Axiom typechecks : syntactically_safe_U ru0.
  Axiom summarizable : exists summaries, summarize_univ ru0 summaries.
  (* Axiom summarizable : summarize_univ ru0 summaries. *)
  Axiom lameness : lameAdv b (adversary ru0).

  Axiom safe_invariant : invariantFor
                           SYS
                           (fun st => no_resends_U (fst (fst st)) /\ alignment st /\ returns_align st).
End AutomatedSafeProtocolSS.

Module SSProtocolSimulates (Proto : AutomatedSafeProtocolSS).
  Import Proto Simulation.

  Module SSAutomatedSafeProtocol <: AutomatedSafeProtocol.
    Definition t__hon := t__hon.
    Definition t__adv := t__adv.
    Definition b := b.
    Definition iu0 := iu0.
    Definition ru0 := ru0.

    Lemma U_good : universe_starts_sane b ru0.
    Proof. exact U_good. Qed.

    Lemma universe_starts_safe : universe_ok ru0.
    Proof. exact universe_starts_safe. Qed.

    Lemma goodness_predicates_ok : goodness_predicates ru0.
    Proof. pose proof universe_starts_safe; unfold universe_ok, goodness_predicates, adv_goodness in *
           ; intuition idtac.

           unfold adv_message_queue_ok in H4
           ; rewrite Forall_forall in H4 |- *
           ; intros * LIN
           ; apply H4 in LIN.

           - destruct x; split_ex; split; eauto.
             intros.
             apply H11 in H12; split_ex; eauto.
           - unfold adv_cipher_queue_ok in H3
             ; rewrite Forall_forall in H3 |- *
             ; intros * LIN
             ; apply H3 in LIN
             ; split_ex
             ; eauto.
    Qed.

    #[local] Hint Resolve goodness_predicates_ok : core.
    #[local] Hint Resolve typechecks lameness Proto.safe_invariant : core.

    Lemma safe_invariant :
      invariantFor
        (TrS ru0 iu0)
        (fun st => safety st /\ alignment st /\ returns_align st).
    Proof.
      pose proof (@step_stepSS Proto.t__hon Proto.t__adv).
      pose proof finitelyRuns.
      pose proof summarizable.
      split_ex.
      eapply H; eauto.

      pose proof (@step_stepSS' Proto.t__hon Proto.t__adv); eauto.
    Qed.

  End SSAutomatedSafeProtocol.

  Module Import SSSimulates := ProtocolSimulates ( SSAutomatedSafeProtocol ).

  Lemma protocol_with_adversary_could_generate_spec :
    forall U__ra advcode acts__r,
      U__ra = add_adversary ru0 advcode
      -> rCouldGenerate U__ra acts__r
      -> exists acts__i,
          iCouldGenerate iu0 acts__i
          /\ traceMatches acts__r acts__i.
  Proof.
    eauto using SSSimulates.protocol_with_adversary_could_generate_spec.
  Qed.

End SSProtocolSimulates.