Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.omega.Omega.

Require Import Monad.
Require Import StringUtility.
Require Import InvTactics.
Require Import FileSystem.

Module SimpleFS : FileSystem with Definition path := string.

  Definition path : Type := string.
  Definition file_content : Type := bool.
  Definition file : Type := unit.
  Definition file_handle : Type := nat.
  Definition metadata : Type := nat.

  Record file_stat' : Type :=
    mkStat { is_reg : bool;
           is_dir : bool;
           is_chr : bool;
           is_blk : bool;
           is_fifo : bool;
           is_lnk : bool;
           is_sock : bool
           }.

  Definition file_stat : Type := file_stat'.

  Definition file_name : string := "file".

  Definition fsContents (p : path) : option (list bool) :=
    if strcmp p file_name then
      Some (true :: nil)
    else None.

  Hint Unfold fsContents.

  Record file_system' : Type :=
    mkFS { is_open : bool;
           is_read : bool;
           has_fd : bool;
           the_stat : file_stat
         }.

  Definition file_system : Type := file_system'.

  Definition init_file_stat : file_stat :=
    mkStat true false false false false false false.
  Definition initial_fs : file_system :=
    mkFS false false false init_file_stat.

  Record abstract_file_stat : Type :=
    abs_stat { isReg : bool;
               isDir : bool;
               isChr : bool;
               isBlk : bool;
               isFifo : bool;
               isLnk : bool;
               isSock : bool
             }.

  Record abstract_file_metainfo : Type :=
    abs_file { p : path;
               offset : nat;
               stat : abstract_file_stat
             }.

  Definition abs_fstat (f : file_stat) : abstract_file_stat :=
    abs_stat (is_reg f) (is_dir f) (is_chr f) (is_blk f)
             (is_fifo f) (is_lnk f) (is_sock f).

  Definition init_abs_fstat := abs_fstat init_file_stat.

  Definition contents (fs : file_system) := fsContents.
  Definition streams (fs : file_system) :=
    if is_open fs then tt::nil else nil.
  Definition file_info (fs : file_system) (_ : file) :=
    if is_open fs then
      Some (abs_file file_name (if is_read fs then 1 else 0)
                     init_abs_fstat)
    else None.
  Definition file_no (fs : file_system) (_ : file) :=
    if (has_fd fs) then Some 1 else None.

  Definition FS ( A : Type ) := file_system -> (A * file_system).
  Instance FS_Monad : Monad FS :=
    { ret A x := fun fs => (x, fs) ;
      bind A B f a := fun fs =>
                    match a fs with
                    | (b, fs') => f b fs'
                    end }.
  Definition get : FS file_system :=
    fun fs => (fs, fs).

  Hint Unfold contents.
  Hint Unfold streams.
  Hint Unfold file_info.
  Hint Unfold file_no.

  (*
  Theorem abstract_file_system_spec : forall fs f,
      forall afs, afs = abs_fs fs ->
             (In f (streams afs) <-> file_info afs f <> None) /\
             (forall fi, file_info afs f = Some fi ->
                    contents afs (p fi) <> None).
  Proof.
    intros. split; unfold abs_fs in H; subst; simpl.
    - split; intros; destruct (is_open fs) eqn:Hopen;
        destruct f; try intro; try solve by inversion;
          simpl; auto.
    - intros.
      destruct (is_open fs); subst; inversion H;
        simpl; intro; try solve by inversion.
  Qed.
   *)

  Definition fopen (p: path) (m : file_access_mode) : FS (option file) :=
    fun fs => match m with
           | wb => (None, fs)
           | ab => (None, fs)
           | rb => if strcmp p file_name then
                    (Some tt, mkFS true (is_read fs) (has_fd fs) (the_stat fs))
                  else (None, fs)
           end.

  Theorem fopen_spec : forall p m f fs fs',
      fopen p m fs = (f, fs') ->
      (m = rb -> contents fs p = None -> f = None) /\
      (m = wb \/ m = ab ->
       forall f', f = Some f' ->
             contents fs' p <> None) /\
      (forall f', f = Some f' ->
             In f' (streams fs')) /\
      (forall f', file_no fs f' = file_no fs' f') /\
      (forall f', f <> Some f' ->
             file_info fs f' = file_info fs' f' /\
             In f' (streams fs) = In f' (streams fs')) /\
      (forall p', p <> p' \/ m = rb ->
             contents fs p' = contents fs' p').
  Proof.
    intros. repeat split.
    - intros; subst.
      unfold contents in H1. unfold fsContents in H1.
      unfold fopen in H.
      destruct (strcmp p0 file_name).
      + try solve by inversion.
      + inversion H; auto.
    - intros. destruct H0; subst; simpl in *; try solve by inversion.
    - intros. subst. destruct m; simpl in H; try solve by inversion.
      destruct (strcmp p0 file_name); try solve by inversion.
      inversion H. simpl. auto.
    - intros. subst.
      destruct m; simpl in H;
        destruct (strcmp p0 file_name); inversion H; simpl; auto.
    - subst.
      destruct m; simpl in H; destruct (strcmp p0 file_name);
        inversion H; subst; auto.
      + simpl. destruct (is_open fs); destruct f'; contradiction.
    - destruct f.
      + destruct f; destruct f'. contradiction.
      + destruct m; simpl in H; destruct (strcmp p0 file_name);
          subst; inversion H; auto.
  Qed.

  Definition fileno (f : file) : FS (option file_handle) :=
    fun fs => if (is_open fs) then
             (Some 1, mkFS (is_open fs) (is_read fs) true (the_stat fs))
           else (None, fs).

  Theorem fileno_spec : forall f fs fs' fd,
      fileno f fs = (fd, fs') ->
      (In f (streams fs) ->
       file_no fs' f = fd /\
       (file_no fs f <> None -> file_no fs f = fd)) /\
      (~ In f (streams fs) -> fd = None) /\
      (forall f', f' <> f ->
             file_no fs' f <> file_no fs' f' /\
             file_no fs f' = file_no fs' f') /\
      (forall f', file_info fs f' = file_info fs' f') /\
      (forall f', In f' (streams fs) <-> In f' (streams fs')) /\
      (forall p', contents fs p' = contents fs' p').
  Proof.
    intros. unfold fileno in H.
    destruct (is_open fs) eqn:Hopen.
    - repeat split; subst; inversion H; subst; simpl; auto.
      all: try (destruct f; destruct f'; contradiction).
      all: autounfold; try rewrite Hopen; simpl; auto.
      + destruct (has_fd fs); auto; contradiction.
      + destruct f. intros. destruct H0. simpl. auto.
    - repeat split; subst; inversion H; subst; simpl; auto.
      all: try (destruct f; destruct f'; contradiction).
      all: autounfold in *; rewrite Hopen in *;
        destruct f; simpl in *; try solve by inversion.
  Qed.

  Definition fseek (f : file) (off : nat) (s : seek_set) : FS bool :=
    fun fs => if negb (is_open fs) then
             (false, fs)
           else if (1 <=? off) then
                  (true, mkFS true true (has_fd fs) (the_stat fs))
                else match s with
                     | SeekEnd => (true, mkFS true true (has_fd fs) (the_stat fs))
                     | SeekSet => (true, mkFS true false (has_fd fs) (the_stat fs))
                     | _ => (true, fs)
                     end.

  Theorem fseek_spec : forall f off origin fs fs' b,
      fseek f off origin fs = (b, fs') ->
      (In f (streams fs) <-> b = true) /\
      (forall f', file_no fs f' = file_no fs' f') /\
      (forall f', f <> f' -> file_info fs f' = file_info fs' f') /\
      (forall fi,  file_info fs  f = Some fi  ->
       forall fi', file_info fs' f = Some fi' ->
       forall s, contents fs (p fi) = Some s ->
            offset fi' = min (length s) (expected_offset origin (offset fi) (length s) off)) /\
      (forall f', In f' (streams fs) <-> In f' (streams fs')) /\
      (forall p', contents fs p' = contents fs' p').
  Proof.
    intros.
    destruct off; unfold fseek in H;
      destruct (is_open fs) eqn:Hopen; simpl in H; inversion H; subst;
        destruct origin eqn:Horigin; repeat split.
    all: try intros; inversion H; subst; auto.
    all: autounfold in *; rewrite Hopen in *.
    all: try (destruct f).
    all: try (destruct f').
    all: simpl in *; auto; try contradiction.
    all: try
           (match goal with
              [ H : fsContents ?pi = Some ?s |- _ ] =>
              autounfold in H; destruct (strcmp pi file_name); inversion H end).
    all: try inversion H0; simpl; auto.
    all: try inversion H1; simpl; auto.
    all: try inversion H2; simpl; auto.
    - destruct (is_read fs'); simpl; auto.
    - destruct (is_read fs); simpl; auto.
  Qed.

  Definition fread (f : file) (size : nat) (count : nat) : FS (list (list bool) * nat) :=
    fun fs => if (beq_nat size 0) then
             ((nil, 0), fs)
           else if (beq_nat count 0) then
                  ((nil, 0), fs)
                else if (is_open fs) then
                       if (is_read fs) then
                         ((nil, 0), fs)
                       else
                         (((true::nil)::nil, if (beq_nat size 1) then 1 else 0),
                          mkFS true true (has_fd fs) (the_stat fs))
                     else ((nil, 0), fs).

  Theorem fread_spec : forall f size count fs fs' buf r,
      fread f size count fs = ((buf, r), fs') ->
      (r <= count) /\
      (length (filter (fun b => beq_nat (length b) size) buf) = r) /\
      (~ In f (streams fs) -> buf = nil /\ r = 0) /\
      (forall f', file_no fs f' = file_no fs' f') /\
      (forall f', f <> f' ->
             file_info fs f' = file_info fs' f') /\
      (forall l, l = fold_left (fun x y => x + length y) buf 0 ->
       forall fi,  file_info fs  f = Some fi  ->
       forall fi', file_info fs' f = Some fi' ->
       forall s, contents fs (p fi) = Some s ->
            l <= (length s - offset fi) /\ offset fi' = offset fi + l) /\
      (forall f', In f' (streams fs) <-> In f' (streams fs')) /\
      (forall p', contents fs p' = contents fs' p').
  Proof.
    intros. repeat split.
    all: try match goal with
               [ H : fread _ _ _ _ = _ |- _ ] =>
               unfold fread in H;
                 destruct (beq_nat size 0) eqn:Hsize;
                 destruct (beq_nat count 0) eqn:Hcount;
                 destruct (is_open fs) eqn:Hopen;
                 destruct (is_read fs) eqn:Hread;
                 try solve [inversion H; omega];
                 try solve [inversion H; simpl; auto];
                 try solve [destruct (beq_nat size 1) eqn:Hsize';
                            inversion H; try apply beq_nat_false in Hcount; omega]
             end.
    all: autounfold in *.
    all: try (rewrite Hopen in *).
    all: try (destruct f'; intros).
    all: try solve [destruct f; destruct H0; simpl; auto].
    all: try
           (match goal with
              [ H : fsContents ?pi = Some ?s |- _ ] =>
              autounfold in H; destruct (strcmp pi file_name); inversion H end).
    all: try (inversion H1; simpl; rewrite Hread;
              inversion H; subst; simpl; auto).
    all: try simpl in H2.
    all: try (rewrite Hopen in H2; rewrite Hread in H2).
    all: try (inversion H2; simpl; auto).
    all: try (inversion H).
    all: simpl; auto.
    - destruct size eqn:Hsize'; try solve by inversion.
      simpl in H. destruct n; simpl in H; inversion H; simpl; auto.
  Qed.

  Definition fclose (f : file) : FS bool :=
    fun fs => if (is_open fs) then
             (true, mkFS false false (has_fd fs) (the_stat fs))
           else (false, fs).

  Theorem fclose_spec : forall f fs fs' b,
      fclose f fs = (b, fs') ->
      (~ In f (streams fs) -> b = false) /\
      ~ In f (streams fs') /\
      (forall f', file_no fs f' = file_no fs' f') /\
      (forall f', f <> f' ->
             file_info fs f' = file_info fs' f' /\
             In f' (streams fs) = In f' (streams fs')) /\
      (forall p', contents fs p' = contents fs' p').
  Proof.
    intros. unfold fclose in H.
    destruct (is_open fs) eqn:Hopen; inversion H; repeat split.
    all: autounfold.
    all: destruct f.
    all: try rewrite Hopen; simpl; auto.
    all: try (destruct f'; contradiction).
    - intros. destruct H0. auto.
    - subst. rewrite Hopen. auto.
  Qed.

  Definition fstat (fd : file_handle) (fs : file_system) : option file_stat :=
    if (beq_nat fd 1) then
      Some init_file_stat
    else None.

  Theorem fstat_spec : forall f fd fs st,
      file_no fs f = Some fd ->
      fstat fd fs = st ->
      forall fi, file_info fs f = Some fi ->
      forall st', st = Some st' ->
      stat fi = abs_fstat st'.
  Proof.
    intros. autounfold in *.
    destruct (beq_nat fd 1) eqn:Heq; subst.
    all: unfold fstat in H2; rewrite Heq in H2; inversion H2.
    subst. unfold abs_fstat. simpl in *.
    destruct (is_open fs); destruct (has_fd fs);
      try solve by inversion.
    inversion H1. simpl. auto.
  Qed.

  Theorem is_reg_spec : forall st,
      is_reg st = isReg (abs_fstat st).
  Proof.
    intros. reflexivity.
  Qed.

  Theorem is_dir_spec : forall st,
      is_dir st = isDir (abs_fstat st).
  Proof.
    intros. reflexivity.
  Qed.

End SimpleFS.


(******************************************************************************)
(** * Definition of the x86-TSO memory model *)
(******************************************************************************)
From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section TSO.

Variable G : execution.

Notation "'E'" := G.(acts_set).
Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).
Notation "'deps'" := G.(deps).
Notation "'fre'" := G.(fre).
Notation "'rfe'" := G.(rfe).
Notation "'coe'" := G.(coe).
Notation "'rfi'" := G.(rfi).
Notation "'fri'" := G.(fri).
Notation "'fr'" := G.(fr).
Notation "'eco'" := G.(eco).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).

Notation "'MFENCE'" := (F ∩₁ (fun a => is_true (is_sc lab a))).

(******************************************************************************)
(** ** Derived relations  *)
(******************************************************************************)

Definition ppo := (⦗RW⦘ ⨾ sb ⨾ ⦗RW⦘) \ (fun x y => W x /\ R y).

Definition fence := ⦗RW⦘ ⨾ sb ⨾ ⦗MFENCE⦘ ⨾ sb ⨾ ⦗RW⦘.

Definition implied_fence := ⦗W⦘ ⨾ sb ⨾ ⦗dom_rel rmw⦘ ∪ ⦗codom_rel rmw⦘ ⨾ sb ⨾ ⦗R⦘.

Definition hb := ppo ∪ fence ∪ implied_fence ∪ rfe ∪ co ∪ fr.

(******************************************************************************)
(** ** Consistency *)
(******************************************************************************)

Implicit Type WF : Wf G.
Implicit Type COMP : complete G.
Implicit Type ATOM : rmw_atomicity G.
Implicit Type SC_PER_LOC : sc_per_loc G.

Definition TSOConsistent :=
  ⟪ WF : Wf G ⟫ /\
  ⟪ COMP : complete G ⟫ /\
  ⟪ SC_PER_LOC: sc_per_loc G ⟫ /\
  ⟪ ATOMICITY : rmw_atomicity G ⟫ /\
  ⟪ GHB : acyclic hb ⟫.

Implicit Type CON : TSOConsistent.

Lemma CON_WF CON : Wf G.
Proof using. apply CON. Qed.

(******************************************************************************)
(** ** Relations in graph *)
(******************************************************************************)

Lemma wf_ppoE WF: ppo ≡ ⦗E⦘ ⨾ ppo ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold ppo.
rewrite (@wf_sbE G) at 1.
basic_solver 42.
Qed.

Lemma wf_fenceE WF: fence ≡ ⦗E⦘ ⨾ fence ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold fence.
rewrite (@wf_sbE G) at 1 2.
basic_solver 42.
Qed.

Lemma wf_implied_fenceE WF: implied_fence ≡ ⦗E⦘ ⨾ implied_fence ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold implied_fence.
rewrite (@wf_sbE G) at 1 2.
basic_solver 42.
Qed.

(******************************************************************************)
(** ** Domains and codomains *)
(******************************************************************************)

Lemma wf_hbD WF : hb ≡ ⦗RW⦘ ⨾ hb ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
apply dom_helper_3.
unfold hb.
unfold ppo, fence, implied_fence.
rewrite (wf_rmwD WF) at 1 2.
rewrite (wf_rfeD WF) at 1.
rewrite (wf_coD WF) at 1.
rewrite (wf_frD WF) at 1.
generalize (R_ex_in_R lab).
basic_solver 42.
Qed.

Lemma wf_ct_hbD WF : hb⁺ ≡ ⦗RW⦘ ⨾ hb⁺ ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
apply dom_helper_3.
rewrite (wf_hbD WF).
rewrite inclusion_ct_seq_eqv_l.
rewrite inclusion_ct_seq_eqv_r.
basic_solver.
Qed.

(******************************************************************************)
(** ** Properties  *)
(******************************************************************************)

Lemma ppo_alt : ppo ≡
  ⦗R⦘ ⨾ sb ⨾ ⦗RW⦘ ∪ ⦗W⦘ ⨾ sb ⨾ ⦗W⦘.
Proof using.
unfold ppo.
split.
by apply inclusion_minus_l; basic_solver 12.
by unfolder; ins; desf; splits; eauto 10; intro; type_solver.
Qed.

Lemma ppo_in_sb : ppo ⊆ sb.
Proof using.
unfold ppo; basic_solver.
Qed.

End TSO.


(*
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Lia
     Program.Equality.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Tactics
     Simulation
     SyntacticallySafe

     Theory.KeysTheory

     ModelCheck.ModelCheck
     ModelCheck.Commutation
     ModelCheck.InvariantSearchLemmas
     ModelCheck.ProtocolFunctions
     ModelCheck.RealWorldStepLemmas
     ModelCheck.SafeProtocol
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.UniverseInversionLemmas
     ModelCheck.NoResends
.

From SPICY Require IdealWorld RealWorld.
From Frap Require Export Invariant.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

Import Tacs Gen.

Set Implicit Arguments.

Open Scope protocol_scope.

Ltac eq1 :=
  invert_base_equalities1
  || match goal with
    | [ H : List.In _ _ |- _ ] => unfold List.In in H; (* intuition idtac *) split_ors

    | [ H : _ $+ (_,_) $? _ = Some ?UD |- _ ] =>
      match type of UD with
      | RealWorld.user_data _ =>
        apply lookup_some_implies_in in H; (* unfold List.In in H; intuition idtac *) simpl in H
      | _ => apply lookup_split in H; (* intuition idtac *) split_ors
      end
    | [ H : _ #+ (_,_) #? _ = Some ?UD |- _ ] =>
      apply ChMaps.ChMap.lookup_split in H; (* intuition idtac *) split_ors

    | [ H : _ = {| RealWorld.users := _ |} |- _ ]
      => apply split_real_univ_fields in H; split_ex; subst
    | [ |- RealWorld.protocol (RealWorld.adversary _) = RealWorld.Return _ ] =>
      unfold RealWorld.protocol, RealWorld.adversary
    | [ H : lameAdv _ ?adv |- RealWorld.protocol ?adv = _ ] => unfold lameAdv in H; eassumption

    | [ H : RealWorld.users _ $? _ = Some _ |- _ ] => unfold RealWorld.users in H

    | [ H : _ = RealWorld.mkUserData _ _ _ |- _ ] => inversion H; clear H

    | [ H : Action _ = Action _ |- _ ] =>
      injection H; subst
    | [ H : RealWorld.Return _ = RealWorld.Return _ |- _ ] => apply invert_return in H

    | [ H: RealWorld.SignedCiphertext _ = RealWorld.SignedCiphertext _ |- _ ] =>
      injection H; subst
    | [ H: RealWorld.SigCipher _ _ _ _ = RealWorld.SigCipher _ _ _ _ |- _ ] =>
      injection H; subst
    | [ H: RealWorld.SigEncCipher _ _ _ _ _ = RealWorld.SigEncCipher _ _ _ _ _ |- _ ] =>
      injection H; subst
    | [ H : _ = RealWorld.Output _ _ _ _ |- _ ] => apply output_act_eq_inv in H; split_ex; subst
    | [ H : RealWorld.Output _ _ _ _ = _ |- _ ] => apply output_act_eq_inv in H; split_ex; subst
    | [ H : _ = RealWorld.Input _ _ _ |- _ ] => apply input_act_eq_inv in H; split_ex; subst
    | [ H : RealWorld.Input _ _ _ = _ |- _ ] => apply input_act_eq_inv in H; split_ex; subst
    | [ H : MkCryptoKey _ _ _ = _ |- _ ] => apply key_eq_inv in H; split_ex; subst

    | [ H: _ = {| IdealWorld.read := _ |} |- _ ] => injection H
    | [ H: {| IdealWorld.read := _ |} = _ |- _ ] => injection H

    | [ H : keyId _ = _ |- _] => inversion H; clear H

    | [ H : realServer 0 _ _ = _ |- _ ] => rewrite realserver_done in H
    | [ H : realServer _ _ _ = _ |- _ ] => erewrite unroll_realserver_step in H by reflexivity
    end.

Ltac ch := (repeat equality1); subst; rw_step1.
(* Ltac ch := (repeat equality1); subst; rw_step1. *)
Ltac chu := repeat ch.

Ltac process_map_in_H H :=
  repeat ( (rewrite add_eq_o in H by trivial)
         || (rewrite add_neq_o in H by congruence)
         || (rewrite lookup_empty_none in H) )
  ; repeat
      match goal with
      | [ H : Some _ = Some _ |- _ ] => apply some_eq_inv in H; subst
      | [ H : None = Some _ |- _ ] => discriminate H
      end.

Ltac finish_honest_cmds_safe1 :=
    (* (progress solve_concrete_perm_merges) || *)
    match goal with
    (* from solve_concrete_perm_merges *)
    | [ |- context [true || _]  ] => rewrite orb_true_l
    | [ |- context [_ || true]  ] => rewrite orb_true_r
    | [ |- context [$0 $k++ _] ] => rewrite merge_perms_left_identity
    | [ |- context [_ $k++ $0] ] => rewrite merge_perms_right_identity

    | [ H : _ = {| RealWorld.users := _;
                   RealWorld.adversary := _;
                   RealWorld.all_ciphers := _;
                   RealWorld.all_keys := _ |} |- _ ] =>
      time ( let to := type of H in idtac "Universe Invert: " to; invert H )

    | [ |- honest_cmds_safe _ ] => unfold honest_cmds_safe; intros; simpl in *
    | [ |- next_cmd_safe _ _ _ _ _ _ ] => unfold next_cmd_safe; intros
    | [ H : _ $+ (?id1,_) $? ?id2 = Some ?ud |- context [ ?id2 ] ] =>
      match type of ud with
      | RealWorld.user_data _ =>
        is_var id2; destruct (id1 ==n id2); subst
        ; process_map_in_H H
        (* ; repeat ( discriminate H *)
        (*          || (rewrite add_eq_o in H by trivial) *)
        (*          || (rewrite add_neq_o in H by congruence) *)
        (*          || (rewrite lookup_empty_none in H) ) *)
        (* clean_map_lookups *)
      end
    | [ H : nextAction (RealWorld.protocol _) _ |- _ ] =>
      unfold RealWorld.protocol in H
    | [ H : nextAction (realServer 0 _ _) _ |- _ ] =>
      rewrite realserver_done in H
    | [ H : nextAction (realServer _ _ _) _ |- _ ] =>
      erewrite unroll_realserver_step in H by reflexivity
    | [ H : nextAction _ _ |- _ ] =>
      apply invert_na in H; cbn in H; destruct H; subst; invert_base_equalities1; subst
    | [ H : mkKeys _ $? _ = _ |- _ ] => unfold mkKeys in H; simpl in H
    | [ |- context [ RealWorld.findUserKeys _ ] ] =>
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty by eauto
    | [ H : RealWorld.findKeysMessage _ $? _ = _ |- _ ] =>
      unfold RealWorld.findKeysMessage in H; simpl in H
    | [ |- (_ -> _) ] => intros
    | [ H : _ $+ (?id1,_) $? ?id2 = _ |- context [ _ $? ?id2 ] ] =>
      progress (process_map_in_H H)
      (* ( progress ( *)
      (*       repeat ( *)
      (*           (rewrite add_neq_o in H by congruence) *)
      (*           || (rewrite add_eq_o in H by trivial) *)
      (*           || (rewrite lookup_empty_none in H) *)
      (* ))) *)
      || (is_var id2; destruct (id1 ==n id2); subst; process_map_in_H H)
      (* || (let to := type of H in idtac "Map inverting :" to; is_var id2; destruct (id1 ==n id2); subst; clean_map_lookups) *)
    | [ |- context [ _ $+ (_,_) $? _ ] ] =>
      (* ( progress clean_map_lookups ) *)
      ( progress (
          repeat (
              (rewrite add_eq_o by trivial)
              (* || (rewrite add_neq_o by solve_simple_ineq) *)
              || (rewrite add_neq_o by congruence)
              || (rewrite lookup_empty_none)
        )))

    | [ H : _ $k++ _ $? ?k = Some _ |- context [ _ $? ?k ]] => (*  *)
        apply merge_perms_split in H; destruct H
    | [ |- context [ _ $k++ _ $? _ ] ] => rewrite !lookup_in_merge_perm
    | [ |- RealWorld.msg_pattern_safe _ _ ] => econstructor
    | [ |- RealWorld.honest_key _ _ ] => econstructor
    | [ |- context [ ?m $? _ ] ] => unfold m
    | [ |- Forall _ _ ] => econstructor
    | [ |- exists x y, (_ /\ _)] => (do 2 eexists); repeat simple apply conj; eauto 2
    | [ |- _ /\ _ ] => repeat simple apply conj
    | [ |- ~ List.In _ ?lst ] =>
      match lst with
      | context [OrderedTypeEx.Nat_as_OT.compare ?x ?x] =>
        let EQ := fresh "EQ" in
        let RW := fresh "RW"
        in pose proof (@OTF.elim_compare_eq x x eq_refl) as EQ; destruct EQ as [EQ RW]
           ; rewrite RW
           ; progress vm_compute
      | _ =>  progress vm_compute
      end
    | [ |- ~ (_ \/ _) ] => unfold not; intros; split_ors; subst; try contradiction
    | [ H : context [ _ \/ False ] |- False ] =>
      destruct H; try contradiction
    | [ H : (_,_) = (_,_) |- _ ] => invert H
    end.

Ltac finish_honest_cmds_safe :=
  repeat (finish_honest_cmds_safe1 || (progress simplify_terms) (* ; simpl; cbn *)).

Definition safety_inv :=
  fun t__hon t__adv st => @safety t__hon t__adv st /\ alignment st /\ @returns_align t__hon t__adv st.

Definition noresends_inv :=
  fun t__hon t__adv st => no_resends_U (fst (fst st)) /\ alignment st /\ @returns_align t__hon t__adv st.

#[export] Hint Opaque safety_inv : core.

Definition can_con_map {V} (m : Map.t V) : Map.t V.
  let m' := eval simpl in (fold (fun k v acc => acc $+ (k, v)) m $0)
    in apply m'.
Defined.

Lemma can_con_map_correct : forall {V} (m : Map.t V),
    can_con_map m = m.
Proof.
  induction m using P.map_induction_bis; intros; Equal_eq; eauto.
  unfold can_con_map.
  rewrite fold_add; eauto.
  fold (can_con_map m).
  rewrite IHm; trivial.
  Morphisms.solve_proper.
  unfold transpose_neqkey; intros.
  maps_equal.
Qed.

Ltac ccm m H :=
  replace m with (can_con_map m) in H by apply can_con_map_correct
  ; try match goal with
        | [ H : context [ can_con_map ?cm ] |- _ ] =>
          (unfold can_con_map,fold in H; simpl in H)
        end.

Ltac ccmag m :=
  replace m with (can_con_map m) by apply can_con_map_correct
  ; match goal with
    | [ |- context [ can_con_map ?cm ] ] =>
      (unfold can_con_map,fold); simpl
    end.

Ltac rwuf :=
  unfold RealWorld.buildUniverse, RealWorld.build_data_step
  , RealWorld.key_heap, RealWorld.msg_heap, RealWorld.c_heap
  , RealWorld.from_nons, RealWorld.sent_nons, RealWorld.cur_nonce
  , RealWorld.protocol, RealWorld.all_keys, RealWorld.all_ciphers
  , RealWorld.users, RealWorld.adversary
  in *.

Tactic Notation "canonicalize" "ideal" "goal" :=
  rwuf
  ; match goal with
    | [ |- context [{| IdealWorld.users := ?usrs |}]] => ccmag usrs
    end.

Ltac idealUnivSilentStep' uid :=
  eapply IdealWorld.LStepUser with (u_id := uid)
  ; simpl
  ; [ solve [ simple_clean_maps; trivial ]
    | solve [ idealUserSilentStep ]
    ].

Ltac step_ideal1' uid :=
  idtac "stepping " uid
  ; eapply TrcFront
  ; [ idealUnivSilentStep' uid |].

Ltac multistep_ideal' usrs :=
  canonicalize ideal goal;
  match usrs with
  | ?us $+ (?uid,_) =>
    idtac "multi stepping " uid
    ; (repeat step_ideal1' uid)
    ; multistep_ideal' us
  | _ => eapply TrcRefl
  end.

Ltac run_ideal_silent_steps_to_end' :=
  canonicalize ideal goal;
  match goal with
  | [ |- istepSilent ^* {| IdealWorld.users := ?usrs |} ?U ] =>
    is_evar U
    ; multistep_ideal' usrs
  end.

Ltac discharge_ideal_proto_equality :=
  repeat
    match goal with
    | [ |- context [ IdealWorld.protocol _ = _ ] ] => unfold IdealWorld.protocol
    | [ |- idealServer 0 _ _ = _ ] => rewrite idealserver_done
    | [ |- idealServer _ _ _ = _ ] => erewrite unroll_idealserver_step by reflexivity
    | [ |- _ = _ ] => reflexivity
    end.

(* note the automation here creates a bunch of extra existentials while
 * doint the search for available steps.  This creates several nats
 * that need to be resolved at the end of proofs that use it.
 * Should look at fixing this. *)
Ltac find_step_or_solve' :=
  (* simpl in *; *)
  match goal with
  | [ H1 : forall _ _ _, indexedRealStep _ _ ?ru _ -> False
    , H2 : ?usrs $? _ = Some ?ur
    , H3 : RealWorld.protocol ?ur = RealWorld.Return _ |- _ ] =>

    ( assert (exists uid lbl ru', indexedRealStep uid lbl ru ru')
      by (eexists ?[uid]; (do 2 eexists); find_indexed_real_step usrs ?uid)
      ; split_ex; exfalso; eauto
    )
    || ( repeat solve_returns_align1
        ; ( (do 3 eexists); rwuf; (* simpl in *; *) (repeat eq1)
            ; subst
            ; repeat simple apply conj
            ; [ solve [ run_ideal_silent_steps_to_end' ]
              | solve [ simpl; simple_clean_maps; trivial ]
              | solve [ discharge_ideal_proto_equality ]
              | reflexivity
              ]
      ))
  end.

Ltac cleanup1 :=
  match goal with
  | [ H : True |- _ ] => clear H
  | [ H : ?X = ?X |- _ ] => clear H
  | [ H : ?x <> ?y |- _ ] =>
    match type of x with
    | nat => concrete x; concrete y; clear H
    end
  | [ H : ?x = ?y -> False |- _ ] =>
    match type of x with
    | nat => concrete x; concrete y; clear H
    end
  | [ H: RealWorld.keys_mine _ $0 |- _ ] => clear H
  | [ H : _ $+ (?k1,_) $? ?k2 = None |- _ ] =>
    (* (rewrite add_neq_o in H by solve_simple_ineq) *)
    (rewrite add_eq_o in H by trivial)
    || (rewrite add_neq_o in H by congruence)
    || (destruct (k1 ==n k2); subst)
  | [ H : Map.In ?k ?m -> False |- _ ] =>
    change (Map.In k m -> False) with (~ Map.In k m) in H
    ; rewrite F.not_find_in_iff in H
  | [ H : context [ ChMaps.ChannelType.eq _ _ ] |- _ ] => unfold ChMaps.ChannelType.eq in H
  | [ H : _ #+ (?k1,_) #? ?k2 = None |- _ ] =>
    (rewrite ChMaps.ChMap.F.add_neq_o in H by solve_simple_ineq)
    || (rewrite ChMaps.ChMap.F.add_eq_o in H by trivial)
    || (destruct (ChMaps.ChMap.F.eq_dec k1 k2); subst)

  | [ H : (Some _ = None -> False) -> ?c |- _ ] =>
    assert (c) by (apply H; intros; discriminate); clear H
  | [ H : (Some _ <> None) -> ?c |- _ ] =>
    assert (c) by (apply H; intros; discriminate); clear H
  | [ H : context [ sharePerm _ _ ] |- _ ] => unfold sharePerm in H
  | [ H : context [ $0 $? _ ] |- _ ] => rewrite lookup_empty_none in H
  | [ H : $0 $? _ = None |- _ ] => clear H
  | [ H : #0 #? _ = None |- _ ] => clear H
  | [ H : context [ add_key_perm _ _ _ ] |- _ ] => unfold add_key_perm in H

  | [ H : context [ (?uid,_) = (?x,_) \/ False] |- _ ] =>
    concrete uid; destruct H

  | [ H : MessageEq.content_eq ?m _ _ |- _ ] =>
    match type of m with
    | RealWorld.message.message Nat => fail 2
    | _ => unfold MessageEq.content_eq in H
    end
  | [ H : match ?acc with _ => _ end |- _ ] =>
    match type of acc with
    | IdealWorld.IW_message.access => destruct acc
    | _ => fail 1
    end

  | [ H : context [ _ #+ (?k,_) #? ?k ] |- _ ] =>
    is_not_evar k
    ; rewrite ChMaps.ChMap.F.add_eq_o in H by trivial
  | [ H : context [ _ #+ (?k1,_) #? ?k2 ] |- _ ] =>
    is_not_evar k1
    ; is_not_evar k2
    ; rewrite ChMaps.ChMap.F.add_neq_o in H by congruence
  | [ H : mkKeys _ $? _ = _ |- _ ] => unfold mkKeys in H
  | [ H : ~ RealWorld.msg_accepted_by_pattern _ _ _ _ _ |- _ ] => clear H
  | [ H : RealWorld.msg_accepted_by_pattern _ _ _ _ _ -> False |- _ ] => clear H
  | [ H : IdealWorld.screen_msg _ _ |- _ ] => invert H
  | [ H : IdealWorld.permission_subset _ _ |- _ ] => invert H
  | [ H : IdealWorld.check_perm _ _ _ |- _ ] => unfold IdealWorld.check_perm in H
  | [ H : IdealWorld.message.Permission _ = _ |- _ ] => invert H
  | [ H : context [ IdealWorld.addMsg _ _ _ ] |- _ ] => unfold IdealWorld.addMsg in H
  | [ H : Forall _ [] |- _ ] => clear H
  | [ H : context [true || _]  |- _] => rewrite orb_true_l in H
  | [ H : context [_ || true]  |- _] => rewrite orb_true_r in H
  | [ H : context [false || _]  |- _] => rewrite orb_false_l in H
  | [ H : context [_ || false]  |- _] => rewrite orb_false_r in H
  | [ H : context [$0 $k++ _] |- _] => rewrite merge_perms_left_identity in H
  | [ H : context [_ $k++ $0] |- _] => rewrite merge_perms_right_identity in H
  | [ H : context [_ $k++ _ $? _] |- _ ] => rewrite lookup_in_merge_perm in H
  (* | [ H : context [_ $k++ _]  |- _] => *)
  (*   erewrite reduce_merge_perms in H by (clean_map_lookups; eauto) *)
  (* | [ H : context [_ $k++ _]  |- _] => *)
  (*   unfold merge_perms, add_key_perm, fold in H; clean_map_lookups *)

  | [ H : context [ _ $+ (?k1,_) $? ?k2] |- _ ] =>
    (* (rewrite add_neq_o in H by solve_simple_ineq) *)
    (rewrite add_eq_o in H by trivial)
    || (rewrite add_neq_o in H by congruence)
  | [ H : context [ ?m $? _ ] |- _ ] =>
    progress (unfold m in H)

  | [ |- context [$0 $k++ _] ] => rewrite !merge_perms_left_identity
  | [ |- context [_ $k++ $0] ] => rewrite !merge_perms_right_identity

  | [ H : context [[] ++ _] |- _ ] => rewrite !app_nil_l in H
  | [ H : context [_ ++ []] |- _ ] => rewrite !app_nil_r in H
  end || discriminate || eq1.

Ltac print_nosilents :=
  repeat
    match goal with
    | [ H : NoSilent ?uidA _ |- _ ] => idtac "NoSilent ready for assert: " uidA; fail
    end.

Ltac prove_gt_pred :=
  intros
  ; simpl in *
  ; repeat
      match goal with
      | [ H : context [ _ $+ (_,_) $- _ ] |- _ ] =>
        repeat (
            (rewrite map_add_remove_neq in H by congruence)
            || (rewrite map_add_remove_eq in H by trivial)
            || (rewrite remove_empty in H)
          )
      | [ H : _ $+ (?uid,_) $? ?uid' = Some _ |- _ ] =>
        destruct (uid ==n uid'); subst; simple_clean_maps; try lia
      | [ H : NoSilent ?uid _ |- ~ indexedRealStep ?uid _ _ _ ] =>
        eapply NoSilent_no_indexed_silent_step
        ; eauto 2
      end.

Ltac assert_gt_pred U uid :=
  let P := fresh "P"
  in assert (forall uid' ud' U', U.(RealWorld.users) $? uid' = Some ud'
                            -> uid' > uid
                            -> ~ indexedRealStep uid' Silent U U') as P by prove_gt_pred
     ; pose proof (upper_users_cant_step_rewrite P); clear P
.

Ltac solve_all_users_no_silent :=
  repeat
    lazymatch goal with
    | [ |- _ -> _ ] => intros
    | [ |- ~ indexedRealStep ?uid _ _ _ ] => eapply all_users_NoSilent_no_indexed_silent_step
    | [ H : RealWorld.users _ $? _ = Some _ |- _ ] => unfold RealWorld.users in H
    | [ H : _ $+ (?conUid,_) $? ?uid = Some _ |- NoSilent ?uid _ ] =>
      destruct (conUid ==n uid); subst; simple_clean_maps
    | [ H : NoSilent ?uid _  |- NoSilent ?uid _ ] => exact H
    end.

Ltac assert_no_silents U :=
  let P := fresh "P"
  in assert (forall uid U', ~ indexedRealStep uid Silent U U') as P by solve_all_users_no_silent
.

Ltac getNextAction p :=
  match p with
  | RealWorld.Bind ?n _ => getNextAction n
  | ?n                  => idtac n
  end.

Ltac assertSilentStatus uid U p :=
  let rec assertSilentStatus' pr :=
      lazymatch pr with
      | RealWorld.Bind ?n _ => assertSilentStatus' n
      | RealWorld.Send _ _  => assert (NoSilent uid U) by (econstructor; unfold not; intros; rstep)
      | RealWorld.Recv _    => assert (NoSilent uid U) by (econstructor; unfold not; intros; rstep)
      | ?n                  => assert (exists U', indexedRealStep uid Silent U U') by solve_indexedRealStep
      end
  in lazymatch p with
     | RealWorld.Return _  => assert (NoSilent uid U) by (econstructor; unfold not; intros; rstep)
     | _                   => assertSilentStatus' p
     end.

Ltac find_silent_step U us :=
  let MAX := fresh "MEQ"
  in  remember (O.max_elt us) eqn:MAX
      ; unfold O.max_elt in MAX
      ; simpl in MAX
      ; lazymatch type of MAX with
        | _ = Some (?uid,?u) =>
          match goal with
          | [ H : NoSilent uid U |- _ ] => idtac "already have it"; find_silent_step U (us $- uid)
          | _ =>
            let p := (eval cbn in u.(RealWorld.protocol))
            in  assertSilentStatus uid U p
                ; subst; split_ex
                ; lazymatch goal with
                  | [ H : NoSilent uid _ |- _ ] => find_silent_step U (us $- uid)
                  | [ H : indexedRealStep uid Silent _ _ |- _ ] => assert_gt_pred U uid
                  end
          end
        | _ => assert_no_silents U
        end
(* ; clear MAX *)
.

Ltac solve_noresends :=
  unfold NoResends.no_resends_U, fst, RealWorld.users
  ; rewrite Forall_natmap_forall; intros
  ; focus_user; simpl
  ; unfold NoResends.no_resends
  ; repeat
      match goal with
      | [ |- NoDup [] ] => apply NoDup_nil
      | [ |- NoDup (_ :: _) ] => apply NoDup_cons
      | [ |- ~ List.In _ _ ] =>
        unfold not; simpl; intros; split_ors; repeat invert_base_equalities1; try contradiction
      end
  ; eauto.

Ltac finish_noresends_invariant :=
  rwuf
  ; try match goal with
        | [ |- context [{| RealWorld.users := ?users |} ]] =>
          ccmag users
        end
  ; unfold noresends_inv, safety, alignment, returns_align
  ; repeat simple apply conj
  ; [ solve_noresends
    | trivial
    | unfold labels_align; intros; rstep; subst; solve_labels_align
    | try solve [ simpl; intros; find_step_or_solve' ]
    ].

Ltac finish_invariant :=
  rwuf
  ; try match goal with
    | [ |- context [{| RealWorld.users := ?users |} ]] =>
      ccmag users
    end
  ; unfold safety_inv, safety, alignment, returns_align
  ; repeat simple apply conj
  ; [ finish_honest_cmds_safe; simple_clean_maps; eauto 8
    | trivial
    | unfold labels_align; intros; rstep; subst; solve_labels_align
    | try solve [ simpl; intros; find_step_or_solve' ]
    ].

Ltac prove_honest_heaps_sane :=
  repeat
    match goal with
    | [ H : _ |- _ ] => clear H
    end
  ; unfold InvariantSearchLemmas.honest_heaps_sane
  ; intros
  ; match goal with
    | [ USRS : _ $+ (_,_) $? _ = Some _ |- _ ] =>
      repeat
        match type of USRS with
        | _ $+ (?uid1,_) $? ?uid2 = Some _ => destruct (uid1 ==n uid2); subst; simple_clean_maps
        end
    end
  ; unfold RealWorld.c_heap, RealWorld.key_heap, List.In
  ; split
  ; intros
  ; repeat
      match goal with
      | [ |- In ?kid2 _ ] =>
        rewrite in_find_iff; unfold not; intros
      | [ H : _ \/ _ |- _ ] => destruct H
      | [ H : _ $+ (?kid1,_) $? ?kid2 = None |- False ] =>
        destruct (kid1 ==n kid2); subst; simple_clean_maps
      | [ H : _ $k++ _ $? _ = Some _ |- False ] =>
        apply KeysTheory.merge_perms_split in H; destruct H; solve_concrete_maps
      end
  ; trivial.

Ltac forward_nosilents :=
  lazymatch goal with
  | [ XX : NoSilent _ _ |- _ ] =>
    match goal with
    | [ H : honest_heaps_sane ?usrs ?cs ?gks -> propNoSilent _ _ |- _ ] =>
      ( let HHS := fresh "HHS" in
        assert (InvariantSearchLemmas.honest_heaps_sane usrs cs gks) as HHS by prove_honest_heaps_sane
        ; apply H in HHS
        ; clear H
        ; repeat
            match goal with
            | [ NS : NoSilent ?uid _ |- _ ] =>
              idtac "asserting nosilent " uid
              ; generalize (HHS _ NS)
              ; clear NS
            end
        ; clear HHS
        ; intros
      ) || fail 3
    end
  | [ H : honest_heaps_sane _ _ _ ->  _ |- _ ] =>
    clear H
  | _ => idtac
  end.
  (* try  *)
  (*   match goal with *)
  (*   | [ PROPNS : propNoSilent _ _ |- _ ] => *)
  (*     repeat  *)
  (*       match goal with *)
  (*       | [ NS : NoSilent ?uid _ |- _ ] => *)
  (*         idtac "asserting nosilent " uid *)
  (*         ; generalize (PROPNS _ NS) *)
  (*         ; clear NS *)
  (*       end *)
  (*     ; clear PROPNS *)
  (*     ; intros *)
  (*   end. *)

Ltac clear_nosilents :=
  idtac "Clearing NoSilents"
  ; repeat
      match goal with
      | [ H : NoSilent _ _ |- _ ] => clear H
      | [ H : propNoSilent _ _ |- _ ] => clear H
      | [ H : honest_heaps_sane _ _ _ ->  _ |- _ ] => clear H
      end.

Ltac invSS1 :=
  discriminate
  || match goal with
    | [ STEP : (stepSS (t__adv := _)) ^* (?U,_,_) _
      , IRS : indexedRealStep ?uid Silent ?U ?RU
      , P : (forall _ _, _ > ?uid -> _)
        |- _ ] =>

      ( let PROOF := fresh "PROOF" in
        pose proof (InvariantSearchLemmas.ssteps_inv_silent STEP eq_refl IRS P) as PROOF
        ; clear STEP IRS P RU
        ; unfold RealWorld.users, RealWorld.all_ciphers, RealWorld.all_keys in PROOF
        ; split_ex
        ; clear_nosilents
        (* ; forward_nosilents *)
        ; idtac "Found silents"
      ) || fail 1

    | [ H : action_matches _ _ _ _ |- _] => invert H
    | [H : indexedRealStep _ _ _ _ |- _ ] =>
      invert H
    | [H : RealWorld.step_universe _ ?u _ _ |- _] =>
      concrete u; chu
    | [H : RealWorld.step_user _ None _ _ |- _] =>
      invert H
    | [H : RealWorld.step_user _ _ ?u _ |- _] =>
      concrete u; chu
    | [ H : indexedIdealStep _ _ _ _ |- _ ] => istep (* run _after_ real steps *)

    | [ STEP : (stepSS (t__adv := _)) ^* (?ru,?iu,?b) _
      , P : (forall _ _, ~ indexedRealStep _ Silent _  _)
        |- _ ] =>

      progress ( unfold not in P )

    | [ STEP : (stepSS (t__adv := _)) ^* (?ru,?iu,?b) (_,_,_)
      , P : (forall _ _, indexedRealStep _ Silent _ _ -> False)
        |- _ ] =>

      concrete ru
      ; match goal with
        | [ LA : labels_align (?ru,?iu,?b) |- _ ] =>
          let PROOF := fresh "PROOF" in
          pose proof (ssteps_inv_labeled P STEP LA eq_refl) as PROOF
          ; clear STEP P LA
          ; clear_nosilents
          ; destruct PROOF
          ; split_ex
          ; subst

        | _ =>
          idtac "proving alignment 4"
          ; assert (labels_align (ru,iu,b)) by ((repeat prove_alignment1); eauto)
        end

    | [ STEP : (stepSS (t__adv := _)) ^* ?st ?st'
      , P : (forall _ _, indexedRealStep _ Silent _ _ -> False)
        |- _ ] =>

      match st with
      | (_,_,_) => idtac
      | _ => destruct st as [[?ru ?iu] ?b]
      end
      ; match st' with
        | (_,_,_) => idtac
        | _ => destruct st' as [[?ru' ?iu'] ?b']
        end

    | [ H : (stepSS (t__adv := _)) ^* (?U,_,_) _ |- _ ] =>

      match U with
      | {| RealWorld.users := ?usrs |} =>
        match usrs with
        | context [ {| RealWorld.protocol := realServer 0 _ _ |} ] =>
          idtac "rewriting server done"; rewrite realserver_done in H
        | context [ {| RealWorld.protocol := realServer _ _ _ |} ] =>
          idtac "unrolling server"; erewrite unroll_realserver_step in H by reflexivity
        | _ =>
          idtac "finding silent steps..."
          (* ; forward_nosilents *)
          ; find_silent_step U usrs
          ; clear_nosilents
        end
      end

    | [ H : forall _ _ _, _ -> _ -> _ -> _ <-> _ |- _ ] => clear H
    | [ H : forall _ _ _ _, _ -> _ -> _ -> _ -> _ <-> _ |- _ ] => clear H
    | [ H : (forall _ _ _, indexedRealStep _ _ ?ru _ ->
                      exists _ _ _, (indexedIdealStep _ _) ^* ?iu _ /\ _) |- _ ] =>
      clear H

    | [ |- safety_inv (?ru,_,_) ] =>
      concrete ru; clear_nosilents; solve [ finish_invariant ]

    | [ |- noresends_inv (?ru,_,_) ] =>
      concrete ru; clear_nosilents; solve [ finish_noresends_invariant ]

    | [ H : _ \/ _ |- _ ] => destruct H; split_ex; subst
    end.

Tactic Notation "canonicalize" "context" :=
  rwuf
  ; try
      match goal with
      | [ H : stepSS (?ru,?iu,_) _ |- _ ] =>
        match ru with
        | context [{| RealWorld.users := ?usrs |}] =>
          ccm usrs H
        end
        ; match iu with
          | context [{| IdealWorld.users := ?usrs |}] =>
            ccm usrs H
          end
      | [ H : (stepSS (t__adv:=_)) ^* (?ru,?iu,_) _ |- _ ] =>
        match ru with
        | context [{| RealWorld.users := ?usrs |}] =>
          ccm usrs H
        end
        ; match iu with
          | context [{| IdealWorld.users := ?usrs |}] =>
            ccm usrs H
          end
      end
  ; try
      match goal with
      | [ H : _ -> propNoSilent _ ?ru |- _ ] =>
        match ru with
        | context [{| RealWorld.users := ?usrs |}] =>
          ccm usrs H
        end
      end.

Ltac find_runtime :=
  repeat
    match goal with
    | [ |- boundRunningTimeUniv (_ $+ (?usr,_)) _ ] =>
      eapply BrtRecur with (uid := usr); eauto 2; simpl
    | [ |- boundRunningTime _ _ ] => econstructor; eauto 2
    | [ |- _ -> _ ] => intros
    | [ |- boundRunningTimeUniv (_ $+ (?usr,_) $- _) _ ] =>
      repeat
        (rewrite map_add_remove_neq by congruence)
      || (rewrite map_add_remove_eq by trivial)
      || (rewrite remove_empty)
    | [ |- boundRunningTimeUniv $0 _ ] => apply BrtEmpty
    | [ |- queues_size _ = _ ] => unfold queues_size, fold; trivial
    end.

Lemma findKeysMessage_getKey_compatible :
  forall (m : RealWorld.message.message Access),
  exists kp,
    RealWorld.findKeysMessage m $? getKey m = Some kp.
Proof.
  intros.
  dependent destruction m.
  unfold getKey; simpl.
  destruct acc
  ; simpl
  ; eauto.
Qed.

Lemma findKeysMessage_getKey_verify_pr_compatible :
  forall (m : bool * RealWorld.message.message Access),
  exists kp, RealWorld.findKeysMessage (snd m) $? getKey (snd m) = Some kp.
Proof.
  intros.
  destruct m.
  dependent destruction m; unfold getKey; simpl.
  eauto.
Qed.

Lemma findKeysMessage_getKey_pr_compatible1 :
  forall t (m : RealWorld.message.message (TPair Access t)),
  exists kp,
    RealWorld.findKeysMessage m $? getKey (RealWorld.message.msgFst m) = Some kp.
Proof.
  intros.
  induct m; simpl.
  clear IHm1 IHm2.
  pose proof (findKeysMessage_getKey_compatible m1); split_ex.
  cases (RealWorld.findKeysMessage m2 $? getKey m1)
  ; eexists
  ; eauto.
Qed.

Lemma findKeysMessage_getKey_pr_compatible2 :
  forall t (m : RealWorld.message.message (TPair t Access)),
  exists kp,
    RealWorld.findKeysMessage m $? getKey (RealWorld.message.msgSnd m) = Some kp.
Proof.
  intros.
  induct m; simpl.
  clear IHm1 IHm2.
  pose proof (findKeysMessage_getKey_compatible m2); split_ex.
  cases (RealWorld.findKeysMessage m1 $? getKey m2)
  ; eexists
  ; eauto.
Qed.

Ltac typechecks1 :=
  simple_clean_maps1
  || match goal with
    | [ |- syntactically_safe _ _ _ (RealWorld.Return _) _ ] =>
      solve [ eapply SafeReturn; repeat typechecks1 ] || apply SafeReturnUntyped
    | [ |- syntactically_safe _ _ _ _ _ ] =>
      econstructor
    | [ |- _ -> _ ] => intros
    | [ H : RealWorld.findKeysMessage _ $? _ = Some _ |- _ ] => progress (simpl in H)
    | [ H : _ $+ (?k1,_) $? ?k2 = Some _ |- _ ] =>
      destruct (k1 ==n k2); subst
    | [ H : _ $k++ _ $? _ = Some _ |- _ ] =>
      apply merge_perms_split in H; split_ors
    | [ |- HonestKey _ (fst ?k) ] => destruct k; simpl; eapply HonestPermission
    | [ |- HonestKey _ (getKey (snd ?m)) ] =>
      pose proof (findKeysMessage_getKey_verify_pr_compatible m); split_ex
      ; eapply HonestKeyFromMsgVerify with (v := m); eauto 2
    | [ |- HonestKey _ (getKey (RealWorld.message.msgFst ?m)) ] =>
      pose proof (findKeysMessage_getKey_pr_compatible1 m); split_ex
      ; eapply HonestFromMsg with (msg := m); eauto 2
    | [ |- HonestKey _ (getKey (RealWorld.message.msgSnd ?m)) ] =>
      pose proof (findKeysMessage_getKey_pr_compatible2 m); split_ex
      ; eapply HonestFromMsg with (msg := m); eauto 2
    | [ |- HonestKey _ (getKey ?m) ] =>
      pose proof (findKeysMessage_getKey_compatible m); split_ex
      ; eapply HonestFromMsg with (msg := m); eauto 2
    | [ |- HonestKey _ _ ] => eapply HonestPermission
    | [ |- HonestKey _ _ /\ _ ] => split; trivial
    | [ |- List.In _ _ ] => progress simpl
    | [ |- _ \/ _ ] => (left; reflexivity) || right
    | [ |- List.In _ ?l ] => is_evar l; eauto 2
    | [ |- _ <> _ ] => congruence
    end.

Ltac verify_context_soundness :=
  match goal with
  | [ |- typingcontext_sound _ _ _ _ ] =>
    unfold typingcontext_sound
    ; repeat simple apply conj; intros; simpl
  | [ H : HonestKey _ ?kid |- RealWorld.findUserKeys _ $? ?kid = Some true ] =>
    unfold RealWorld.findUserKeys,fold; simpl; invert H
  | [ H : List.In _ _ |- _ ] => simpl in H; split_ors; try contradiction
  | [ H : {| cmd_type := _ |} = _ |- _ ] => apply safe_typ_eq in H; split_ex; subst; try discriminate
  | [ H : JMeq.JMeq _ _ |- _ ] => invert H
  | [ |- _ $k++ _ $? _ = Some true ] => KeysTheory.solve_perm_merges
  end || invert_base_equalities1.

Ltac build_summary :=
  repeat
    match goal with
    | [ |- _ $+ (?k1,_) $? ?k2 = Some _ ] => rewrite add_neq_o by congruence
    | [ |- _ $? ?k2 = Some _ ] => rewrite add_eq_o by reflexivity
    end.

(* Ltac t := (repeat eq1); try invSS1. *)
(* Ltac u := (repeat cleanup1); invSS1(* ; istep *); (repeat cleanup1). *)
Ltac do_trsys_step := invSS1; (repeat cleanup1); subst.

Ltac transition_system_step :=
  rwuf; do_trsys_step; canonicalize context.