theory RB_Relaxed_mike imports RCU_Lems
begin

datatype F = B | W | Q | R
datatype Pointer = Head | Tail

consts n :: nat   (*size of buffer, input*)
consts N :: nat   (*number of Arr\<^sub>W entries*)

(*(Wr T u t b \<sigma>)*)
(*
lemma pval_val:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
  and "ts = getTS \<sigma> w"
shows "\<not> [x \<approx>\<^sub>t u] (write_trans t b w v \<sigma> ts) "
  sorry
*)

lemma pval_val_same:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v t b \<sigma>)"
  using assms
  apply (simp add: p_obs_def visible_writes_def value_def write_trans_def)
  apply(simp add: rev_app_def update_modView_def update_mods_def update_thrView_def update_wa_def)
  apply safe
  using w_in_writes_on_var apply blast
  defer
  apply (simp add: getVWNC_var)
   apply (simp add: getVWNC_var)
  apply(case_tac "(a, ba)
       \<in> writes_on \<sigma> x")
  apply (smt dual_order.strict_trans getTS_w_greater_tst_w getVWNC_in_visible_writes le_neq_trans less_le_not_le mem_Collect_eq visible_writes_def)
proof -
fix a :: nat and ba :: rat
  assume a1: "(a, ba) \<in> writes_on (\<sigma> \<lparr>thrView := (thrView \<sigma>) (t := (thrView \<sigma> t) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> t (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) := (thrView \<sigma> t) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> t (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) := True)\<rparr>) (var w)"
  assume a2: "x = var w"
  assume a3: "(a, ba) \<notin> writes_on \<sigma> x"
  assume a4: "ba \<noteq> getTS \<sigma> (getVWNC \<sigma> t (var w))"
  have f5: "\<forall>s n p. var p = n \<and> p \<in> surrey_state.writes (s::surrey_state) \<or> p \<notin> writes_on s n"
    using writes_on_def by force
  have "\<forall>s n p. writes_on (write_available_update p (s::surrey_state)) n = writes_on s n"
    by (metis (no_types) surrey_state.select_convs(1) surrey_state.surjective surrey_state.update_convs(5) writes_on_def)
  then have f6: "(a, ba) \<in> writes_on (\<sigma> \<lparr>thrView := (thrView \<sigma>) (t := (thrView \<sigma> t) (x := (x, getTS \<sigma> (getVWNC \<sigma> t x)))), modView := (modView \<sigma>) ((x, getTS \<sigma> (getVWNC \<sigma> t x)) := (thrView \<sigma> t) (x := (x, getTS \<sigma> (getVWNC \<sigma> t x)))), mods := (mods \<sigma>) ((x, getTS \<sigma> (getVWNC \<sigma> t x)) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (x, getTS \<sigma> (getVWNC \<sigma> t x)) (surrey_state.writes \<sigma>)\<rparr>) x"
    using a2 a1 by blast
  have f7: "\<forall>s f. surrey_state.writes (writes_update f (s::surrey_state)) = f (surrey_state.writes s)"
    by auto
  have f8: "var (a, ba) = x"
    using f6 f5 by meson
  have "(a, ba) \<in> surrey_state.writes \<sigma>"
    using f7 f6 f5 a4 a2 by (metis insert_iff snd_conv)
  then show False
    using f8 a3 writes_on_def by force
qed

lemma pval_val_other:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
  and "t\<noteq>s"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v s b \<sigma>)"
  using assms apply simp
  apply (simp add: p_obs_def visible_writes_def value_def write_trans_def)
    apply(simp add: rev_app_def update_modView_def update_mods_def update_thrView_def update_wa_def)
  apply safe
  using w_in_writes_on_var
  apply (simp add: w_in_writes_on_var getVWNC_var)
  apply (simp add: getVWNC_var)

  apply(case_tac "(a, ba)
       \<in> writes_on \<sigma> x")
  apply (smt dual_order.strict_trans getTS_w_greater_tst_w getVWNC_in_visible_writes le_neq_trans less_le_not_le mem_Collect_eq visible_writes_def)
proof -
  fix a :: nat and ba :: rat
  assume a1: "ba \<noteq> getTS \<sigma> (getVWNC \<sigma> s (var w))"
  assume a2: "(a, ba) \<in> writes_on (\<sigma> \<lparr>thrView := (thrView \<sigma>) (s := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := True)\<rparr>) (var w)"
  assume a3: "(a, ba) \<notin> writes_on \<sigma> x"
  assume a4: "x = var w"
  have "(a, ba) \<in> \<lbrace>\<acute>var = var w \<and> \<acute>(\<in>) (surrey_state.writes (\<sigma> \<lparr>thrView := (thrView \<sigma>) (s := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := True)\<rparr>))\<rbrace>"
    using a2 writes_on_def by blast
  then have f5: "var (a, ba) = var w \<and> (a, ba) \<in> surrey_state.writes (\<sigma> \<lparr>thrView := (thrView \<sigma>) (s := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := True)\<rparr>)"
    by blast
  then have "(a, ba) \<notin> surrey_state.writes \<sigma>"
    using a4 a3 writes_on_def by fastforce
  then show False
    using f5 a1 by simp
qed

lemma pval_val:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v t' b \<sigma>)"
  using assms apply (cases "t=t'")
  using pval_val_same apply blast
  using pval_val_other by blast

lemma pval_val_outside:
  assumes "wfs \<sigma>"
  and "N\<in> \<nat>"
  and "\<forall>j.[x \<approx>\<^sub>t j] \<sigma> \<longrightarrow> j<N"
  and "\<forall>k. k<N \<longrightarrow> [x \<approx>\<^sub>t k] \<sigma>"
  and "u\<in>\<nat> \<and> u<N"
shows "\<forall>z.(z>N\<longrightarrow>\<not>[x \<approx>\<^sub>t z] (Wr x u t' b \<sigma>))"
  using assms apply (cases "t=t'")
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  by (metis fst_conv not_less_iff_gr_or_eq pval_val)

lemma pval_val_outside_2:
  assumes "wfs \<sigma>"
  and "N \<in> \<nat>"
  and "[x =\<^sub>t 0] \<sigma>"
  and "u \<noteq> 0"
shows "\<exists>i.(([x =\<^sub>t i] (Wr x u t b \<sigma>))\<or>([x =\<^sub>t i] (Wr x 0 t' b \<sigma>)))"
  using assms apply (cases "t=t'")
  using OpSem_ProofRules.ext_d_obs_d_obs apply blast
  using OpSem_ProofRules.ext_d_obs_d_obs by blast

(*
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v t b \<sigma>)"

lemma pval_val_all:
  assumes "wfs \<sigma>"
  and "\<forall>i. i > k \<longrightarrow> \<not> [x \<approx>\<^sub>t i] \<sigma>"
  and "k < j"
  and "u \<le> k"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t j] (Wr x v t b \<sigma>) "
  using assms

  using pval_val sledgehammer
*)

consts
  H :: L
  T :: L

record LB =
  hW ::  V               (*local copy of W*)
  tW ::  V               (*local copy of W*)
  q :: "(nat \<times> nat) list" (*for now assume well synchronised, need to think about weak memory *)
  tempR :: "(nat \<times> nat)"          (*local copy of word by R*)

  tloc :: V
  Data:: "nat  \<Rightarrow> nat"     (*returns a word Data_i*)
  countW :: nat  (* the index of the next element of Data to be written  *)
  countR :: nat  (* how many words from Data the read has read or reading (i.e., retrieved)  *)

  ownD :: "nat \<Rightarrow> F" (* ownership of data indices *)
  ownB :: "nat \<Rightarrow> F" (* ownership of bytes in buffer *)
  (* tries :: nat *)
  oom :: bool       (*signals W that it was OOM*)
  \<sigma> :: surrey_state

