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 )?)*)


(*  Title:      HOL/HOLCF/IOA/NTP/Packet.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

theory Packet
imports Multiset
begin

type_synonym
  'msg packet = "bool * 'msg"

definition
  hdr :: "'msg packet => bool" where
  "hdr == fst"

definition
  msg :: "'msg packet => 'msg" where
  "msg == snd"

text {* Instantiation of a tautology? *}
lemma eq_packet_imp_eq_hdr: "!x. x = packet --> hdr(x) = hdr(packet)"
  by simp

declare hdr_def [simp] msg_def [simp]

end


(*
 * 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


section \<open>Graph Type Class Instantiations\<close>

theory
  IRGraphSort
imports
  Graph.IRGraph
begin

text \<open>
An @{typ IRGraph} can be treated as an instantiation of
various type classes such as the equal type class.

Here we define the instantiations for all type classes
of which @{typ IRGraph} belongs.
\<close>

subsection \<open>Equal Instance\<close>
text \<open>
The following is an incorrect definition of equality
which is used to allow code generation of the Canonicalization
phase. Without this we have to use the values command to generate
all possible results of the canonicalization phase.

Note that we should be able to find a correct equality definition
in terms of the ids, kind, and stamp function. However, we are
yet to find a satisfactory definition as yet.
\<close>
definition IRGraph_equal :: "IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool" where
  "IRGraph_equal g1 g2 = True"

lemma graph_eq:
  fixes g1 g2 :: IRGraph
  shows "g1 = g2 \<longleftrightarrow> IRGraph_equal g1 g2"
  sorry

instantiation IRGraph :: equal
begin

definition equal_IRGraph :: "IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool" where
  "equal_IRGraph = IRGraph_equal"

instance proof
  fix g1 g2 :: IRGraph
  show "equal_class.equal g1 g2 \<longleftrightarrow> (g1 = g2)"
    apply standard
    unfolding equal_IRGraph_def using graph_eq by auto
qed
end

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


subsection \<open>Twin Spheres Example\<close>

theory TwinSpheresIdentity
  imports  Identifiability "../ParticularStructures/TwinSpheres"
begin

(*
interpretation conf1_struct: particular_struct conf1 \<open>TYPE(endurant)\<close> \<open>TYPE(quale)\<close>
  by simp

interpretation conf1: ufo_particular_theory
      \<open>conf1.\<W>\<close> \<open>conf1.inheresIn\<close> \<open>conf1.\<Q>\<S>\<close> \<open>conf1.assoc_quale\<close> \<open>conf1.towards\<close>
      \<open>TYPE(endurant)\<close> \<open>TYPE(quale)\<close>
  using conf1.ufo_particular_theory_axioms .

find_consts name: "conf1."

term \<open>ufo_particular_theory_sig.identifiables conf1.\<W> conf1.inheresIn conf1.\<Q>\<S>
          conf1.assoc_quale conf1.towards\<close>
lemma \<^marker>\<open>tag (proof) aponly\<close> conf1_sphere1_identifiable: \<open>Sphere1 \<in> conf1.identifiables\<close>
  apply (simp only: conf1.identifiable_particulars_are_the_non_permutables)
  apply (intro conf1.non_permutables_I)
  subgoal G1 by (auto simp: all_defs)
proof (intro conf1.non_permutable_I)
  fix \<phi> y
  assume \<open>\<phi> \<in> EndoMorphs\<^bsub>conf1.\<Gamma>\<^esub>\<close> \<open>y \<in> conf1.\<P>\<close>
  then interpret phi: particular_struct_endomorphism \<open>conf1.\<Gamma>\<close> \<phi>
    using endomorphisms_D[of \<phi>] by metis
  have A: \<open>conf1.inheresIn Sphere1Radius10M Sphere1\<close>
      \<open>conf1.assoc_quale Sphere1Radius10M Q_Radius10M\<close>
    by (simp add: all_defs)+
  note B = phi.morph_closes_quale_assoc[of \<open>conf1.\<w>\<close> Sphere1 \<open>\<phi> Sphere1Radius10M\<close> Q_Radius10M
        , simplified]
  show \<open>\<phi> y = Sphere1 \<longleftrightarrow> y = Sphere1\<close>
    apply (cases y ; simp)

    oops
*)

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