definition "global s \<equiv> wfs s \<and> H \<noteq> T"

lemmas opsemsyntax [simp] =  global_def
lemmas defs_del [simp del] =  Rd_def Let_def Wr_def Upd_def st_rd_def val_rd_def

(* thread 2 is the writer *)
(* thread 3 is the reader *)

(* Omit tries *)
(* Finish queueu + reader *)

(* We need this one to hold at minimum *)
definition "arrayInv s \<equiv> \<forall>i. (i<countR s \<longrightarrow> ownD s i = R)\<and> (countR s \<le> i \<and> i < countW s \<longrightarrow> ownD s i = B) \<and> (countW s \<le> i \<and> i < n \<longrightarrow> ownD s i = W) "

definition "q_entries_bounded s \<equiv> (\<forall>i. i < length(q s) \<longrightarrow> (fst(q s!i)+snd(q s!i)\<le>N)\<and>snd(q s!i)>0)"
definition "tempR_bounded s \<equiv> fst (tempR s) + snd (tempR s) \<le> N"
definition "counter_q_rel s \<equiv> (countW s-countR s=length(q s))"
definition "con_assms s  \<equiv>   0 < N \<and> 0<n \<and> (countR s\<le>countW s) \<and> (countW s\<le>n)
                             \<and> (\<forall>i.(i<n)\<longrightarrow>Data s i\<le>N \<and> Data s i>0)"
(*new
(typically)
\forall x . P(x) \<longrightarrow> Q(x)
\exists x . P(x) \<and> Q(x)

[H =\<^sub>2 i] means thread 2 sees the last write to H and this has value i.
[H \<approx>\<^sub>2 i] means that thread 2 can see the value i.
*)
definition "bounded_pointers s \<equiv> ((\<forall>i. i > N \<longrightarrow> \<not>[H \<approx>\<^sub>2 i] (\<sigma> s)))\<and>
                                 ((\<forall>j. j > N \<longrightarrow> \<not>[T \<approx>\<^sub>2 j] (\<sigma> s)))"

definition "basic_pointer_movement s \<equiv> 0\<le>hW s\<and> hW s\<le>N \<and> 0\<le>tW s\<and> tW s\<le>N"

definition "collection s \<equiv> arrayInv s \<and> q_entries_bounded s
                          \<and>tempR_bounded s \<and>counter_q_rel s \<and> con_assms s
                          \<and> bounded_pointers s \<and> basic_pointer_movement s"

definition "init s \<equiv>
                     [T =\<^sub>2 0] (\<sigma> s) \<and> [H =\<^sub>2 0] (\<sigma> s) \<and> [T =\<^sub>3 0] (\<sigma> s) \<and> (q s = []) \<and> (hW s = 0) \<and> (tW s = 0)
                        \<and> (\<forall>l. (l<n) \<longrightarrow>  ((Data s l > 0)\<and>(Data s l \<le> N)))
                        \<and> (\<forall>i. (i<n) \<longrightarrow>  ownD s i = W)
                        \<and> (\<forall>i. (i\<le>N) \<longrightarrow>  ownB s i = B)
                        \<and> (countW s = 0) \<and> (countR s = 0)
                        \<and> (tempR s = (0,0)) \<and> \<not> oom s "

definition "grd1 s \<equiv> (tW s = hW s) \<and> (Data s (countW s) \<le> N) "
definition "grd2 s \<equiv> (tW s > hW s) \<and> (Data s (countW s) < (tW s - hW s)) "
definition "grd3 s \<equiv> tW s < hW s "
definition "grd4 s \<equiv> Data s (countW s) \<le> N - hW s "
definition "grd5 s \<equiv> Data s (countW s) < tW s "
definition "no_space_for_word s \<equiv> (grd1 s \<longrightarrow> \<not>(Data s (countW s) \<le> N))\<and>
                                  (grd2 s \<longrightarrow> \<not>(Data s (countW s) < (tW s - hW s)))\<and>
                                  (grd3 s \<longrightarrow> \<not>(Data s (countW s) \<le> N - hW s \<or> Data s (countW s) < tW s))"

lemmas main_invariant_lemmas = collection_def arrayInv_def q_entries_bounded_def
                                      counter_q_rel_def tempR_bounded_def con_assms_def
                                      init_def bounded_pointers_def basic_pointer_movement_def
                                      pval_val_same pval_val_other pval_val
lemmas guards = grd1_def grd2_def grd3_def grd4_def grd5_def no_space_for_word_def

lemma LoadBuffering:
 "\<parallel>-   \<lbrace> global \<acute>\<sigma>  \<and> \<acute>collection  \<and> \<acute>init \<rbrace>
COBEGIN
\<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> \<not> \<acute>oom \<and> \<acute>init\<rbrace>
  WHILE \<acute>countW < n
   INV \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> (\<exists> i. [H =\<^sub>2 i]\<acute>\<sigma>)\<rbrace>
   DO
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> (\<exists> i. [H =\<^sub>2 i]\<acute>\<sigma>) \<and> \<acute>countW < n\<rbrace> \<comment> \<open>A1\<close>
      <\<acute>hW \<leftarrow>\<^sub>2 H\<acute>\<sigma>> ;;
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n\<rbrace>
      <\<acute>tW \<leftarrow>\<^sub>2 T\<acute>\<sigma>> ;;
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n\<rbrace>
      IF \<acute>grd1 \<comment> \<open>A2\<close>
      THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd1 \<rbrace> \<comment> \<open>A3\<close>
            <T :=\<^sub>2 0 \<acute>\<sigma>> ;; \<comment> \<open>This might not need to be releasing\<close>
            \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd1 \<rbrace>
            \<langle><H :=\<^sub>2 (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>hW := 0 ,, \<acute>oom := False ,,
              (\<acute>ownB := ( \<lambda> x. if 0\<le> x \<and> x < (\<acute>Data \<acute>countW) then W else \<acute>ownB x ))\<rangle>
      ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<not>\<acute>grd1 \<rbrace>
            IF \<acute>grd2
            THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd2\<rbrace> \<comment> \<open>A4\<close>
                \<langle><H :=\<^sub>2 \<acute>hW + (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>oom := False ,,
                  (\<acute>ownB := ( \<lambda> x. if \<acute>hW \<le> x \<and> x < (\<acute>hW + (\<acute>Data \<acute>countW)) then W else \<acute>ownB x ))\<rangle>
            ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<not>\<acute>grd1 \<and> \<not>\<acute>grd2\<rbrace>
                 IF \<acute>grd3
                 THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<rbrace> \<comment> \<open>A5\<close>
                      IF \<acute>grd4
                      THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<and> \<acute>grd4 \<rbrace> \<comment> \<open>A6\<close>
                      \<langle><H :=\<^sub>2 \<acute>hW + (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>oom := False ,,
                         (\<acute>ownB := ( \<lambda> x. if \<acute>hW \<le> x \<and> x < (\<acute>hW + (\<acute>Data \<acute>countW)) then W else \<acute>ownB x ))\<rangle>
                      ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<and> \<not>\<acute>grd4 \<rbrace>
                            IF \<acute>grd5
                            THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<and> \<acute>grd5 \<rbrace> \<comment> \<open>A7\<close>
                              \<langle><H :=\<^sub>2 (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>hW := 0 ,, \<acute>oom := False ,,
                                (\<acute>ownB := ( \<lambda> x. if ((0 \<le> x \<and> x < (\<acute>Data \<acute>countW))\<or> x\<ge>T)\<and>x\<noteq>N then W else \<acute>ownB x ))\<rangle>
                            ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>no_space_for_word\<rbrace> \<comment> \<open>A8\<close>
                                \<langle>\<acute>oom := True\<rangle>
                                  \<comment> \<open>OOM\<close>
                            FI
                      FI
                 ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>no_space_for_word\<rbrace>
                      \<langle>\<acute>oom := True\<rangle>
                      \<comment> \<open>OOM\<close>
                 FI
           FI
     FI;;
     \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection
        \<and> ((\<acute>oom=False \<and> [H =\<^sub>2 (\<acute>hW+(\<acute>Data \<acute>countW))]\<acute>\<sigma> ) \<comment> \<open>\<and> \<acute>hW  + \<acute>Data (\<acute>countW) \<le> N\<close>
             \<or> (\<acute>oom=True \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>no_space_for_word)) \<and> \<acute>countW < n\<rbrace>
     IF \<acute>oom=True
     THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>no_space_for_word \<and> \<acute>countW < n\<rbrace> \<comment> \<open>OK\<close>
          SKIP
     ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> \<acute>countW < n \<and> [H =\<^sub>2 (\<acute>hW+(\<acute>Data \<acute>countW))]\<acute>\<sigma>\<rbrace>
          \<langle>\<acute>q := \<acute>q @ [(\<acute>hW, (\<acute>Data \<acute>countW))],,
           \<acute>ownD := (\<lambda> x. if x = \<acute>countW then B else \<acute>ownD x),,
           \<acute>ownB := (\<lambda> x. if (\<acute>ownB x = W) then Q else \<acute>ownB x),,
           \<acute>countW := (\<acute>countW+1)\<rangle>
     FI
   OD
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countW = n\<rbrace>

\<parallel>
 \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>tempR = (0, 0) \<rbrace>
  WHILE \<acute>countR < n
  INV \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>tempR=(0,0) \<rbrace>
  DO  \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countR < n \<and> \<acute>tempR=(0,0) \<rbrace>
      IF \<acute>countR < \<acute>countW THEN
                \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countR < \<acute>countW \<and> \<acute>tempR=(0,0) \<rbrace> \<comment> \<open>retrieve from Q, dequeue\<close>
                \<langle> \<acute>tempR  := (fst(hd \<acute>q),(snd(hd \<acute>q))) ,,
                    \<acute>ownD := (\<lambda> x. if x = \<acute>countR then R else \<acute>ownD x),,
                    \<acute>countR := \<acute>countR+1,,
                    ( IF \<exists>i.(i<(fst(hd \<acute>q)+snd(hd \<acute>q)) \<and> [T =\<^sub>3 i] \<acute>\<sigma>) THEN (\<acute>ownB := ( \<lambda> x. if i \<le> x \<and> x < (fst(hd \<acute>q)+(snd(hd \<acute>q))) then R else \<acute>ownB x ))
                      ELSE (\<acute>ownB := ( \<lambda> x. if i > x \<and> x \<le> (fst(hd \<acute>q)+(snd(hd \<acute>q)))\<or>(x=N) then \<acute>ownB x else R ))FI),,
                     \<acute>q := (tl \<acute>q) \<rangle>;;
                    \<lbrace> global \<acute>\<sigma> \<and>\<acute>collection \<and> \<acute>countR \<le> \<acute>countW  \<and> \<acute>tempR\<noteq>(0,0)\<rbrace> \<comment> \<open>Push T\<close>
                    \<langle><T :=\<^sub>3 (fst \<acute>tempR + snd \<acute>tempR) \<acute>\<sigma> >
                    ,, \<acute> tempR := (0,0),,
                   \<acute>ownB := (\<lambda> x. if \<acute>ownB x = R then B else \<acute>ownD x) \<rangle>
      ELSE
      \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>tempR=(0,0) \<and> \<acute>countR < n\<rbrace>
      SKIP
      FI
  OD
\<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countR = n\<rbrace>

COEND
  \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countW = n \<and> \<acute>countR = n\<rbrace>

"
  apply (oghoare)
  apply ((simp add: main_invariant_lemmas Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff; force)+)[4]
  apply ((simp add: guards main_invariant_lemmas Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)[1]
  apply (metis OpSem_ProofRules.d_obs_read_value OpSem_ProofRules.ext_d_obs_rd_pres d_obs_implies_p_obs le_less_linear)
  apply auto[1]
  apply ((simp add: guards main_invariant_lemmas Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)[1]
  apply clarsimp
  apply (meson not_less not_pobs_contradiction)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  using pval_val apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[3]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply auto[3]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis (no_types, lifting) Suc_diff_le d_obs_implies_p_obs fst_eqD le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply clarsimp
  apply (simp_all add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)
          (*129*)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred hd_conv_nth length_0_conv length_tl less_numeral_extra(3) nat.inject nth_tl snd_conv zero_less_diff)
  apply clarify
  using pval_val apply auto[1]
  using OpSem_ProofRules.p_obs_contradiction apply blast
  apply clarify
  apply linarith
  apply (metis (no_types, lifting) less_numeral_extra(3) )
  using pval_val apply auto[1]
  apply clarify
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (intro conjI impI)
  apply (metis getVWNC_var leD pval_val)
  apply (metis OpSem_ProofRules.ext_write_other_pres_d_obs)
  apply clarify
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (intro conjI impI)
  apply (metis getVWNC_var leD pval_val)
  apply (metis OpSem_ProofRules.ext_write_other_pres_d_obs)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply linarith
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply linarith
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply linarith
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply clarify
  apply blast
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (intro conjI impI)
  apply (metis getVWNC_var leD pval_val)
  apply (metis OpSem_ProofRules.ext_write_other_pres_d_obs)
  apply clarify
  apply blast
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (meson not_less not_pobs_contradiction)
  apply (meson not_less not_pobs_contradiction)
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  by simp

(*(simp add: Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff )?)*)


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory Lookups_D
imports
  "DSpec.Syscall_D"
  "Lib.OptionMonadND"
begin

type_synonym 'a lookup = "cdl_state \<Rightarrow> 'a option"

definition
  opt_cnode :: "cdl_object_id \<Rightarrow> cdl_cnode lookup"
where
  "opt_cnode p \<equiv> DO
      t \<leftarrow> \<lambda>s. cdl_objects s p;
      case t of
        CNode cnode \<Rightarrow> oreturn cnode
      | _ \<Rightarrow> ofail
   OD"

function resolve_cap ::
  "cdl_cap \<Rightarrow> cdl_cptr \<Rightarrow> nat \<Rightarrow> (cdl_fault_error + cdl_cap_ref \<times> nat) lookup"
where
  "resolve_cap cnode_cap cap_ptr remaining_size =
  (if is_cnode_cap cnode_cap
  then DO
    \<comment> \<open>Fetch the next level CNode.\<close>
    cnode \<leftarrow> opt_cnode $ cap_object cnode_cap;
    radix_size \<leftarrow> oreturn $ cdl_cnode_size_bits cnode;
    guard_size \<leftarrow> oreturn $ cap_guard_size cnode_cap;
    cap_guard  \<leftarrow> oreturn $ cap_guard cnode_cap;
    level_size \<leftarrow> oreturn (radix_size + guard_size);
    oassert (level_size \<noteq> 0);

    \<comment> \<open>Ensure the guard matches up.\<close>
    guard \<leftarrow> oreturn $ (cap_ptr >> (remaining_size-guard_size)) && (mask guard_size);
    if \<not>(guard_size \<le> remaining_size \<and> guard = cap_guard) \<or>
       level_size > remaining_size
    then othrow FaultError
    else DO
      \<comment> \<open>Find the next slot.\<close>
      offset \<leftarrow> oreturn $ (cap_ptr >> (remaining_size-level_size)) && (mask radix_size);
      slot \<leftarrow> oreturn (cap_object cnode_cap, unat offset);
      size_left \<leftarrow> oreturn (remaining_size - level_size);
      if size_left = 0 then
        oreturnOk (slot, 0)
      else DO
        next_cap \<leftarrow> opt_cap slot;
        if is_cnode_cap next_cap then
          resolve_cap next_cap cap_ptr size_left
        else
          oreturnOk (slot, size_left)
      OD
    OD
  OD
  else othrow FaultError)"
  by auto

termination
  by (relation "measure (\<lambda>(a,b,c). c)") auto

declare resolve_cap.simps [simp del]

declare resolve_address_bits.simps [simp del]

lemma throwError_FaultError [simp]:
  "throwError FaultError = throw"
  apply (cases "undefined::cdl_fault_error")
  apply simp
  done

lemma gets_the_get_cnode:
  "gets_the (opt_cnode r) = get_cnode r"
  apply (simp add: get_cnode_def opt_cnode_def)
  apply (rule bind_cong, rule refl)
  apply (clarsimp split: cdl_object.splits)
  done

lemma gets_the_resolve_cap:
  "gets_the (resolve_cap cnode_cap cap_ptr remaining_size) =
   resolve_address_bits cnode_cap cap_ptr remaining_size"
  apply (induct cnode_cap cap_ptr remaining_size rule: resolve_cap.induct [simplified])
  apply (subst resolve_cap.simps)
  apply (subst resolve_address_bits.simps)
  apply (clarsimp simp: unlessE_def liftE_bindE assertE_liftE gets_the_get_cnode)
  apply (rule bind_cong, rule refl)
  apply (rule bind_apply_cong, rule refl)
  apply (clarsimp simp: liftE_bindE)
  apply (rule bind_apply_cong, rule refl)
  apply (clarsimp simp: in_monad gets_the_get_cnode [symmetric])
  done

definition resolve_address_bits' ::
  "cdl_cap \<Rightarrow> cdl_cptr \<Rightarrow> nat \<Rightarrow> (cdl_cap_ref \<times> nat) lookup"
where
  "resolve_address_bits' cap cptr n \<equiv> odrop $  resolve_cap cap cptr n"

definition
  lookup_slot' :: "cdl_object_id \<Rightarrow> cdl_cptr \<Rightarrow> cdl_cap_ref lookup"
where
  "lookup_slot' thread cptr \<equiv>
    DO
      cspace_root \<leftarrow> opt_cap (thread, tcb_cspace_slot);
      (slot, _) \<leftarrow> resolve_address_bits' cspace_root cptr word_bits;
      oreturn slot
    OD"

definition
  lookup_cap' :: "cdl_object_id \<Rightarrow> cdl_cptr \<Rightarrow> cdl_cap lookup"
where
  "lookup_cap' thread cptr \<equiv>
    DO
      slot \<leftarrow> lookup_slot' thread cptr;
      opt_cap slot
    OD"

definition
  lookup_cap_and_slot' :: "cdl_object_id \<Rightarrow> cdl_cptr \<Rightarrow> (cdl_cap \<times> cdl_cap_ref) lookup"
where
  "lookup_cap_and_slot' thread cptr \<equiv>
    DO
      slot \<leftarrow> lookup_slot' thread cptr;
      cap \<leftarrow> opt_cap slot;
      oreturn (cap, slot)
    OD"

definition
  lookup_object :: "cdl_object_id \<Rightarrow> cdl_cptr \<Rightarrow> cdl_object_id lookup"
where
  "lookup_object thread cptr \<equiv>
    DO
      cap \<leftarrow> lookup_cap' thread cptr;
      oreturn $ cap_object cap
    OD"

definition
  lookup_extra_caps' :: "cdl_object_id \<Rightarrow> cdl_cptr list \<Rightarrow> (cdl_cap \<times> cdl_cap_ref) list lookup"
where
  "lookup_extra_caps' thread cptrs \<equiv>
     omap (\<lambda>cptr. lookup_cap_and_slot' thread cptr) cptrs"

end


theory "FMap-Utils"
imports "FMap-Nominal-HOLCF" "HOLCF-Fix-Join-Nominal" "DistinctVars"
begin

default_sort type

text {* Lemmas relating @{theory FMap} to the other auxiliary theories. *}

lemma fdom_fix_join_compat:
  assumes "fix_on_cond S (bottom_of S) (\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>')"
  assumes "\<rho>' \<in> fix_join_compat \<rho> F"
  shows "fdom \<rho>' = fdom \<rho>"
  by (metis assms(2) bottom_of_fjc fmap_below_dom subpcpo.bottom_of_minimal subpcpo_fjc to_bot_minimal)

lemma sharp_star_Env': "atom ` heapVars \<Gamma> \<sharp>* (\<rho> :: 'var::{cont_pt,at_base} f\<rightharpoonup> 'value::{pure_cpo,Nonempty_Meet_cpo,pcpo}) \<longleftrightarrow> heapVars \<Gamma> \<inter> fdom \<rho> = {}"
  by(induct \<Gamma>, auto simp add: fresh_star_def sharp_Env)
end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "64-Bit Machine Word Setup"

theory Machine_Word_64
imports Machine_Word_64_Basics More_Word Bit_Shifts_Infix_Syntax Rsplit
begin

context
  includes bit_operations_syntax
begin

type_synonym machine_word = \<open>machine_word_len word\<close>

lemma word_bits_len_of:
  \<open>LENGTH(machine_word_len) = word_bits\<close>
  by (simp add: word_bits_conv)

lemma word_bits_size:
  "size (w :: machine_word) = word_bits"
  by (simp add: word_bits_def word_size)

lemma word_bits_word_size_conv:
  \<open>word_bits = word_size * 8\<close>
  by (simp add: word_bits_def word_size_def)

lemma word_size_word_size_bits:
  \<open>word_size = (2 :: 'a :: semiring_1) ^ word_size_bits\<close>
  by (simp add: word_size_def word_size_bits_def)

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: machine_word)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: machine_word)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma bool_mask [simp]:
  \<open>0 < x AND 1 \<longleftrightarrow> x AND 1 = 1\<close> for x :: machine_word
  by (rule bool_mask') auto

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: machine_word)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: machine_word. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma le_step_down_word_3:
  fixes x :: machine_word
  shows "\<lbrakk>x \<le> y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (fact le_step_down_word_2)

lemma shiftr_1:
  "(x::machine_word) >> 1 = 0 \<Longrightarrow> x < 2"
  apply transfer
  apply (simp add: take_bit_drop_bit)
  apply (simp add: drop_bit_Suc)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size :: machine_word)) = 2 ^ (min sz word_bits - word_size_bits)"
  by (simp add: word_size_word_size_bits unat_drop_bit_eq unat_mask_eq drop_bit_mask_eq Suc_mask_eq_exp
    flip: drop_bit_eq_div word_bits_conv)

lemma ucast_not_helper:
  fixes a::"8 word"
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::machine_word)"
proof
  assume "ucast a = (0xFF::machine_word)"
  also
  have "(0xFF::machine_word) = ucast (0xFF::8 word)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma unat_less_2p_word_bits:
  "unat (x :: machine_word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma unat_less_word_bits:
  fixes y :: machine_word
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemma unat_mask_2_less_4:
  "unat (p AND mask 2 :: machine_word) < 4"
  by (rule unat_less_helper) (simp only: take_bit_eq_mod word_mod_less_divisor flip: take_bit_eq_mask, simp add: word_mod_less_divisor)

lemma unat_mult_simple:
  \<open>unat (x * y) = unat x * unat y\<close>
    if \<open>unat x * unat y < 2 ^ LENGTH(machine_word_len)\<close>
    for x y :: machine_word
  using that by (simp flip: unat_mult_lem)

lemma upto_2_helper:
  "{0..<2 :: machine_word} = {0, 1}"
  by (safe; simp) unat_arith

lemma word_ge_min:
  \<open>- (2 ^ (word_bits - 1)) \<le> sint x\<close> for x :: machine_word
  using sint_ge [of x] by (simp add: word_bits_def)

lemma word_rsplit_0:
  "word_rsplit (0 :: machine_word) = replicate (word_bits div 8) (0 :: 8 word)"
  by (simp add: word_rsplit_def bin_rsplit_def word_bits_def word_size_def Cons_replicate_eq)

lemma x_less_2_0_1:
  fixes x :: machine_word
  shows "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

end

end


(*  Title:      HOL/Auth/Guard/Guard_Yahalom.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section\<open>Yahalom Protocol\<close>

theory Guard_Yahalom imports "../Shared" Guard_Shared begin

subsection\<open>messages used in the protocol\<close>

abbreviation (input)
  ya1 :: "agent => agent => nat => event" where
  "ya1 A B NA == Says A B \<lbrace>Agent A, Nonce NA\<rbrace>"

abbreviation (input)
  ya1' :: "agent => agent => agent => nat => event" where
  "ya1' A' A B NA == Says A' B \<lbrace>Agent A, Nonce NA\<rbrace>"

abbreviation (input)
  ya2 :: "agent => agent => nat => nat => event" where
  "ya2 A B NA NB == Says B Server \<lbrace>Agent B, Ciph B \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>"

abbreviation (input)
  ya2' :: "agent => agent => agent => nat => nat => event" where
  "ya2' B' A B NA NB == Says B' Server \<lbrace>Agent B, Ciph B \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>\<rbrace>"

abbreviation (input)
  ya3 :: "agent => agent => nat => nat => key => event" where
  "ya3 A B NA NB K ==
    Says Server A \<lbrace>Ciph A \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>,
                    Ciph B \<lbrace>Agent A, Key K\<rbrace>\<rbrace>"

abbreviation (input)
  ya3':: "agent => msg => agent => agent => nat => nat => key => event" where
  "ya3' S Y A B NA NB K ==
    Says S A \<lbrace>Ciph A \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>, Y\<rbrace>"

abbreviation (input)
  ya4 :: "agent => agent => nat => nat => msg => event" where
  "ya4 A B K NB Y == Says A B \<lbrace>Y, Crypt K (Nonce NB)\<rbrace>"

abbreviation (input)
  ya4' :: "agent => agent => nat => nat => msg => event" where
  "ya4' A' B K NB Y == Says A' B \<lbrace>Y, Crypt K (Nonce NB)\<rbrace>"

subsection\<open>definition of the protocol\<close>

inductive_set ya :: "event list set"
where

  Nil: "[]:ya"

| Fake: "[| evs:ya; X:synth (analz (spies evs)) |] ==> Says Spy B X # evs:ya"

| YA1: "[| evs1:ya; Nonce NA ~:used evs1 |] ==> ya1 A B NA # evs1:ya"

| YA2: "[| evs2:ya; ya1' A' A B NA:set evs2; Nonce NB ~:used evs2 |]
  ==> ya2 A B NA NB # evs2:ya"

| YA3: "[| evs3:ya; ya2' B' A B NA NB:set evs3; Key K ~:used evs3 |]
  ==> ya3 A B NA NB K # evs3:ya"

| YA4: "[| evs4:ya; ya1 A B NA:set evs4; ya3' S Y A B NA NB K:set evs4 |]
  ==> ya4 A B K NB Y # evs4:ya"

subsection\<open>declarations for tactics\<close>

declare knows_Spy_partsEs [elim]
declare Fake_parts_insert [THEN subsetD, dest]
declare initState.simps [simp del]

subsection\<open>general properties of ya\<close>

lemma ya_has_no_Gets: "evs:ya ==> ALL A X. Gets A X ~:set evs"
by (erule ya.induct, auto)

lemma ya_is_Gets_correct [iff]: "Gets_correct ya"
by (auto simp: Gets_correct_def dest: ya_has_no_Gets)

lemma ya_is_one_step [iff]: "one_step ya"
by (unfold one_step_def, clarify, ind_cases "ev#evs:ya" for ev evs, auto)

lemma ya_has_only_Says' [rule_format]: "evs:ya ==>
ev:set evs --> (EX A B X. ev=Says A B X)"
by (erule ya.induct, auto)

lemma ya_has_only_Says [iff]: "has_only_Says ya"
by (auto simp: has_only_Says_def dest: ya_has_only_Says')

lemma ya_is_regular [iff]: "regular ya"
apply (simp only: regular_def, clarify)
apply (erule ya.induct, simp_all add: initState.simps knows.simps)
by (auto dest: parts_sub)

subsection\<open>guardedness of KAB\<close>

lemma Guard_KAB [rule_format]: "[| evs:ya; A ~:bad; B ~:bad |] ==>
ya3 A B NA NB K:set evs --> GuardK K {shrK A,shrK B} (spies evs)"
apply (erule ya.induct)
(* Nil *)
apply simp_all
(* Fake *)
apply (clarify, erule in_synth_GuardK, erule GuardK_analz, simp)
(* YA1 *)
(* YA2 *)
apply safe
apply (blast dest: Says_imp_spies)
(* YA3 *)
apply blast
apply (drule_tac A=Server in Key_neq, simp+, rule No_Key, simp)
apply (drule_tac A=Server in Key_neq, simp+, rule No_Key, simp)
(* YA4 *)
apply (blast dest: Says_imp_spies in_GuardK_kparts)
by blast

subsection\<open>session keys are not symmetric keys\<close>

lemma KAB_isnt_shrK [rule_format]: "evs:ya ==>
ya3 A B NA NB K:set evs --> K ~:range shrK"
by (erule ya.induct, auto)

lemma ya3_shrK: "evs:ya ==> ya3 A B NA NB (shrK C) ~:set evs"
by (blast dest: KAB_isnt_shrK)

subsection\<open>ya2' implies ya1'\<close>

lemma ya2'_parts_imp_ya1'_parts [rule_format]:
     "[| evs:ya; B ~:bad |] ==>
      Ciph B \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>:parts (spies evs) -->
      \<lbrace>Agent A, Nonce NA\<rbrace>:spies evs"
by (erule ya.induct, auto dest: Says_imp_spies intro: parts_parts)

lemma ya2'_imp_ya1'_parts: "[| ya2' B' A B NA NB:set evs; evs:ya; B ~:bad |]
==> \<lbrace>Agent A, Nonce NA\<rbrace>:spies evs"
by (blast dest: Says_imp_spies ya2'_parts_imp_ya1'_parts)

subsection\<open>uniqueness of NB\<close>

lemma NB_is_uniq_in_ya2'_parts [rule_format]: "[| evs:ya; B ~:bad; B' ~:bad |] ==>
Ciph B \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>:parts (spies evs) -->
Ciph B' \<lbrace>Agent A', Nonce NA', Nonce NB\<rbrace>:parts (spies evs) -->
A=A' & B=B' & NA=NA'"
apply (erule ya.induct, simp_all, clarify)
apply (drule Crypt_synth_insert, simp+)
apply (drule Crypt_synth_insert, simp+, safe)
apply (drule not_used_parts_false, simp+)+
by (drule Says_not_parts, simp+)+

lemma NB_is_uniq_in_ya2': "[| ya2' C A B NA NB:set evs;
ya2' C' A' B' NA' NB:set evs; evs:ya; B ~:bad; B' ~:bad |]
==> A=A' & B=B' & NA=NA'"
by (drule NB_is_uniq_in_ya2'_parts, auto dest: Says_imp_spies)

subsection\<open>ya3' implies ya2'\<close>

lemma ya3'_parts_imp_ya2'_parts [rule_format]: "[| evs:ya; A ~:bad |] ==>
Ciph A \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>:parts (spies evs)
--> Ciph B \<lbrace>Agent A, Nonce NA, Nonce NB\<rbrace>:parts (spies evs)"
apply (erule ya.induct, simp_all)
apply (clarify, drule Crypt_synth_insert, simp+)
apply (blast intro: parts_sub, blast)
by (auto dest: Says_imp_spies parts_parts)

lemma ya3'_parts_imp_ya2' [rule_format]: "[| evs:ya; A ~:bad |] ==>
Ciph A \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>:parts (spies evs)
--> (EX B'. ya2' B' A B NA NB:set evs)"
apply (erule ya.induct, simp_all, safe)
apply (drule Crypt_synth_insert, simp+)
apply (drule Crypt_synth_insert, simp+, blast)
apply blast
apply blast
by (auto dest: Says_imp_spies2 parts_parts)

lemma ya3'_imp_ya2': "[| ya3' S Y A B NA NB K:set evs; evs:ya; A ~:bad |]
==> (EX B'. ya2' B' A B NA NB:set evs)"
by (drule ya3'_parts_imp_ya2', auto dest: Says_imp_spies)

subsection\<open>ya3' implies ya3\<close>

lemma ya3'_parts_imp_ya3 [rule_format]: "[| evs:ya; A ~:bad |] ==>
Ciph A \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>:parts(spies evs)
--> ya3 A B NA NB K:set evs"
apply (erule ya.induct, simp_all, safe)
apply (drule Crypt_synth_insert, simp+)
by (blast dest: Says_imp_spies2 parts_parts)

lemma ya3'_imp_ya3: "[| ya3' S Y A B NA NB K:set evs; evs:ya; A ~:bad |]
==> ya3 A B NA NB K:set evs"
by (blast dest: Says_imp_spies ya3'_parts_imp_ya3)

subsection\<open>guardedness of NB\<close>

definition ya_keys :: "agent => agent => nat => nat => event list => key set" where
"ya_keys A B NA NB evs == {shrK A,shrK B} Un {K. ya3 A B NA NB K:set evs}"

lemma Guard_NB [rule_format]: "[| evs:ya; A ~:bad; B ~:bad |] ==>
ya2 A B NA NB:set evs --> Guard NB (ya_keys A B NA NB evs) (spies evs)"
apply (erule ya.induct)
(* Nil *)
apply (simp_all add: ya_keys_def)
(* Fake *)
apply safe
apply (erule in_synth_Guard, erule Guard_analz, simp, clarify)
apply (frule_tac B=B in Guard_KAB, simp+)
apply (drule_tac p=ya in GuardK_Key_analz, simp+)
apply (blast dest: KAB_isnt_shrK, simp)
(* YA1 *)
apply (drule_tac n=NB in Nonce_neq, simp+, rule No_Nonce, simp)
(* YA2 *)
apply blast
apply (drule Says_imp_spies)
apply (drule_tac n=NB in Nonce_neq, simp+)
apply (drule_tac n'=NAa in in_Guard_kparts_neq, simp+)
apply (rule No_Nonce, simp)
(* YA3 *)
apply (rule Guard_extand, simp, blast)
apply (case_tac "NAa=NB", clarify)
apply (frule Says_imp_spies)
apply (frule in_Guard_kparts_Crypt, simp+)
apply (frule_tac A=A and B=B and NA=NA and NB=NB and C=Ba in ya3_shrK, simp)
apply (drule ya2'_imp_ya1'_parts, simp, blast, blast)
apply (case_tac "NBa=NB", clarify)
apply (frule Says_imp_spies)
apply (frule in_Guard_kparts_Crypt, simp+)
apply (frule_tac A=A and B=B and NA=NA and NB=NB and C=Ba in ya3_shrK, simp)
apply (drule NB_is_uniq_in_ya2', simp+, blast, simp+)
apply (simp add: No_Nonce, blast)
(* YA4 *)
apply (blast dest: Says_imp_spies)
apply (case_tac "NBa=NB", clarify)
apply (frule_tac A=S in Says_imp_spies)
apply (frule in_Guard_kparts_Crypt, simp+)
apply (blast dest: Says_imp_spies)
apply (case_tac "NBa=NB", clarify)
apply (frule_tac A=S in Says_imp_spies)
apply (frule in_Guard_kparts_Crypt, simp+, blast, simp+)
apply (frule_tac A=A and B=B and NA=NA and NB=NB and C=Aa in ya3_shrK, simp)
apply (frule ya3'_imp_ya2', simp+, blast, clarify)
apply (frule_tac A=B' in Says_imp_spies)
apply (rotate_tac -1, frule in_Guard_kparts_Crypt, simp+)
apply (frule_tac A=A and B=B and NA=NA and NB=NB and C=Ba in ya3_shrK, simp)
apply (drule NB_is_uniq_in_ya2', simp+, blast, clarify)
apply (drule ya3'_imp_ya3, simp+)
apply (simp add: Guard_Nonce)
apply (simp add: No_Nonce)
done

end


theory Memory_Allocation_Security
imports Memory_Allocation_Model Memory_Allocation_Invariant SK_SecurityModel
begin

subsection \<open>Memory Execution Model\<close>

type_synonym partition_id = nat
type_synonym partition_name = string
datatype Partition_Conf = PartConf partition_id partition_name
type_synonym Partitions = "partition_id \<rightharpoonup> Partition_Conf"

type_synonym domain_id = nat
type_synonym Mem_Add = "ID set"
type_synonym Partition_Mem = "partition_id \<rightharpoonup> Mem_Add"

record Sys_Config = partconf :: Partitions
                    scheduler :: domain_id

record State = current :: domain_id
               partitionmem :: Partition_Mem
               mempools :: "Pool set"
               memids :: "ID set"

datatype Hypercall = Buddy_Memory_Alloc Pool nat |
                     Buddy_Memory_Free Pool Block
datatype System_Event = Schedule
datatype Event = hyperc Hypercall | sys System_Event

primrec get_partname_by_type :: "Partition_Conf \<Rightarrow> partition_name"
  where "get_partname_by_type (PartConf _ pn) = pn"

primrec get_partid_by_type :: "Partition_Conf \<Rightarrow> partition_id"
  where "get_partid_by_type (PartConf pid _) = pid"

definition is_a_partition :: "Sys_Config \<Rightarrow> domain_id \<Rightarrow> bool"
  where "is_a_partition sc nid \<equiv> (partconf sc) nid \<noteq> None"

definition is_a_scheduler :: "Sys_Config \<Rightarrow> domain_id \<Rightarrow> bool"
  where "is_a_scheduler sc nid \<equiv> (scheduler sc) = nid"

definition get_partconf_byid :: "Sys_Config \<Rightarrow> partition_id \<Rightarrow> Partition_Conf option"
  where "get_partconf_byid sc pid \<equiv> (partconf sc) pid"

definition get_partmem_byid :: "State \<Rightarrow> partition_id \<Rightarrow> Mem_Add option"
  where "get_partmem_byid s pid \<equiv> (partitionmem s) pid"

definition alloc_memory :: "Sys_Config \<Rightarrow> State \<Rightarrow> Pool \<Rightarrow> nat \<Rightarrow> State"
  where "alloc_memory sc s po lv \<equiv>
           (if get_partconf_byid sc (current s) \<noteq> None then
               (let partmem = get_partmem_byid s (current s);
                    re = alloc (zerolevelblocks po) lv (memids s) in
                    (if fst (snd (snd re)) = True then
                        s\<lparr>partitionmem := (partitionmem s)(current s := Some (the partmem \<union> (snd (snd (snd re))))),
                          mempools := (mempools s - {po}) \<union> {po\<lparr>zerolevelblocks := fst re\<rparr>},
                          memids := fst (snd re)\<rparr>
                     else s))
            else s)"

definition free_memory :: "Sys_Config \<Rightarrow> State \<Rightarrow> Pool \<Rightarrow> Block \<Rightarrow> State"
  where "free_memory sc s po b \<equiv>
           let partmem = get_partmem_byid s (current s) in
             (if get_partconf_byid sc (current s) \<noteq> None \<and> partmem \<noteq> None then
                 (let re = free (zerolevelblocks po) b (memids s) in
                      (if snd (snd re) = True then
                          s\<lparr>partitionmem := (partitionmem s)(current s := Some (the partmem - {snd (L b)}  )),
                            mempools := (mempools s - {po}) \<union> {po\<lparr>zerolevelblocks := fst re\<rparr>},
                            memids := fst (snd re)\<rparr>
                       else s))
              else s)"

definition schedule :: "Sys_Config \<Rightarrow> State \<Rightarrow> State set" where
  "schedule sc s \<equiv> {s\<lparr>current:= SOME p. p\<in>{x. (partconf sc) x \<noteq> None}\<rparr>}"

definition sys_config_witness :: Sys_Config
  where "sys_config_witness \<equiv> \<lparr>partconf = Map.empty,
                               scheduler = 0\<rparr>"

consts sysconf :: "Sys_Config"
specification(sysconf)
  part_id_conf: "\<forall>p. (partconf sysconf) p \<noteq> None \<longrightarrow> get_partid_by_type (the ((partconf sysconf) p)) = p"
  part_not_sch: "(partconf sysconf) x \<noteq> None \<longrightarrow> x \<noteq> scheduler sysconf"
  sch_not_part: "scheduler sysconf = x \<longrightarrow> (partconf sysconf) x = None"
  by (metis Sys_Config.select_convs(1) sys_config_witness_def)

definition state_witness :: State
  where "state_witness \<equiv> \<lparr>current = (SOME x. (partconf sysconf) x \<noteq> None),
                          partitionmem = (\<lambda> p. (case ((partconf sysconf) p) of None \<Rightarrow> None
                                                                             | Some (PartConf _ _) \<Rightarrow> Some {})),
                          mempools = {},
                          memids = {}\<rparr>"

consts s0t :: State
specification(s0t)
  s0t_init: "s0t = state_witness"
  by simp

primrec event_enabled :: "State \<Rightarrow> Event \<Rightarrow> bool"
  where "event_enabled s (hyperc h) = (is_a_partition sysconf (current s))" |
        "event_enabled s (sys h) =  (case h of Schedule \<Rightarrow> True)"

definition exec_event :: "Event \<Rightarrow> (State \<times> State) set"
  where "exec_event e = {(s, s'). s' \<in> (if event_enabled s e then
                                           (case e of hyperc (Buddy_Memory_Alloc po lv) \<Rightarrow> {(alloc_memory sysconf s po lv)} |
                                                      hyperc (Buddy_Memory_Free po b) \<Rightarrow> {(free_memory sysconf s po b)} |
                                                      sys Schedule \<Rightarrow> schedule sysconf s)
                                        else {s})}"

primrec domain_of_event :: "State \<Rightarrow> Event \<Rightarrow> domain_id option"
where "domain_of_event s (hyperc h) = Some (current s)" |
      "domain_of_event s (sys h) = Some (scheduler sysconf)"

definition interference1 :: "domain_id \<Rightarrow> domain_id \<Rightarrow> bool" ("(_ \<leadsto> _)")
  where "interference1 d1 d2 \<equiv>
            if d1 = d2 then True
            else if is_a_scheduler sysconf d1 then True
            else False"

definition non_interference1 :: "domain_id \<Rightarrow> domain_id \<Rightarrow> bool" ("(_ \<setminus>\<leadsto> _)")
      where "(u \<setminus>\<leadsto>  v) \<equiv> \<not> (u \<leadsto> v)"

declare non_interference1_def [cong] and interference1_def [cong] and domain_of_event_def[cong] and
       event_enabled_def[cong] and is_a_partition_def[cong] and is_a_scheduler_def[cong]

lemma nintf_neq: "u \<setminus>\<leadsto>  v \<Longrightarrow> u \<noteq> v"  by auto

lemma nintf_reflx: "interference1 u u" by auto

definition vpeq_part :: "State \<Rightarrow> partition_id \<Rightarrow> State \<Rightarrow> bool"
  where "vpeq_part s d t \<equiv> (partitionmem s) d = (partitionmem t) d"

definition vpeq_sched :: "State \<Rightarrow> domain_id \<Rightarrow> State \<Rightarrow> bool"
  where "vpeq_sched s d t \<equiv> current s = current t"

definition vpeq1  :: "State \<Rightarrow> domain_id \<Rightarrow> State \<Rightarrow> bool" ("(_ \<sim> _ \<sim> _)")
  where "vpeq1 s d t \<equiv>
         (if d = scheduler sysconf then
            (vpeq_sched s d t)
          else if is_a_partition sysconf d then
            (vpeq_part s d t)
          else True)"

declare vpeq_part_def [cong] and vpeq_sched_def[cong] and vpeq1_def[cong]

lemma vpeq_part_transitive_lemma : "\<forall> s t r d. vpeq_part s d t \<and> vpeq_part t d r \<longrightarrow> vpeq_part s d r"
  by auto

lemma vpeq_part_symmetric_lemma:"\<forall> s t d. vpeq_part s d t \<longrightarrow> vpeq_part t d s"
  by auto

lemma vpeq_part_reflexive_lemma:"\<forall> s d. vpeq_part s d s"
  by auto

lemma vpeq_scheduler_transitive_lemma : "\<forall> s t r d. vpeq_sched s d t \<and> vpeq_sched t d r \<longrightarrow> vpeq_sched s d r"
 by simp

lemma vpeq_scheduler_symmetric_lemma:"\<forall> s t d. vpeq_sched s d t \<longrightarrow> vpeq_sched t d s"
  by simp

lemma vpeq_scheduler_reflexive_lemma:"\<forall> s d. vpeq_sched s d s"
  by simp

lemma vpeq1_transitive_lemma : "\<forall> s t r d. (vpeq1 s d t) \<and> (vpeq1 t d r) \<longrightarrow> (vpeq1 s d r)"
  by auto

lemma vpeq1_symmetric_lemma : "\<forall> s t d. (vpeq1 s d t) \<longrightarrow> (vpeq1 t d s)"
  by auto

lemma vpeq1_reflexive_lemma : "\<forall> s d. (vpeq1 s d s)"
  by auto

lemma sched_current_lemma : "\<forall>s t a. vpeq1 s (scheduler sysconf) t \<longrightarrow> (domain_of_event s a) = (domain_of_event t a)"
  by (metis (no_types) Event.exhaust domain_of_event.simps(1) domain_of_event.simps(2) vpeq1_def vpeq_sched_def)

lemma schedeler_intf_all_help : "\<forall>d. interference1 (scheduler sysconf) d"
  by (meson interference1_def is_a_scheduler_def)

lemma no_intf_sched_help : "\<forall>d. interference1 d (scheduler sysconf) \<longrightarrow> d = (scheduler sysconf)"
  by (simp add: interference1_def is_a_scheduler_def)

lemma reachable_top: "\<forall>s a. (SM.reachable0 s0t exec_event) s \<longrightarrow> (\<exists>s'. (s, s') \<in> exec_event a)"
  proof -
  {
    fix s a
    assume p0: "(SM.reachable0 s0t exec_event) s"
    have "\<exists>s'. (s, s') \<in> exec_event a"
      proof(induct a)
        case (hyperc x) show ?case
          apply (induct x)
          by (simp add:exec_event_def)+
        next
        case (sys x) then show ?case
          apply (induct x)
          by (simp add:exec_event_def schedule_def)+
      qed
  }
  then show ?thesis by auto
  qed

interpretation SM_enabled
    s0t exec_event domain_of_event "scheduler sysconf" vpeq1 interference1
  using vpeq1_transitive_lemma vpeq1_symmetric_lemma vpeq1_reflexive_lemma sched_current_lemma
        schedeler_intf_all_help no_intf_sched_help reachable_top nintf_reflx
        SM.intro[of vpeq1 "scheduler sysconf" domain_of_event interference1]
        SM_enabled_axioms.intro [of s0t exec_event]
        SM_enabled.intro[of domain_of_event "scheduler sysconf" vpeq1 interference1 s0t exec_event] by blast

subsection \<open>Some lemmas of security proofs\<close>

lemma sche_imp_not_part:
  "is_a_scheduler sysconf d \<Longrightarrow> \<not> (is_a_partition sysconf d)"
  using sch_not_part by auto

lemma part_imp_not_sch:
  "is_a_partition sysconf d \<Longrightarrow> \<not> (is_a_scheduler sysconf d)"
  by (auto simp add: sch_not_part)

subsection \<open>proving "allocate memory" satisfying the "local respect" property\<close>
lemma alloc_memory_notchg_current:
  "\<lbrakk>is_a_partition sysconf (current s);
  s' = alloc_memory sysconf s po lv\<rbrakk>
  \<Longrightarrow> current s = current s'"
  by(clarsimp simp: alloc_memory_def get_partconf_byid_def get_partmem_byid_def Let_def)

lemma alloc_memory_sm_sche:
  "\<lbrakk>is_a_partition sysconf (current s);
  s' = alloc_memory sysconf s po lv\<rbrakk>
  \<Longrightarrow> (s\<sim>(scheduler sysconf)\<sim>s')"
  using alloc_memory_notchg_current part_imp_not_sch
  by(meson vpeq1_def vpeq_sched_def)

lemma alloc_memory_notchg_partstate:
  "\<lbrakk>is_a_partition sysconf (current s);
  is_a_partition sysconf d;
  d \<noteq> current s;
  s' = alloc_memory sysconf s po lv\<rbrakk>
  \<Longrightarrow> (partitionmem s) d = (partitionmem s') d"
  by(clarsimp simp: alloc_memory_def get_partconf_byid_def get_partmem_byid_def Let_def)

lemma alloc_memory_sm_nitfpart:
  "\<lbrakk>reachable0 s;
  is_a_partition sysconf (current s);
  is_a_partition sysconf d;
  ((current s) \<setminus>\<leadsto> d);
  s' = alloc_memory sysconf s po lv\<rbrakk>
  \<Longrightarrow> (s \<sim> d \<sim> s')"
  using sche_imp_not_part
  apply(clarsimp cong del: is_a_partition_def interference1_def non_interference1_def)
  using nintf_neq alloc_memory_notchg_partstate by blast

lemma alloc_memory_presrv_lcrsp:
  assumes p0:"reachable0 s"
    and   p1:"is_a_partition sysconf (current s)"
    and   p2:"(current s) \<setminus>\<leadsto> d"
    and   p3:"s' = alloc_memory sysconf s po lv"
  shows   "s \<sim> d \<sim> s'"
proof(cases "is_a_scheduler sysconf d")
  assume a0:"is_a_scheduler sysconf d"
  then show ?thesis using is_a_scheduler_def alloc_memory_sm_sche[OF p1 p3] by auto
next
  assume a1:"\<not> is_a_scheduler sysconf d"
  show ?thesis
  proof(cases "is_a_partition sysconf d")
    assume b0:"is_a_partition sysconf d"
    show ?thesis using b0 alloc_memory_sm_nitfpart p0 p1 p2 p3 by blast
  next
    assume b1:"\<not> is_a_partition sysconf d"
    show ?thesis using a1 b1 by auto
  qed
qed

lemma alloc_memory_presrv_lcrsp_e:
  "local_respect_e (hyperc (Buddy_Memory_Alloc po lv))"
  using alloc_memory_presrv_lcrsp exec_event_def
        prod.simps(2) vpeq_reflexive_lemma
  by(auto cong del: vpeq1_def)

subsection \<open>proving "free memory" satisfying the "local respect" property\<close>
lemma free_memory_notchg_current:
  "\<lbrakk>is_a_partition sysconf (current s);
  s' = free_memory sysconf s po b\<rbrakk>
  \<Longrightarrow> current s = current s'"
  by(clarsimp simp: free_memory_def get_partconf_byid_def get_partmem_byid_def Let_def)

lemma free_memory_sm_sche:
  "\<lbrakk>is_a_partition sysconf (current s);
  s' = free_memory sysconf s po b\<rbrakk>
  \<Longrightarrow> (s\<sim>(scheduler sysconf)\<sim>s')"
  using free_memory_notchg_current part_imp_not_sch
  by(meson vpeq1_def vpeq_sched_def)

lemma free_memory_notchg_partstate:
  "\<lbrakk>is_a_partition sysconf (current s);
  is_a_partition sysconf d;
  d \<noteq> current s;
  s' = free_memory sysconf s po b\<rbrakk>
  \<Longrightarrow> (partitionmem s) d = (partitionmem s') d"
  by(clarsimp simp: free_memory_def get_partconf_byid_def get_partmem_byid_def Let_def)

lemma free_memory_sm_nitfpart:
  "\<lbrakk>reachable0 s;
  is_a_partition sysconf (current s);
  is_a_partition sysconf d;
  ((current s) \<setminus>\<leadsto> d);
  s' = free_memory sysconf s po b\<rbrakk>
  \<Longrightarrow> (s \<sim> d \<sim> s')"
  using sche_imp_not_part
  apply(clarsimp cong del: is_a_partition_def interference1_def non_interference1_def)
  using nintf_neq free_memory_notchg_partstate by blast

lemma free_memory_presrv_lcrsp:
  assumes p0:"reachable0 s"
    and   p1:"is_a_partition sysconf (current s)"
    and   p2:"(current s) \<setminus>\<leadsto> d"
    and   p3:"s' = free_memory sysconf s po b"
  shows   "s \<sim> d \<sim> s'"
proof(cases "is_a_scheduler sysconf d")
  assume a0:"is_a_scheduler sysconf d"
  then show ?thesis using is_a_scheduler_def free_memory_sm_sche[OF p1 p3] by auto
next
  assume a1:"\<not> is_a_scheduler sysconf d"
  show ?thesis
  proof(cases "is_a_partition sysconf d")
    assume b0:"is_a_partition sysconf d"
    show ?thesis using b0 free_memory_sm_nitfpart p0 p1 p2 p3 by blast
  next
    assume b1:"\<not> is_a_partition sysconf d"
    show ?thesis using a1 b1 by auto
  qed
qed

lemma free_memory_presrv_lcrsp_e:
  "local_respect_e (hyperc (Buddy_Memory_Free po b))"
  using free_memory_presrv_lcrsp exec_event_def
        prod.simps(2) vpeq_reflexive_lemma
  by(auto cong del: vpeq1_def)

subsection \<open>proving "schedule" satisfying the "local respect" property\<close>
lemma schedule_presrv_lcrsp:
  assumes p0:"(scheduler sysconf) \<setminus>\<leadsto> d"
  shows   "s \<sim> d \<sim> s'"
  using p0 by auto

lemma schedule_presrv_lcrsp_e: "local_respect_e (sys Schedule)"
  using schedule_presrv_lcrsp exec_event_def prod.simps(2) vpeq_reflexive_lemma by auto

subsection \<open>proving the "local respect" property\<close>
theorem local_respect:local_respect
  proof -
    {
      fix e
      have "local_respect_e e"
        apply(induct e)
        using alloc_memory_presrv_lcrsp_e free_memory_presrv_lcrsp_e
        apply (rule Hypercall.induct)
        using schedule_presrv_lcrsp_e
        by (rule System_Event.induct)
    }
    then show ?thesis using local_respect_all_evt by blast
  qed

end