(*
Copyright 2018

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
theory Memory_Rewriting
  imports
      Byte_Rewriting
      "~~/src/HOL/Eisbach/Eisbach"
begin

section "Rewrite rules for reading and writing memory"

subsection "Get and set"

definition "get' \<equiv> get"
lemma get_rewrite:
  shows "get (f(k := v)) a = (if a = k then v else let' ret = get' f a in ret)"
  by (auto simp add: get_def Let'_def get'_def)
lemma get_simp_reg:
  shows "get (regs \<sigma>) r = regs \<sigma> r"
  unfolding get_def
  by auto
lemma get_simp_flg:
  shows "get (flags \<sigma>) r = flags \<sigma> r"
  unfolding get_def
  by auto
lemma get_simp_mem:
  shows "get (mem \<sigma>) r = mem \<sigma> r"
  unfolding get_def
  by auto

definition "set' \<equiv> set"
lemma set_simp:
  shows "set (f(k := v)) a b = (if a = k then f(k := b) else let' f' = set' f a b in f'(k := v))"
  unfolding set_def
  by (auto simp add: Let'_def set'_def set_def)
lemma set_simp_reg:
  shows "set (regs \<sigma>) r v = (regs \<sigma>)(r := v)"
  unfolding set_def
  by auto
lemma set_simp_flg:
  shows "set (flags \<sigma>) r v = (flags \<sigma>)(r := v)"
  unfolding set_def
  by auto
lemma set_simp_mem:
  shows "set (mem \<sigma>) r v = (mem \<sigma>)(r := v)"
  unfolding set_def
  by auto

text {*
  Use these rewrite rules:
*}
lemmas get_set_rewrite_rules =
    write_flg_def read_flg_def set_simp_flg get_simp_flg
    get_rewrite get_simp_reg get_simp_mem set_simp set_simp_reg set_simp_mem

subsection "Separation and enclosure of blocks"

text {*
  Two blocks in memory are \emph{separated} iff they have no shared address.
  Note this definition works only if the blocks do not overflow.
*}
fun sep :: "64 word \<times> nat \<Rightarrow> 64 word \<times> nat \<Rightarrow> bool" (infixl "\<bowtie>" 65)
  where "(a,s) \<bowtie> (a',s') = (s = 0 \<or> s' = 0 \<or> a + of_nat s \<le> a' \<or> a' + of_nat s' \<le> a)"

text {*
  Two blocks are \emph{enclosed} if all addresses in the first block are within the second block.
  Note this definition works only if the blocks do not overflow.
*}
fun enclosed :: "(64 word \<times> nat) \<Rightarrow> (64 word \<times> nat) \<Rightarrow> bool" (infixl "\<sqsubseteq>" 65)
  where "(a0,s0) \<sqsubseteq> (a1,s1) = (a0 \<ge> a1 \<and> a0 + of_nat s0 \<le> a1 + of_nat s1)"
definition "enclosed'' \<equiv> enclosed"

text {*
  Rewrite rules are based on the \emph{master} of the blocks used in the assembly code.
  If a block @{term a} has master @{term b}, then @{term "a \<sqsubseteq> b"} and block @{term b} is a member of a set of
  predefined blocks. Function \emph{seps} can be used to formulate an assumption stating that
  that set of blocks does not overflow, and is mutually separate.

  Reasoning is set up as follows: to check @{term "a \<bowtie> b"}, find the masters of @{term a} and @{term b},
  and check whether they are different. Different masters implies separate blocks.
  Two easily identify whether blocks are different, we use IDs.
  Similarly, @{term "\<not>a \<sqsubseteq> b"} can be checked: different masters implies non-enclosure.

  We have set up a method find\_master which can be used to find the master of a given block.
*}
definition master :: "(nat \<times> 64 word \<times> nat) set \<Rightarrow> 64 word \<times> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "master blocks a i \<equiv> no_block_overflow a \<and> (\<exists> b \<in> blocks . fst b = i \<and> a \<sqsubseteq> snd b)"

definition seps :: "(nat \<times> 64 word \<times> nat) set \<Rightarrow> bool"
  where "seps x \<equiv>
          (\<forall> (i,b) \<in> x . \<forall> (i',b') \<in> x . i = i' \<longrightarrow> b = b') \<and>
          (\<forall> (i,a,s) \<in> x . no_block_overflow (a,s) \<and> (\<forall> (i',a',s') \<in> x . (i \<noteq> i' \<longrightarrow> (a,s) \<bowtie> (a',s'))))"

lemma enclosed_reflexive[simp]:
  shows "b \<sqsubseteq> b"
  by (cases b,auto)

lemma sep_enclosed:
  assumes "no_block_overflow a"
      and "a \<sqsubseteq> a'"
      and "a' \<bowtie> b"
    shows "a \<bowtie> b"
  using assms
  apply (cases a, cases a',cases b,auto simp add: no_block_overflow.simps)
  apply unat_arith
  by (auto simp add: unat_of_nat)

lemma master_if_in_blocks:
  assumes "seps blocks"
      and "(i,a) \<in> blocks"
    shows "master blocks a i"
proof-
  have "no_block_overflow a"
    using assms
    unfolding seps_def
    by auto
  moreover
  have "(i,a) \<in> blocks \<and> fst (i,a) = i \<and> a \<sqsubseteq> snd (i,a)"
    using assms(2)
    by (auto)
  ultimately
  show ?thesis
    unfolding master_def
    by metis
qed

lemma seps_implies_no_block_overflow:
  assumes "seps blocks"
      and "(i,a) \<in> blocks"
    shows "no_block_overflow a"
  using assms
  unfolding seps_def
  by auto

lemma master_of_enclosed:
  assumes "seps blocks"
      and "no_block_overflow a"
      and "(i,b) \<in> blocks"
      and "a \<sqsubseteq> b"
    shows "master blocks a i"
    using assms
    unfolding master_def
    by force

lemma sep_implies_not_enclosed:
  assumes "a \<bowtie> b"
      and "no_block_overflow a"
      and "snd a > 0"
      and "snd b > 0"
    shows "\<not>a \<sqsubseteq> b"
  using assms
  apply (cases a, cases b,auto simp add: no_block_overflow.simps)
  apply unat_arith
  apply (auto simp add: unat_of_nat)
  apply unat_arith
  by (auto simp add: unat_of_nat)

lemma no_block_overflow_smaller_block_negative_offset:
assumes "no_block_overflow (a - offset, s)"
    and "a \<ge> offset"
    and "a \<ge> offset'"
    and "s' - unat offset' \<le> s - unat offset"
  shows "no_block_overflow (a - offset',s')"
proof-
  have "unat a + s' - unat offset' < 18446744073709551616"
    using assms(1,2,4)
    apply (auto simp add: no_block_overflow.simps unat_sub_if' word_le_nat_alt split: if_split_asm)
    apply unat_arith
    by auto
  moreover
  have "unat offset' \<le> unat a"
    using assms(3)
    by unat_arith
  ultimately
  show ?thesis
    by (auto simp add: no_block_overflow.simps unat_sub_if')
qed

lemma sep_symmetric[symmetric]:
    shows "a \<bowtie> b = b \<bowtie> a"
  by (cases a, cases b,auto simp add:)

lemma no_block_overflow_smaller_block_positive_offset:
assumes "no_block_overflow (a, s)"
    and "unat offset + s' \<le> s"
  shows "no_block_overflow (offset + a ,s')"
proof-
  show ?thesis
    using assms
    apply (auto simp add: no_block_overflow.simps )
    by unat_arith
qed

lemma no_block_overflow_smaller_block_positive_offset_r:
assumes "no_block_overflow (a, s)"
    and "unat offset + s' \<le> s"
  shows "no_block_overflow (a + offset ,s')"
proof-
  show ?thesis
    using assms
    apply (auto simp add: no_block_overflow.simps )
    by unat_arith
qed

lemma master_blocks_implies_sep:
  assumes "seps blocks"
      and "master blocks a i"
      and "master blocks a' i'"
  shows "a \<bowtie> a' = (i\<noteq>i' \<or> snd a = 0 \<or> snd a' = 0 \<or> (fst a + of_nat (snd a) \<le> fst a' \<or> fst a' + of_nat (snd a') \<le> fst a))"
proof-
  obtain b b' where b : "(i,b) \<in> blocks \<and> a \<sqsubseteq> b"
                and b': "(i',b') \<in> blocks \<and> a' \<sqsubseteq> b'"
    using assms
    by (auto simp add: master_def)
  show ?thesis
  proof(cases "i=i'")
    case False
    have "\<forall> (i', b') \<in> blocks . i \<noteq> i' \<longrightarrow> b \<bowtie> b'"
      using assms(1)[unfolded seps_def Ball_def, THEN conjunct2,THEN spec, of "(i,b)"]
            b b'
      by (cases b,auto simp add: seps_def case_prod_unfold)
    hence "b \<bowtie> b'"
      using False b'
      by auto
    thus ?thesis
      using sep_enclosed[of a b a'] sep_enclosed[of a' b' b]
      using sep_symmetric[of a' b]  sep_symmetric[of b' b] b b'
      using assms False
      by (auto simp add: master_def)
  next
    case True
    thus ?thesis
      using b b'
      by (cases a, cases a',auto)
  qed
qed

lemma master_block_implies_no_block_overflow:
  assumes "master blocks a i"
    shows "no_block_overflow a"
  using assms
  unfolding seps_def master_def
  by (auto simp add: case_prod_unfold)

lemma master_blocks_implies_enclosed:
  assumes "seps blocks"
      and "(i,b) \<in> blocks"
      and "master blocks a i"
    shows "a \<sqsubseteq> b"
proof-
  obtain b' where b': "(i,b') \<in> blocks \<and> a \<sqsubseteq> b'"
    using assms
    by (auto simp add: master_def)
  hence "b = b'"
    using assms(1)[unfolded seps_def,THEN conjunct1] assms(2)
    by (auto simp add: case_prod_unfold)
  thus ?thesis
    using b'
    by auto
qed

lemma master_blocks_implies_not_enclosed:
  assumes "seps blocks"
      and "master blocks a i"
      and "master blocks b i'"
      and "snd a > 0"
      and "snd b > 0"
      and "i \<noteq> i'"
    shows "\<not>a \<sqsubseteq> b"
proof-
  have "a \<bowtie> b"
    using assms master_blocks_implies_sep[OF assms(1),of a i b i']
    by (auto)
  thus ?thesis
    using sep_implies_not_enclosed[of a b] assms
    unfolding master_def
    by auto
qed

lemma enclosed_minus:
  shows "(a - offset,s) \<sqsubseteq> (a - offset',s') =
            (if offset \<le> a \<and> offset' \<le> a then
              (offset' \<ge> offset \<and> a - offset + of_nat s \<le> a - offset' + of_nat s')
             else
              enclosed'' (a - offset,s) (a - offset',s'))"
  by (auto simp add: enclosed''_def)

lemma enclosed_minus_numeral:
  shows "(a - ((numeral x)::64 word),s) \<sqsubseteq> (a - ((numeral x')::64 word),s') =
            (if ((numeral x)::64 word) \<le> a \<and> ((numeral x')::64 word) \<le> a then
              (((numeral x')::64 word) \<ge> ((numeral x)::64 word) \<and> a - ((numeral x)::64 word) + of_nat s \<le> a - ((numeral x')::64 word) + of_nat s')
             else
              enclosed'' (a - ((numeral x)::64 word),s) (a - ((numeral x')::64 word),s'))"
  using enclosed_minus
  by force

lemma enclosed_plus:
  shows "(n + a,s) \<sqsubseteq> (a,s') =
            (if unat n + unat a + s < 2^64 \<and> unat a + s' < 2 ^64 then n + of_nat s \<le> of_nat s' else enclosed'' (n + a, s) (a,s'))"
proof-
  have "unat n + unat a + s < 2^64 \<Longrightarrow> unat a + unat (n + of_nat s) = unat n + unat a + s"
    apply unat_arith
    by (auto simp add: unat_of_nat)
  hence 1: "unat n + unat a + s < 2^64 \<Longrightarrow> a \<le> a + (n + of_nat s)"
    by (auto simp add: no_olen_add_nat)
  have 2: "unat a + s' < 2 ^64 \<Longrightarrow> a \<le> a + of_nat s'"
    apply unat_arith
    by (auto simp add: unat_of_nat)
  have 3: "a + (n + of_nat s) = n + a + of_nat s"
    by auto
  have 4: "unat n + unat a + s < 2^64 \<Longrightarrow> a \<le> n + a"
    apply unat_arith
    by (auto simp add: unat_of_nat)
  show ?thesis
    using plus_less_left_cancel_nowrap[of a "n + of_nat s" "of_nat s'"] 1 2 3 4
    by (auto simp add: enclosed''_def)
qed

lemma enclosed_plus_numeral:
  shows "(((numeral x)::64 word) + a,s) \<sqsubseteq> (a,s') =
            (if unat ((numeral x)::64 word) + unat a + s < 2^64 \<and> unat a + s' < 2 ^64 then ((numeral x)::64 word) + of_nat s \<le> of_nat s' else enclosed'' (((numeral x)::64 word) + a, s) (a,s'))"
  using enclosed_plus
  by force

declare sep.simps[simp del]
declare enclosed.simps(1)[simp del]
lemmas sep_enclosed_simps =
  master_blocks_implies_sep
  master_block_implies_no_block_overflow
  master_blocks_implies_not_enclosed
  master_blocks_implies_enclosed
  enclosed_plus_numeral enclosed_minus_numeral

method find_master_same_block uses assms =
  match conclusion in "master blocks b i" for blocks b i \<Rightarrow> \<open>
      match assms in A: "(i, b) \<in> blocks" \<Rightarrow> \<open>
        match assms in B: "seps blocks" \<Rightarrow> \<open>
          rule master_if_in_blocks[OF B A]
        \<close>
      \<close>
    \<close>

method find_master_larger_block_negative_offset uses assms add =
  match conclusion in "master blocks (a - offset,s) i" for blocks a offset s i \<Rightarrow> \<open>
      match assms in A: "(i, a - offset',s') \<in> blocks" for offset' s' \<Rightarrow> \<open>
        match assms in B: "seps blocks" \<Rightarrow> \<open>
          rule master_of_enclosed[OF B _ A],
          rule no_block_overflow_smaller_block_negative_offset[of _ offset' s'],
          rule seps_implies_no_block_overflow[OF B A],
          simp add: add,
          simp add: add,
          simp add: add,
          simp add: add enclosed_minus enclosed_plus sep_enclosed_simps
        \<close>
      \<close>
    \<close>

method find_master_larger_block_positive_offset uses assms add =
  match conclusion in "master blocks (offset + a,s) i" for blocks a offset s i \<Rightarrow> \<open>
      match assms in A: "(i, a ,s') \<in> blocks" for s' \<Rightarrow> \<open>
        match assms in B: "seps blocks" \<Rightarrow> \<open>
          rule master_of_enclosed[OF B _ A],
          rule no_block_overflow_smaller_block_positive_offset[of a s'],
          rule seps_implies_no_block_overflow[OF B A],
          simp add: add,
          insert enclosed_plus seps_implies_no_block_overflow[OF B A],
          simp add: add enclosed_minus enclosed_plus sep_enclosed_simps no_block_overflow.simps
        \<close>
      \<close>
    \<close>
method find_master_larger_block_positive_offset_r uses assms add =
  match conclusion in "master blocks (a + offset,s) i" for blocks a offset s i \<Rightarrow> \<open>
      match assms in A: "(i, a ,s') \<in> blocks" for s' \<Rightarrow> \<open>
        match assms in B: "seps blocks" \<Rightarrow> \<open>
          rule master_of_enclosed[OF B _ A],
          rule no_block_overflow_smaller_block_positive_offset_r[of a s'],
          rule seps_implies_no_block_overflow[OF B A],
          simp add: add,
          insert enclosed_plus seps_implies_no_block_overflow[OF B A],
          simp add: add enclosed_minus enclosed_plus sep_enclosed_simps no_block_overflow.simps
        \<close>
      \<close>
    \<close>

method find_master uses assms add =
    (find_master_same_block assms: assms)
  | (find_master_larger_block_negative_offset   assms: assms add: add)
  | (find_master_larger_block_positive_offset   assms: assms add: add)
  | (find_master_larger_block_positive_offset_r assms: assms add: add)

subsection "Write blocks into memory"

text {*
  When a block is written into the memory and there exists a non-separate block, then these two blocks have to be \emph{merged}.
  Mergin means: overwrite block $b_0$ with block $b_1$ wherever possible.
*}
fun merge_blocks :: "(64 word \<times> 8 word list) \<Rightarrow> (64 word \<times> 8 word list) \<Rightarrow> (64 word \<times> 8 word list)"
  where "merge_blocks (a0,bs0) (a1,bs1) =
        (min a0 a1 ,
          (take (if a0 < a1 then unat (a1 - a0) else 0) bs0)
          @ bs1
          @ drop (if unat a1 + length bs1 < unat a0 + length bs0 then unat a1 + length bs1 - unat a0 else length bs0) bs0)"

value "merge_blocks (10, [0,1,2,3,4,5,6]) (5,[10,11,12,13,14,15,16,17])"
value "merge_blocks (10, [0,1,2,3,4,5,6]) (15,[10,11,12,13,14,15,16,17])"
value "merge_blocks (10, [0,1,2,3,4,5,6]) (9,[9,10,11,12,13,14,15,16,17])"
value "merge_blocks (10, [0,1,2,3,4,5,6]) (9,[9,10,11,12])"
value "merge_blocks (7, [0,1,2,3,4,5,6,7,8,9]) (9,[10,11,12])"

text {*
  This theorem characterizes @{term write_bytes}: that function will update the memory with all
  addresses within the block. Outside the block, the memory is unchanged.
*}
lemma spec_of_write_bytes:
  assumes "no_block_overflow (fst block, length (snd block))"
  shows "write_bytes block m x =
            (if fst block \<le> x \<and> x < fst block + of_nat (length (snd block)) then
                (snd block)!(unat (x - (fst block)))
             else
                m x)"
  using assms
proof(induct block m rule: write_bytes.induct)
  case (1 a m)
  then show ?case
    by auto
next
  case (2 a b bs m)
  have 0: "1 + a \<noteq> 0"
    using max_word_wrap[of a] 2
    by (auto simp add: max_word_def no_block_overflow.simps algebra_simps)
  hence 1: "unat a < 2 ^ 64 - 1"
    using max_word_max[of a]
    apply (cases "a=2^64-1",auto simp add: max_word_def)
    apply (subst word_less_nat_alt[of a "2^64-1",simplified,symmetric])
    by auto
  moreover
  hence 3: "a < a + 1"
    using 0
    by (cases "a = 2^64-1",auto simp add: word_less_nat_alt unat_plus_if' unat_of_nat split: if_split_asm)
  moreover
  have "(1::64 word) + of_nat (length bs) \<noteq> 0"
   and "length bs < 2 ^ 64"
   and "unat a + unat ((1::64 word) + of_nat (length bs)) < 2^64"
    using max_word_wrap[of "(of_nat (length bs))::64 word"] 1 2
    apply (auto simp add: max_word_def algebra_simps no_block_overflow.simps)
    by (auto simp add: of_nat_eq unat_plus_if' unat_of_nat)
  hence 4: "a < a + (1 + of_nat (length bs))"
    by (cases "length bs = 2^64-1",auto simp add: word_less_nat_alt unat_plus_if' unat_of_nat split: if_split_asm)
  moreover
  have 5: "no_block_overflow (a + 1, length bs)"
    using 2 unat_plus_simple[of a 1] 3
    by (auto simp add: algebra_simps no_block_overflow.simps)
  moreover
  have 6: "(x < a + 1 + of_nat (length bs)) = (x < a + (1 + of_nat (length bs)))"
    using max_word_wrap[of "(of_nat (length bs))::64 word"]
    by (auto simp add: max_word_def algebra_simps)
  ultimately
  show ?case
    using 2(1)[of "m(a := b)"]
    apply (auto simp add: Let'_def Let_def set_def fun_upd_def nth_Cons unat_sub word_le_nat_alt split: if_split_asm nat.splits)
    apply (auto simp add: unat_plus_if' split: if_split_asm )
    by (metis Suc_eq_plus1 diff_Suc_1 diff_diff_add)
qed

text {*
  Writing two separate blocks is commutative.
*}
lemma write_bytes_commute:
  assumes "(fst block0,length (snd block0)) \<bowtie> (fst block1, length (snd block1))"
      and "no_block_overflow (fst block0, length (snd block0))"
      and "no_block_overflow (fst block1, length (snd block1))"
    shows "write_bytes block0 (write_bytes block1 m) = write_bytes block1 (write_bytes block0 m)"
proof-
  {
    fix x
    have "write_bytes block0 (write_bytes block1 m) x = write_bytes block1 (write_bytes block0 m) x"
      using assms(1)
      using spec_of_write_bytes[of block0 "(write_bytes block1 m)" x,OF assms(2)]
      using spec_of_write_bytes[of block1 "(write_bytes block0 m)" x,OF assms(3)]
      using spec_of_write_bytes[of block0 m x,OF assms(2)]
      using spec_of_write_bytes[of block1 m x,OF assms(3)]
      by (auto simp add: sep.simps)
  }
  thus ?thesis
    by auto
qed

text {*
  Writing two non-separate blocks is equal to writing the merge of those blocks.
*}
lemma no_block_overflow_after_merge:
  assumes "no_block_overflow (fst block0, length (snd block0))"
      and "no_block_overflow (fst block1, length (snd block1))"
  shows "no_block_overflow (fst (merge_blocks block0 block1), length (snd (merge_blocks block0 block1)))"
  using assms
  apply (cases block0,cases block1,auto simp add: min_def no_block_overflow.simps)
  by unat_arith+

lemma write_bytes_nonseparate_is_merge:
  assumes "\<not>(fst block1, length (snd block1)) \<bowtie> (fst block0, length (snd block0))"
      and "no_block_overflow (fst block0, length (snd block0))"
      and "no_block_overflow (fst block1, length (snd block1))"
    shows "write_bytes block1 (write_bytes block0 m) = write_bytes (merge_blocks block0 block1) m"
proof-
  obtain a bs a' bs' s s'
    where 2: "block0 = (a,bs)"
      and 3: "block1 = (a',bs')"
      and 4: "length bs = s"
      and 5: "length bs' = s'"
    by (cases block0;cases block1;auto)
  hence 1: "no_block_overflow (fst (merge_blocks block0 block1), length (snd (merge_blocks block0 block1)))"
    using no_block_overflow_after_merge[OF assms(2-3)]
    by (auto)
  {
    fix x
    note unfold_write_bytes =
      spec_of_write_bytes[of block1 "(write_bytes block0 m)" x,OF assms(3)]
      spec_of_write_bytes[of "merge_blocks block0 block1" m x,OF 1]
      spec_of_write_bytes[of block1 m x,OF assms(3)]
      spec_of_write_bytes[of block0 m x,OF assms(2)]

    consider
        (A) "x < min a a'"
      | (B) "a \<le> x \<and> a < a' \<and> x < a'"
      | (C) "a' \<le> x \<and> x < a' + of_nat s'"
      | (D) "a' + of_nat s' \<le> x \<and> x < a + of_nat s"
      | (E) "max (a + of_nat s) (a' + of_nat s') \<le> x"
      using 2 3 4 5
      apply (cases "x < min a a'",auto split: if_split_asm)
      apply (cases "a < a' \<and> x < a'",auto split: if_split_asm)
      apply (cases "a' \<le> x \<and> x < a' + of_nat s'",auto split: if_split_asm)
      apply (cases "a' + of_nat s' \<le> x \<and> x < a + of_nat s",auto split: if_split_asm)
      apply (cases "max (a + of_nat s) (a' + of_nat s') \<le> x",auto)
      apply (cases "a < a' \<and> x < a'",auto split: if_split_asm)
      apply (cases "a' \<le> x \<and> x < a' + of_nat s'",auto split: if_split_asm)
      apply (cases "a' + of_nat s' \<le> x \<and> x < a + of_nat s",auto split: if_split_asm)
      apply (cases "max (a + of_nat s) (a' + of_nat s') \<le> x",auto)
      apply (cases "a < a' \<and> x < a'",auto split: if_split_asm)
      apply (cases "a' \<le> x \<and> x < a' + of_nat s'",auto split: if_split_asm)
      apply (cases "a' + of_nat s' \<le> x \<and> x < a + of_nat s",auto split: if_split_asm)
      by (cases "max (a + of_nat s) (a' + of_nat s') \<le> x",auto)

    hence "write_bytes block1 (write_bytes block0 m) x = write_bytes (merge_blocks block0 block1) m x"
    proof(cases)
      case A
      thus ?thesis
        apply (auto simp add: unfold_write_bytes)
        using 2 3 4 5
        by (auto split: if_split_asm simp add: min_def)
    next
      case B
      moreover
      hence 6: "x < a + of_nat (length bs)"
        using assms(1) 2 3 4 5
        by (auto simp add: sep.simps)
      moreover
      hence "unat x - unat a < length bs"
        using B
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have 6: "unat x - unat a < unat a' - unat a"
        using B
        by unat_arith
      moreover
      have "of_nat (unat a' - unat a) = a' - a"
        using B
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "a' < a + of_nat s"
        using assms(1) 2 3 4 5
        by (auto simp add: sep.simps)
      moreover
      have "length bs > unat a' - unat a"
        using assms(1-3) 2 3 4 5 6
        apply (auto simp add: unat_of_nat sep.simps no_block_overflow.simps)
        apply unat_arith
        by (auto simp add: unat_of_nat sep.simps no_block_overflow.simps)
      moreover
      hence "x < a' + (of_nat (length bs') + of_nat (length bs + unat a - (unat a' + length bs')))"
        using B 2 3 4 5 assms(2-3)
        unfolding no_block_overflow.simps
        apply (auto split: if_split_asm simp add: min_def)
        apply unat_arith
        by (auto simp add: unat_of_nat)
      ultimately
        show ?thesis
        using unfold_write_bytes
        apply (auto simp add: unfold_write_bytes)
        using 2 3 4 5
        apply (auto split: if_split_asm simp add: nth_append)
        by (auto split: if_split_asm simp add: unat_sub min_def)
    next
      case C
      moreover
      hence "x \<ge> min a a'"
        by (auto simp add: min_def)
      hence "a' > a \<Longrightarrow> length bs > unat a' - unat a"
        using C assms(1) 2 3 4 5
        apply (auto simp add: min_def sep.simps split: if_split_asm)
        apply unat_arith
        apply (auto simp add: unat_of_nat)
        done
      moreover
      have "unat x - unat a \<ge> unat a' - unat a"
        using C
        by unat_arith
      moreover
      have "a' > a \<Longrightarrow> unat a + (unat a' - unat a) = unat a'"
        using C
        by unat_arith
      moreover
      have "a' > a \<Longrightarrow> of_nat (unat a' - unat a) = a' - a"
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "unat x - unat a' < length bs'"
        using C 2 3 4 5
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "x < a' + (of_nat (length bs') + of_nat (length bs + unat a - (unat a' + length bs')))"
        using C assms(2-3) 2 3 4 5
        unfolding no_block_overflow.simps
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "x < a' + (of_nat (length bs') + of_nat (length bs - (unat a' + length bs' - unat a)))"
        using C assms(2-3) 2 3 4 5
        unfolding no_block_overflow.simps
        apply unat_arith
        by (auto simp add: unat_of_nat)
      ultimately
        show ?thesis
        apply (auto simp add: unfold_write_bytes)
        using 2 3 4 5
        apply (auto split: if_split_asm simp add: nth_append)
        by (auto split: if_split_asm simp add: unat_sub min_def)
    next
      case D
      moreover
      have 6: "a \<le> x"
        using D assms(1) 2 3 4 5
        apply (simp add: no_block_overflow.simps sep.simps)
        by unat_arith
      moreover
      have "a' \<le> x"
        using D[THEN conjunct1] assms(3) 2 3 4 5
        unfolding no_block_overflow.simps
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "unat x - unat a < length bs"
        using D[THEN conjunct2] assms(2) 2 3 4 5 6
        unfolding no_block_overflow.simps
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "unat x - unat a' \<ge> length bs'"
        using D[THEN conjunct1] assms(3) 2 3 4 5
        unfolding no_block_overflow.simps
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have 7: "unat a \<le> unat a' + length bs'"
        using D assms(1) 2 3 4 5
        apply (simp add: no_block_overflow.simps sep.simps)
        apply unat_arith
        by (auto simp add: unat_of_nat)
      have "unat a' + length bs' - unat a + (unat x - (unat a' + length bs')) = unat x - unat a"
        using D assms(2-3) 2 3 4 5 7
        unfolding no_block_overflow.simps
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "a < a' \<Longrightarrow> unat a + (unat a' - unat a) = unat a'"
        by unat_arith
      moreover
      have "a' + of_nat (length bs' + length bs - (unat a' + length bs' - unat a)) = of_nat (length bs) + a"
        using D assms(2-3) 2 3 4 5 7
        unfolding no_block_overflow.simps
        apply unat_arith
        by (auto simp add: unat_of_nat)
      ultimately
      show ?thesis
        apply (auto simp add: unfold_write_bytes)
        using 2 3 4 5
                          apply (auto split: if_split_asm simp add: nth_append)
                  apply (auto split: if_split_asm simp add: unat_sub min_def comm_semiring_1_class.semiring_normalization_rules(24))
        by (simp add: Groups.add_ac(2) Nat.diff_add_assoc2)
    next
      case E
      moreover
      have "a  \<le> x"
       and "a' \<le> x"
        using E assms(1) 2 3 4 5
        by (auto split: if_split_asm simp add: no_block_overflow.simps sep.simps max_def)
      moreover
      have "unat x - unat a \<ge> length bs"
        using E assms(2) 2 3 4 5
        apply (simp add: no_block_overflow.simps sep.simps max_def)
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "x \<ge> of_nat (length bs) + a"
        using E assms(2) 2 3 4 5
        apply (simp add: no_block_overflow.simps sep.simps max_def)
        by unat_arith
      moreover
      have "unat x - unat a' \<ge> length bs'"
        using E assms(3) 2 3 4 5
        apply (simp add: no_block_overflow.simps sep.simps max_def)
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "a' > a \<Longrightarrow> unat a + (unat a' - unat a) = unat a'"
        by unat_arith
      moreover
      have "length bs' + unat a' \<ge> unat a"
        using E assms(1-3) 2 3 4 5
        apply (auto simp add: algebra_simps no_block_overflow.simps sep.simps max_def split: if_split_asm)
        apply unat_arith
        apply (auto simp add: unat_of_nat)[1]
        apply (auto simp add: unat_of_nat)[1]
        apply unat_arith
        by (auto simp add: unat_of_nat)
      moreover
      have "a' \<ge> a \<Longrightarrow> length bs > unat a' - unat a"
        using E assms(1) 2 3 4 5
        apply (auto simp add: algebra_simps no_block_overflow.simps sep.simps max_def split: if_split_asm)
        apply unat_arith
        apply (auto simp add: unat_of_nat)[1]
        apply unat_arith
        by (auto simp add: unat_of_nat)
      ultimately
      show ?thesis
        apply (auto simp add: unfold_write_bytes)
        using 2 3 4 5
        apply (auto split: if_split_asm simp add: nth_append)
        by (auto split: if_split_asm simp add: unat_sub of_nat_diff min_def)
    qed
  }
  thus ?thesis
    by auto
qed

definition "write_block' \<equiv> write_block"
text {*
  Now, we can set up the rewriter for writing blocks of memory instead of bytes.
  Consider the case where a block called @{term block0} is written into memory.
  Lemma write\_block\_Cons will be applied once for each block @{term block1} that has
  already been written into memory.

  First, separation of the two blocks is checked. If they are separate, then lemma
  @{thm write_bytes_commute} is used to show that the rewriter can proceed to the next block in memory.
  If not, then lemma @{thm write_bytes_nonseparate_is_merge} is used to merge the two blocks,
  and then proceed.

  This rewrite rule introduces a term @{term write_block'}.
  This prevents the rewriter to apply this rule to all blocks at once, since this rule only applies
  to term @{term write_block}. The rewriter will be set up in such a way that this rule will be
  applied once, and then after rewriting term @{term write_block'} will be substituted by term
  @{term write_block}. This allows us to control the rewriting, i.e., to apply this rewrite rule
  \emph{once}, see what happened (how many new subgoals have arisen), and then proceed.
*}
lemma write_block_Cons:
  shows "write_block block0 (write_blocks (block1#blocks) m) =
          (let' rblock0  = Rep_block block0;
                rblock1  = Rep_block block1;
                b = (fst rblock0, length (snd rblock0)) \<bowtie> (fst rblock1, length (snd rblock1)) in
           if b then
                 let' m' = write_blocks [block1] (write_block' block0 (write_blocks blocks m)) in m'
             else
                 let' m' = write_block' (Abs_block (merge_blocks rblock1 rblock0)) (write_blocks blocks m) in m')"
  unfolding Let'_def
  using Rep_block[of block0] Rep_block[of block1]
  apply (cases "Rep_block block0";cases "Rep_block block1")
  apply (simp add: case_prod_unfold Let_def write_block'_def Let'_def del: merge_blocks.simps)
  apply (rule conjI)
  apply (rule impI, subst write_bytes_commute,simp,simp,simp,simp)
  apply (rule impI,subst write_bytes_nonseparate_is_merge,simp,simp,simp)
  using no_block_overflow_after_merge
  apply (subst Abs_block_inverse,simp add: case_prod_unfold,simp)
  done

lemma write_block'_Nil:
  shows "write_block' block0 (mem \<sigma>) = write_blocks [block0] (mem \<sigma>)"
  by (auto simp add: write_block'_def case_prod_unfold)

lemma write_block_Nil:
  shows "write_block block0 (mem \<sigma>) = write_blocks [block0] (mem \<sigma>)"
  by (auto simp add: write_block'_def case_prod_unfold)

lemma write_blocks_append:
  shows "write_blocks blocks0 (write_blocks blocks1 m) = write_blocks (blocks0@blocks1) m"
proof(induct blocks1 m arbitrary: blocks0 rule: write_blocks.induct)
case (1 m)
  thus ?case
    by auto
next
  case (2 b bs m)
  {
    fix blocks m
    have "write_blocks (blocks @ [b]) m = write_blocks blocks (write_block b m)"
      by(induct blocks m rule: write_blocks.induct,auto)
  }
  thus ?case
    using 2[of "blocks0@[b]"]
    by auto
qed

text {*
  Merging of blocks starting with the same address.
*}
lemma merge_blocks_same_start:
  shows "merge_blocks (a,b0) (a,b1) = (a,b1 @ (if length b1 \<ge> length b0 then [] else drop (length b1) b0))"
  by (auto)

text {*
  Use these rewrite rules, and never use the actually definition of the following functions:
*}
lemmas memory_write_rewrite_rules =
    merge_blocks_same_start write_blocks_append write_block_Nil write_block_Cons
declare write_block.simps[simp del]
declare write_bytes.simps[simp del]
declare write_blocks.simps(2)[simp del]
declare merge_blocks.simps[simp del]

subsection "Reading blocks from memory"

fun read_bytes_in_block :: "64 word \<times> nat \<Rightarrow> block \<Rightarrow> 8 word list"
  where "read_bytes_in_block (a,s) block = (let (a',bs) = Rep_block block in take s (drop (unat (a - a')) bs))"

lemma no_block_overflow_is_inductive:
assumes "no_block_overflow (a, Suc n)"
  shows "no_block_overflow (a + 1, n)"
proof-
  have 0: "1 + a \<noteq> 0"
    using max_word_wrap[of a] assms
    by (auto simp add: max_word_def no_block_overflow.simps algebra_simps)
  hence 1: "unat a < 2 ^ 64 - 1"
    using max_word_max[of a]
    apply (cases "a=2^64-1",auto simp add: max_word_def)
    apply (subst word_less_nat_alt[of a "2^64-1",simplified,symmetric])
    by auto
  hence 3: "a < a + 1"
    using 0
    by (cases "a = 2^64-1",auto simp add: word_less_nat_alt unat_plus_if' unat_of_nat split: if_split_asm)
  thus ?thesis
    using assms unat_plus_simple[of a 1]
    by (auto simp add: algebra_simps no_block_overflow.simps)
qed

lemma read_bytes_focus:
  assumes "\<forall> a' . fst b \<le> a' \<and> a' < fst b + of_nat (snd b) \<longrightarrow> m a' = m' a'"
      and "no_block_overflow b"
    shows "read_bytes m b = read_bytes m' b"
  using assms
proof(induct m b rule: read_bytes.induct)
  case (1 m b)
  thus ?case
    by auto
next
  case (2 m a n)
  moreover
  have "no_block_overflow (a + 1, n)"
    using 2 no_block_overflow_is_inductive
    by auto
  moreover
  have "unat a + n < 18446744073709551615 \<Longrightarrow> \<not> a < a + (1 + of_nat n) \<Longrightarrow> False"
    apply unat_arith
    by (auto simp add: unat_of_nat)
  hence "a \<le> a \<and> a < a + (1 + of_nat n)"
    using 2(3) 2(2)[THEN spec, of a]
    by (auto simp add: no_block_overflow.simps unat_plus_if' split: if_split_asm)
  moreover
  have "\<forall>a'. a + 1 \<le> a' \<and> a' < a + 1 + of_nat n \<longrightarrow> m a' = m' a'"
  proof-
    {
      fix a'
      assume "a+1\<le> a' \<and> a' < a + 1 + of_nat n"
      hence "a \<le> a' \<and> a' < a + of_nat (Suc n)"
        using 2(3)
        apply (auto simp add: no_block_overflow.simps)
        apply unat_arith
        apply (auto simp add: unat_of_nat)
        by unat_arith
      hence "m a' = m' a'"
        using 2(2)[THEN spec,of a']
        by auto
    }
    thus ?thesis
      by auto
  qed
  ultimately
  show ?case
    by (auto simp add: Let'_def)
qed

lemma read_bytes_separate:
  assumes "\<forall> a' . fst b > a' \<or> a' \<ge> fst b + of_nat (snd b) \<longrightarrow> m a' = m' a'"
      and "a \<bowtie> b"
      and "no_block_overflow a"
    shows "read_bytes m a = read_bytes m' a"
    using assms
proof(induct m a rule: read_bytes.induct)
  case (1 m a)
  thus ?case
    by auto
next
  case (2 m a n)
  moreover
  have "no_block_overflow (a + 1, n)"
    using 2 no_block_overflow_is_inductive
    by auto
  moreover
  have "a < fst b \<or> fst b + of_nat (snd b) \<le> a"
    using 2(3,4)
    apply (cases a;cases b; auto simp add: sep.simps no_block_overflow.simps)
    apply unat_arith
    by (auto simp add: unat_of_nat)
  moreover
  have "(a + 1, n) \<bowtie> b"
    using 2(3,4)
    apply (cases b; auto simp add: sep.simps no_block_overflow.simps algebra_simps)
    apply unat_arith
    by (auto simp add: unat_of_nat)
  ultimately
  show ?case
    by (auto simp add: Let'_def Let_def)
qed

lemma read_bytes_write_block_separate:
  assumes "a \<bowtie> (fst (Rep_block block), length (snd (Rep_block block)))"
      and "no_block_overflow a"
    shows "read_bytes (write_block block m) a = read_bytes m a"
  apply (subst read_bytes_separate[of "(fst (Rep_block block), length (snd (Rep_block block)))" "write_block block m" m a])
  using assms Rep_block[of block]
  by (auto simp add: write_block.simps spec_of_write_bytes)

lemma read_bytes_write_blocks_Cons:
  assumes "a \<sqsubseteq> (fst (Rep_block block), length (snd (Rep_block block)))"
      and "no_block_overflow a"
    shows "read_bytes (write_blocks (block#blocks) m) a = read_bytes (write_bytes (Rep_block block) m) a"
proof-
  have 0: "no_block_overflow (fst (Rep_block block), length (snd (Rep_block block)))"
    using Rep_block[of block]
    by auto
  {
    fix a'
    assume "fst a \<le> a' \<and> a' < fst a + of_nat (snd a)"
    hence "fst (Rep_block block) \<le> a' \<and> a' < fst (Rep_block block) + of_nat (length (snd (Rep_block block)))"
      using assms(1)
      by (cases a, auto simp add: enclosed.simps)
    hence "write_bytes (Rep_block block) (write_blocks blocks m) a' = write_bytes (Rep_block block) m a'"
      by (auto simp add: spec_of_write_bytes[OF 0])
  }
  thus ?thesis
    apply (auto simp add: write_blocks.simps(2) write_block.simps)
    using read_bytes_focus[of a "write_bytes (Rep_block block) (write_blocks blocks m)" "write_bytes (Rep_block block) m"] assms(2)
    by auto
qed

lemma spec_of_read_bytes:
  assumes "no_block_overflow (fst region, snd region)"
      and "x < snd region"
    shows "(read_bytes m region) ! x = m (fst region + of_nat x)"
  using assms
proof(induct m region arbitrary: x rule: read_bytes.induct)
case (1 m region)
  thus ?case
    by auto
next
  case (2 m a n)
  have "no_block_overflow (a + 1, n)"
    using 2 no_block_overflow_is_inductive
    by auto
  moreover
  have 1: "\<And> x' . x = Suc x' \<Longrightarrow> a + 1 + of_nat x' = a + (1 + of_nat x')"
    using 2(2-)
    by (auto simp add: no_block_overflow.simps)
  ultimately
  show ?case
    using 2(1)[of "x-1"] 2(2-)
    by (cases x, auto simp add: Let'_def Let_def nth_Cons)
qed

lemma read_bytes_write_bytes:
  assumes "b \<sqsubseteq> (fst (Rep_block block), length (snd (Rep_block block)))"
      and "no_block_overflow b"
    shows "read_bytes (write_bytes (Rep_block block) m) b = read_bytes_in_block b block"
proof-
  have 1: "(length (snd (Rep_block block)) - unat (fst b - fst (Rep_block block))) \<ge> snd b"
    using assms(1-2)
    apply (cases b,auto simp add: no_block_overflow.simps enclosed.simps)
    apply unat_arith
    by (auto simp add: unat_of_nat)
  hence "length (read_bytes (write_bytes (Rep_block block) m) b) = length (read_bytes_in_block b block)"
    by (cases b, auto simp add: case_prod_unfold Let_def length_read_bytes)
  moreover
  {
    fix x
    assume 0: "x < snd b"
    moreover
    have "fst (Rep_block block) \<le> fst b + of_nat x"
      using 0 assms(1-2)
      apply (cases b,auto simp add: no_block_overflow.simps enclosed.simps)
      apply unat_arith
      by (auto simp add: unat_of_nat)
    moreover
      have "fst b + of_nat x < fst (Rep_block block) + of_nat (length (snd (Rep_block block)))"
      using 0 assms(1-2)
      apply (cases b,auto simp add: no_block_overflow.simps enclosed.simps)
      apply unat_arith
      by (auto simp add: unat_of_nat)
    moreover
    have "unat (fst b + of_nat x - fst (Rep_block block)) = (unat (fst b - fst (Rep_block block)) + x)"
      using 0 assms(1-2)
      apply (cases b,auto simp add: no_block_overflow.simps enclosed.simps unat_sub_if' unat_plus_if')
      apply unat_arith
      apply (auto simp add: unat_of_nat)
      by unat_arith+
    ultimately
    have "(read_bytes (write_bytes (Rep_block block) m) b) ! x = (read_bytes_in_block b block) ! x"
      apply (subst spec_of_read_bytes)
      apply (auto simp add: assms(2))
      apply (subst spec_of_write_bytes)
      using 1 Rep_block[of block]
      apply auto
      by (cases b, auto)
  }
  ultimately
  show ?thesis
    apply (intro nth_equalityI)
    by (auto simp add: length_read_bytes)
qed

declare write_block.simps[simp del]
declare write_bytes.simps[simp del]
declare write_blocks.simps(2)[simp del]
declare merge_blocks.simps[simp del]

lemma length_read_bytes_in_block:
  assumes "Rep_region b \<sqsubseteq> (fst (Rep_block block), length (snd (Rep_block block)))"
      and "no_block_overflow (Rep_region b)"
    shows "length (read_bytes_in_block (Rep_region b) block) = snd (Rep_region b)"
  using assms Rep_block[of block]
  apply (cases b,auto simp add: case_prod_unfold Let_def Abs_region_inverse min_def enclosed.simps no_block_overflow.simps unat_sub)
  apply unat_arith
  by (auto simp add: unat_of_nat)

definition "read_region'  \<equiv> read_region"
definition "read_region'' \<equiv> read_region"
lemma read_region_write_blocks:
  shows "((read_region (write_blocks (block#blocks) m) b)::'a::len0 word) =
      (let' (a',s') = (fst (Rep_block block), length (snd (Rep_block block))) ;
           (a,s)   = (fst (Rep_region b), snd (Rep_region b)) in
       let' found = (a,s) \<sqsubseteq> (a',s') in
        if found then
          cat_bytes (rev (read_bytes_in_block (a,s) block))
        else let' sep = (a,s) \<bowtie> (a',s') in
          if sep then
            read_region' (write_blocks blocks m) b
          else
            read_region'' (write_blocks (block#blocks) m) b
      )"
  unfolding Let'_def
  using Rep_region
  apply (auto simp add: Let_def Let'_def case_prod_unfold read_region_def read_region''_def read_region'_def min_def)
  apply (auto simp add: read_bytes_write_blocks_Cons length_read_bytes length_read_bytes_in_block min_def sublist_def take_bits_cat_bytes read_bytes_write_bytes)[1]
  apply (simp add: write_blocks.simps(2),subst read_bytes_write_block_separate,simp,simp,simp)
  by (auto simp add: take_bits_cat_bytes read_bytes_write_bytes read_bytes_write_blocks_Cons length_read_bytes length_read_bytes_in_block min_def sublist_def)[1]

definition "BLOCK_OVERFLOW b \<equiv> Rep_block (Abs_block b)"
lemma Abs_block_inverse_unconditional:
  shows "Rep_block (Abs_block b) = (let' no_overflow = no_block_overflow (fst b,length (snd b)) in if no_overflow then b else BLOCK_OVERFLOW b)"
  using Abs_block_inverse
  by (cases b,auto simp add: Let'_def BLOCK_OVERFLOW_def)
definition "REGION_OVERFLOW b \<equiv> Rep_region (Abs_region b)"
lemma Abs_region_inverse_unconditional:
  shows "Rep_region (Abs_region b) = (let' no_overflow = no_block_overflow (fst b,snd b) in if no_overflow then b else REGION_OVERFLOW b)"
  using Abs_region_inverse
  by (cases b,auto simp add: Let'_def REGION_OVERFLOW_def)

text {*
  Use these rewrite rules, and never use the actually definition of the following functions:
*}
lemmas memory_read_rewrite_rules =
    read_region_write_blocks length_read_bytes
    Abs_block_inverse_unconditional Abs_region_inverse_unconditional
declare read_bytes.simps(2)[simp del]

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

(*
 * Proofs of the frame rules for leaf functions of the kernel.
 *
 * The frame rule for a function is the rule that shows the
 * function affects only local state.
 *
 *)

theory Frame_SD
imports Separation_SD
begin

(***********************************
 * Frame rules for leaf functions. *
 ***********************************)

lemma dom_object_to_sep_state:
  "dom (object_to_sep_state ptr obj cmp) = {ptr} \<times> cmp"
  apply (clarsimp simp: object_to_sep_state_def split:if_splits)
  apply (auto simp:object_project_def split:if_splits cdl_component_id.splits)
  done

lemma object_to_sep_state_restrict:
  "object_to_sep_state obj_id obj M |` ({obj_id} \<times> m) = object_to_sep_state obj_id obj (M \<inter> m)"
  by (rule ext,
    clarsimp simp:object_to_sep_state_def restrict_map_def
    split:if_splits)

lemma object_to_sep_state_add:
  "\<lbrakk>{obj_id} \<times> m \<inter> dom M = {};b\<in> m\<rbrakk> \<Longrightarrow>
   (object_to_sep_state obj_id obj m ++ M) (obj_id, b)
   = Some (object_project b obj)"
  apply (subgoal_tac "(obj_id, b)\<in> {obj_id} \<times> m")
  apply (drule(1) inter_empty_not_both)
   apply (clarsimp simp:object_to_sep_state_def map_add_def dom_def)
  apply fastforce
  done

lemma singleton_intersect:
  "({x} \<times> UNIV \<inter> A = {}) = (\<forall>y. (x,y) \<notin> A)"
  by blast

lemma set_object_wp:
  "\<lbrace>< (obj_id \<mapsto>o -) \<and>* R>\<rbrace>
   set_object obj_id obj
   \<lbrace>\<lambda>rv. <obj_id \<mapsto>o obj \<and>* R>\<rbrace>"
  apply (clarsimp simp: set_object_def sep_state_projection_def)
  apply (clarsimp simp: sep_conj_def)
  apply (simp add:sep_map_o_def sep_map_general_def)
  apply (rule_tac x = "SepState (object_to_sep_state obj_id obj UNIV) empty" in exI)
  apply (rule_tac x=y in exI)
  apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def
    sep_state_disj_def sep_any_def map_disj_def
    sep_map_o_def sep_map_general_def)
  apply (frule disjoint_subset[OF
    dom_map_restrict,rotated,where a1 = "{obj_id} \<times> UNIV"])
  apply (clarsimp simp:dom_object_to_sep_state object_to_sep_state_restrict)
  apply (clarsimp simp:sep_state_add_def)
  apply (rule ext, rename_tac sep_id)
  apply (case_tac sep_id, rename_tac ptr component, clarsimp)
  apply (clarsimp simp:object_to_sep_state_add)
  apply (clarsimp simp:object_to_sep_state_def)
  apply (drule_tac x = "(ptr,component)" in fun_cong)+
  apply (simp add:map_add_def)
  apply (clarsimp split:option.splits)
  done

lemma object_eqI:
  "\<lbrakk>object_wipe_slots obj = object_wipe_slots obj'; object_slots obj = object_slots obj'\<rbrakk>
  \<Longrightarrow> obj = obj'"
  by (simp add: object_slots_def object_wipe_slots_def update_slots_def
                cdl_tcb.splits cdl_cnode.splits
         split: cdl_object.splits)

lemma disjoint_union_diff:
  "a \<inter> b = {} \<Longrightarrow> a \<union> b - a = b"
  by auto

lemma intent_reset_update_slots_single:
  "intent_reset (update_slots (object_slots obj(slot \<mapsto> cap)) obj)
  = update_slots (object_slots (intent_reset obj)(slot \<mapsto> cap)) (intent_reset obj)"
  by simp

lemma object_clean_update_slots_single:
  "object_clean (update_slots (object_slots obj(slot \<mapsto> cap)) obj)
  = update_slots (object_slots (object_clean obj)(slot \<mapsto> reset_cap_asid cap)) (object_clean obj)"
  by (auto simp: object_clean_def intent_reset_def asid_reset_def
                 update_slots_def object_slots_def fun_eq_iff
          split: cdl_object.splits)

lemma ptr_in_obj_to_sep_dom:
  "(ptr,Slot y) \<in> dom (object_to_sep_state ptr obj {Slot y})"
  by (simp add:dom_object_to_sep_state)

lemma sep_any_exist:
  "( sep_any m p \<and>* R ) s = (\<exists>x. ( m p x \<and>* R ) s)"
  by (auto simp:sep_state_projection_def
    sep_any_def sep_conj_def)

lemma sep_map_c_conj:
  "(ptr \<mapsto>c cap \<and>* R) s =
  (let slot = (fst ptr,Slot (snd ptr))
  in (sep_heap s) slot  = Some (CDL_Cap (Some (reset_cap_asid cap))) \<and>
     R (SepState ((sep_heap s)(slot:= None)) (sep_irq_node s)))"
  apply (clarsimp simp:sep_conj_def Let_def plus_sep_state_def sep_state_add_def)
  apply (rule iffI)
   apply (clarsimp simp:sep_map_c_def sep_disj_sep_state_def
     sep_map_general_def sep_state_disj_def map_disj_def)
   apply (subst object_to_sep_state_add)
    apply (simp add:dom_object_to_sep_state singleton_iff)+
   apply (simp add:object_project_def object_slots_object_clean)
   apply (erule arg_cong[where f = R,THEN iffD1,rotated])
   apply (case_tac y)
    apply simp
    apply (rule ext)
    apply (clarsimp simp: dom_def map_add_def object_to_sep_state_def
                   split: if_split_asm option.splits)
  apply (clarsimp simp:sep_map_c_def)
  apply (rule_tac x = "SepState [(fst ptr,Slot (snd ptr))\<mapsto> (CDL_Cap (Some (reset_cap_asid cap)))]
                                empty" in exI)
  apply (rule_tac x = "(SepState ((sep_heap s)((fst ptr,Slot (snd ptr)):= None)))
                                 (sep_irq_node s) " in exI)
  apply (clarsimp simp: sep_map_c_def sep_disj_sep_state_def
                        sep_map_general_def sep_state_disj_def map_disj_def)
  apply (intro conjI)
   apply (case_tac s,simp)
   apply (rule ext)
   apply (clarsimp simp:map_add_def split:option.splits)
  apply (clarsimp simp:object_to_sep_state_def split:if_splits)
  apply (rule_tac x = "CNode \<lparr>cdl_cnode_caps = [slot\<mapsto> cap],
    cdl_cnode_size_bits = of_nat slot\<rparr>" in exI)
  apply (clarsimp simp:object_slots_def)
  apply (rule ext)
  apply (clarsimp simp:object_project_def object_slots_def
    object_clean_def asid_reset_def update_slots_def
    intent_reset_def split:if_splits option.splits)
  done

lemma sep_map_f_conj:
  "(ptr \<mapsto>f obj \<and>* R) s =
  (let slot = (ptr,Fields)
  in (sep_heap s) slot  = Some (CDL_Object (object_wipe_slots (object_clean obj))) \<and>
     R (SepState ((sep_heap s)(slot:= None)) (sep_irq_node s)))"
  apply (clarsimp simp:sep_conj_def Let_def plus_sep_state_def sep_state_add_def)
  apply (rule iffI)
   apply (clarsimp simp:sep_map_f_def sep_disj_sep_state_def
     sep_map_general_def sep_state_disj_def map_disj_def)
   apply (subst object_to_sep_state_add)
    apply (simp add:dom_object_to_sep_state singleton_iff)+
   apply (simp add:object_project_def)
   apply (erule arg_cong[where f = R,THEN iffD1,rotated])
   apply (case_tac y)
   apply simp
   apply (rule ext)
   apply (clarsimp simp:dom_def map_add_def
     object_to_sep_state_def split:if_splits option.splits)
  apply (clarsimp simp:sep_map_c_def)
  apply (rule_tac x = "SepState [(ptr,Fields) \<mapsto> CDL_Object (object_wipe_slots (object_clean obj))]
                                empty" in exI)
  apply (rule_tac x = "SepState ((sep_heap s)((ptr,Fields):= None))
                                (sep_irq_node s)" in exI)
  apply (clarsimp simp:sep_map_f_def sep_disj_sep_state_def
     sep_map_general_def sep_state_disj_def map_disj_def)
  apply (intro conjI)
   apply (case_tac s,simp)
   apply (rule ext)
   apply (clarsimp simp:map_add_def split:option.splits)
  apply (clarsimp simp:object_to_sep_state_def split:if_splits)
  apply (rule ext)
  apply (clarsimp simp:object_project_def split:if_splits)
  done

lemma object_project_slot:
  "object_project (Slot slot) obj =
   CDL_Cap (object_slots (object_clean obj) slot)"
  by (clarsimp simp:object_project_def)

lemma intent_reset_has_slots:
  "intent_reset obj = intent_reset obj' \<Longrightarrow> has_slots obj = has_slots obj'"
  by (clarsimp simp:intent_reset_def  has_slots_def
    split:cdl_object.splits)

lemma asid_reset_has_slots:
  "asid_reset obj = asid_reset obj' \<Longrightarrow>
    has_slots obj = has_slots obj'"
  by (clarsimp simp:asid_reset_def
    has_slots_def update_slots_def
    split:cdl_object.splits)

lemma object_clean_has_slots:
  "object_clean obj = object_clean obj' \<Longrightarrow> has_slots obj = has_slots obj'"
  by (clarsimp simp:object_clean_def2
    dest!: asid_reset_has_slots intent_reset_has_slots)

lemma set_object_slot_wp_helper:
 "\<lbrace>\<lambda>s. <(obj_id, slot) \<mapsto>c - \<and>* R> s \<and> cdl_objects s obj_id = Some obj
  \<and> object_clean obj = object_clean obj'\<rbrace>
  set_object obj_id (update_slots (object_slots obj' (slot \<mapsto> cap)) obj')
  \<lbrace>\<lambda>rv. <(obj_id, slot) \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (clarsimp simp: set_object_def sep_any_def)
  apply (clarsimp simp: sep_map_c_conj sep_conj_exists Let_def)
  apply (clarsimp simp: lift_def sep_state_projection_def
    sep_conj_def object_project_slot object_slots_object_clean)
  apply (case_tac "has_slots obj")
   apply (frule object_clean_has_slots)
   apply (simp add: object_slots_update_slots[where obj' = obj'])
   apply (erule arg_cong[where f = R,THEN iffD1,rotated])
   apply clarsimp
   apply (rule ext)
   apply (clarsimp split: if_splits option.splits)
   apply (clarsimp simp: object_project_def object_wipe_slots_def
                         object_slots_object_clean object_clean_update_slots_single
                  split: cdl_component_id.splits if_splits)
  apply (frule object_clean_has_slots)
  apply (clarsimp simp: has_slots_def object_clean_update_slots_single
                 split: option.splits)
  done

lemma set_object_slot_wp:
 "\<lbrace>\<lambda>s. <(obj_id, slot) \<mapsto>c - \<and>* R> s \<and>
       cdl_objects s obj_id = Some obj \<and>
       (\<exists>obj'. object_clean obj = object_clean obj' \<and>
       nobj = (update_slots (object_slots obj' (slot \<mapsto> cap)) obj'))\<rbrace>
  set_object obj_id nobj
  \<lbrace>\<lambda>rv. <(obj_id, slot) \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply clarsimp
  apply (rule hoare_weaken_pre)
   apply (rule set_object_slot_wp_helper)
  apply auto
  done

lemma object_wipe_slots_object_clean:
  "object_wipe_slots (object_clean obj) = object_clean (object_wipe_slots obj)"
  apply (case_tac obj, simp_all add: object_wipe_slots_def object_clean_def
                       intent_reset_def asid_reset_def update_slots_def object_slots_def)
  done

lemma object_wipe_slots_intent_reset:
  "object_wipe_slots (intent_reset obj) = intent_reset (object_wipe_slots obj)"
  by (case_tac obj,simp_all add:object_wipe_slots_def update_slots_def intent_reset_def)

abbreviation
  "tcb_at' P ptr s \<equiv> object_at (\<lambda>obj. \<exists>tcb. obj = Tcb tcb \<and> P tcb) ptr s"

lemma sep_map_f_tcb_at:
  "\<lbrakk><ptr \<mapsto>f tcb \<and>* R> s ; is_tcb tcb\<rbrakk>
  \<Longrightarrow> tcb_at'
  (\<lambda>t. object_clean (object_wipe_slots (Tcb t)) = object_clean (object_wipe_slots tcb))
  ptr s"
  apply (simp add:sep_state_projection_def)
  apply (clarsimp simp:sep_map_f_conj
    object_project_def is_tcb_def
    split:option.splits cdl_object.splits)
  apply (rename_tac cdl_tcb z)
  apply (case_tac z,
         simp_all add: object_wipe_slots_def object_clean_def asid_reset_def
                       update_slots_def intent_reset_def)
  apply (simp add:object_at_def opt_object_def object_slots_def object_wipe_slots_def
                  update_slots_def)
  apply (rename_tac cdl_tcb')
  apply (case_tac cdl_tcb)
  apply (case_tac cdl_tcb')
  apply clarsimp
  done

lemma object_slots_update_slots_empty [simp]:
  "object_slots (update_slots empty object) = empty"
  by (case_tac "has_slots object", simp_all)

lemma set_object_cdl_field_wp:
  assumes slot: "object_slots obj_n = object_slots obj"
  and type: "object_type obj_n = object_type obj"
            "object_type obj_np = object_type obj"
            "object_type obj_p = object_type obj"
  and fields: "object_wipe_slots (object_clean obj_np) = object_wipe_slots (object_clean obj_n)"
  shows
  "\<lbrace>\<lambda>s. <obj_id \<mapsto>f obj_p \<and>* R> s \<and> object_at (op = obj) obj_id s\<rbrace>
  set_object obj_id obj_n
  \<lbrace>\<lambda>rv. <obj_id \<mapsto>f obj_np \<and>* R>\<rbrace>"
  apply (clarsimp simp: set_object_def)
  apply (clarsimp simp: sep_state_projection_def sep_map_f_conj)
  apply (rule conjI)
   apply (simp add:object_project_def)
   apply (rule object_eqI)
    apply (cut_tac fields)
    apply (simp add:object_wipe_slots_object_clean)
   apply (rule ext)
   apply (simp add:object_wipe_slots_def type)
  apply (erule arg_cong[where f = R, THEN iffD1,rotated])
  apply (clarsimp simp:opt_object_def object_at_def)
  apply (rule ext)
  apply (clarsimp split:if_splits option.splits)
  apply (cut_tac slot)
  apply (rule ccontr)
  apply (clarsimp simp: object_project_def object_slots_object_clean
                 split: cdl_component_id.splits)
  done

lemma set_cap_wp:
  "\<lbrace>\<lambda>s. <ptr \<mapsto>c - \<and>* R> s\<rbrace>
    set_cap ptr cap
   \<lbrace>\<lambda>rv s. <ptr \<mapsto>c cap \<and>* R> s\<rbrace>"
  apply (clarsimp simp: set_cap_def)
  apply (case_tac ptr, rename_tac obj_id slot, clarsimp)
  apply (wp|wpc)+
     apply (rule_tac obj = obj in set_object_slot_wp)
    apply (wp select_wp |wpc)+
  apply (clarsimp simp: opt_object_def)
  apply (clarsimp simp: update_slots_def has_slots_def
                 split: cdl_object.splits)
      apply (rename_tac tcb)
      apply (rule conjI, clarsimp)
       apply (rename_tac intent)
       apply (rule_tac x = "Tcb (tcb\<lparr>cdl_tcb_intent := intent\<rparr>)" in exI)
       apply (clarsimp simp: object_clean_def intent_reset_def asid_reset_def
                             update_slots_def object_slots_def)
      apply clarsimp
      apply (rule_tac x = "Tcb tcb" in exI)
      apply (clarsimp simp: fun_eq_iff)
     apply (fastforce simp: cdl_cnode.splits fun_eq_iff)+
  done

(* General version of setting fields in a TCB.
 * Probably not practical to ever use.
 *)
lemma set_cdl_tcb_field_wp:
  assumes fields_cong:
  "\<And>tcb tcb'. object_clean (object_wipe_slots (Tcb tcb)) = object_clean (object_wipe_slots (Tcb tcb'))
  \<Longrightarrow> object_clean (object_wipe_slots (Tcb (f tcb))) = object_clean (object_wipe_slots (Tcb (f tcb')))"
  assumes slots_simp:
  "\<And>tcb. object_slots (Tcb (f tcb)) = object_slots (Tcb tcb)"
  shows
  "\<lbrace>\<lambda>s. <obj_id \<mapsto>f Tcb tcb \<and>* R> s\<rbrace>
    update_thread obj_id f
   \<lbrace>\<lambda>rv s. <obj_id \<mapsto>f Tcb (f tcb) \<and>* R> s\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp: update_thread_def get_thread_def)
  apply (frule sep_map_f_tcb_at)
   apply simp
  apply (clarsimp simp:object_at_def)
  apply (wp|wpc|simp)+
          apply (rename_tac cdl_tcb)
          apply (rule_tac P =
                 "object_clean (object_wipe_slots (Tcb cdl_tcb)) = object_clean (object_wipe_slots (Tcb tcb))"
                 in hoare_gen_asm)
          apply (rule_tac obj_p = "Tcb tcb" in set_object_cdl_field_wp[OF slots_simp  ])
             apply (simp add:object_type_simps object_wipe_slots_object_clean)+
          apply (drule_tac tcb = cdl_tcb in fields_cong)
          apply simp
         apply wp+
  apply (clarsimp simp:opt_object_def object_at_def)
  done

(* Specialised (and useful) versions of the above rule. *)
lemma set_cdl_tcb_intent_wp:
  "\<lbrace>\<lambda>s. <obj_id \<mapsto>f Tcb tcb \<and>* R> s\<rbrace>
    update_thread obj_id (\<lambda>tcb. tcb\<lparr>cdl_tcb_intent := x\<rparr>)
   \<lbrace>\<lambda>rv s. <obj_id \<mapsto>f Tcb (tcb\<lparr>cdl_tcb_intent := x\<rparr>) \<and>* R> s\<rbrace>"
  apply (rule hoare_weaken_pre)
   apply (wp set_cdl_tcb_field_wp)
    apply (clarsimp simp: object_wipe_slots_def object_clean_def update_slots_def
                          asid_reset_def object_slots_def intent_reset_def)
   apply (clarsimp simp: object_slots_def)
  apply simp
  done

lemma set_cdl_tcb_fault_endpoint_wp:
  "\<lbrace>\<lambda>s. <obj_id \<mapsto>f Tcb tcb \<and>* R> s\<rbrace>
    update_thread obj_id (\<lambda>tcb. tcb\<lparr>cdl_tcb_fault_endpoint := x\<rparr>)
   \<lbrace>\<lambda>rv s. <obj_id \<mapsto>f Tcb (tcb\<lparr>cdl_tcb_fault_endpoint := x\<rparr>) \<and>* R> s\<rbrace>"
  apply (rule hoare_weaken_pre)
   apply (wp set_cdl_tcb_field_wp)
    apply (clarsimp simp: object_wipe_slots_def asid_reset_def update_slots_def
                          object_clean_def object_slots_def intent_reset_def)
    apply (case_tac tcb,case_tac tcb',simp)
   apply (clarsimp simp:object_slots_def)
  apply simp
  done

lemma sep_map_o_conj:
  "(ptr \<mapsto>o obj \<and>* R) s = (( (sep_heap s) |` ({ptr} \<times> UNIV)
  = object_to_sep_state ptr obj UNIV)
  \<and> R (SepState (sep_heap s |` (UNIV - {ptr}\<times>UNIV))
                (sep_irq_node s)))"
  apply (clarsimp simp:sep_conj_def Let_def plus_sep_state_def sep_state_add_def
    sep_map_general_def sep_map_o_def)
  apply (rule iffI)
   apply (clarsimp simp:sep_map_c_def sep_disj_sep_state_def
     sep_map_general_def sep_state_disj_def map_disj_def)
   apply (subst dom_object_to_sep_state[where obj = obj,symmetric])
   apply (subst map_add_restrict_dom_left)
    apply (simp add:map_disj_def)
   apply simp
   apply (erule arg_cong[where f = R,THEN iffD1,rotated])
   apply (case_tac y,clarsimp)
   apply (rule ext)
   apply (clarsimp simp: map_add_restrict
     split:option.splits)
   apply (simp add:dom_object_to_sep_state[where obj = obj,symmetric])
   apply (subst restrict_map_univ_disj_eq)
    apply (fastforce simp:map_disj_def)
   apply simp
  apply (rule_tac x = "SepState (object_to_sep_state ptr obj UNIV) empty" in exI)
  apply (rule_tac x = "SepState (sep_heap s |` (UNIV - {ptr}\<times>UNIV))
                                (sep_irq_node s) " in exI)
  apply (clarsimp simp:sep_map_c_def sep_disj_sep_state_def
     sep_map_general_def sep_state_disj_def map_disj_def)
  apply (clarsimp simp:dom_object_to_sep_state)
  apply (rule conjI)
   apply blast
  apply (case_tac s,simp)
  apply (rule ext)
  apply (case_tac "x \<in> {ptr}\<times>UNIV")
   apply (drule_tac x = x in fun_cong)
   apply (clarsimp simp:map_add_def restrict_map_def)
  apply (clarsimp simp:map_add_def split:option.splits)
  apply (clarsimp simp:object_to_sep_state_def split:if_splits)
  done

lemma detype_one_wp:
  "\<lbrace><obj_id \<mapsto>o obj \<and>* R>\<rbrace>
    modify (detype {obj_id})
   \<lbrace>\<lambda>_. <obj_id \<mapsto>o Untyped \<and>* R>\<rbrace>"
  apply (clarsimp simp: modify_def detype_def)
  apply wp
  apply (clarsimp simp: sep_state_projection_def sep_map_o_conj)
  apply (rule conjI)
   apply (rule ext)
    apply (clarsimp simp:object_project_def
      restrict_map_def object_to_sep_state_def)
  apply (erule arg_cong[where f = R,THEN iffD1,rotated])
  apply clarsimp
  apply (rule ext)
  apply (clarsimp simp:restrict_map_def split:if_splits)
  done

(* What is the go with create_objects? Is is passed a list of singletons? *)
lemma create_one_wp:
  "\<lbrace><obj_id \<mapsto>o - \<and>* R>\<rbrace>
    Untyped_D.create_objects [{obj_id}] (Some obj)
   \<lbrace>\<lambda>_. <obj_id \<mapsto>o obj \<and>* R>\<rbrace>"
  apply (clarsimp simp: modify_def sep_any_exist create_objects_def)
  apply wp
  apply (clarsimp simp: sep_state_projection_def sep_map_o_conj)
  apply (intro conjI ext)
   apply (drule_tac x = xa in fun_cong)
    apply (clarsimp simp: object_to_sep_state_def)
  apply (erule arg_cong[where f = R,THEN iffD1,rotated])
  apply clarsimp
  apply (rule ext)
  apply (clarsimp simp:restrict_map_def split:if_splits)
  done

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__45_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_inv__45_on_rules imports n_germanSimp_lemma_on_inv__45
begin
section{*All lemmas on causal relation between inv__45*}
lemma lemma_inv__45_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__45  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__0Vsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__1Vsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__45) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__45) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
Top level architecture related proofs.
*)

theory Arch_AI
imports ArchUntyped_AI ArchFinalise_AI
begin

declare detype_arch_state[simp]

lemma invs_strgs:
  "invs s \<longrightarrow> valid_pspace s"
  "invs s \<longrightarrow> valid_mdb s"
  "invs s \<longrightarrow> valid_objs s"
  "invs s \<longrightarrow> pspace_aligned s"
  by auto

lemma assocs_dom_comp:
  "set (map fst (filter (\<lambda>(x,y). P x \<and> y = None) (assocs f))) = (- dom f \<inter> Collect P)"
  apply (clarsimp simp: in_assocs_is_fun)
  apply (rule set_eqI)
  apply clarsimp
  apply (rule iffI, clarsimp)
  apply (erule conjE)
  apply (drule not_in_domD)
  apply (rule_tac x="(x,None)" in image_eqI)
   apply simp
  apply simp
  done

lemma assocs_empty_dom_comp:
  "(- dom f \<inter> Collect P = {}) = null (filter (\<lambda>(x, y). P x \<and> y = None) (assocs f))"
   apply (subst assocs_dom_comp [symmetric])
   apply (subst empty_set_is_null)
   apply (simp add: null_def)
   done

lemma dom_hd_assocsD:
  fixes P
  defines "filter_assocs f \<equiv> filter (\<lambda>(x,y). P x \<and> y = None) (assocs f)"
  assumes d: "- dom f \<inter> Collect P \<noteq> {}"
  shows "fst (hd (filter_assocs f)) \<notin> dom f \<and> P (fst (hd (filter_assocs f)))"
proof -
  from d  have "\<not>null (filter_assocs f)"
    unfolding filter_assocs_def
    by (simp add: assocs_empty_dom_comp)
  hence "hd (filter_assocs f) \<in> set (filter_assocs f)"
    by (clarsimp simp: null_def neq_Nil_conv)
  thus ?thesis
    unfolding filter_assocs_def
    by (clarsimp simp: in_assocs_is_fun)
qed

lemma ucast_assocs:
  "LENGTH('a) < LENGTH('b) \<Longrightarrow>
   assocs (fn o (ucast :: 'a :: len word \<Rightarrow> 'b :: len word))
     = map (\<lambda>(x, y). (ucast x, y)) (filter (\<lambda>(x, y). x < 2 ^ LENGTH('a)) (assocs fn))"
  apply (simp add: assocs_def enum_word_def split_def filter_map)
  apply (rule map_cong)
   apply (simp add: o_def)
   apply (rule trans [OF _ filter_cong [OF refl]],
          rule sym, rule filter_to_shorter_upto)
    apply simp
   apply (rule iffI)
    apply (subst word_unat_power, rule of_nat_mono_maybe)
     apply simp
    apply assumption
   apply (simp add: word_less_nat_alt word_unat.Abs_inverse unats_def)
  apply clarsimp
  apply (simp add: word_less_nat_alt word_unat.Abs_inverse unats_def)
  apply (simp add: ucast_of_nat_small)
  done

lemma ucast_le_migrate:
  "\<lbrakk> y < 2 ^ size x; size x < size y \<rbrakk> \<Longrightarrow> (ucast x \<le> y) = (x \<le> ucast y)"
  for x :: "'a :: len word" and y :: "'b :: len word"
  apply (simp add: word_le_def ucast_def del: Word.of_int_uint)
  apply (subst word_uint.Abs_inverse)
   apply (simp add: uints_num word_size)
   apply (rule order_less_le_trans, rule uint_lt2p)
   apply simp
  apply (subst word_uint.Abs_inverse)
   apply (simp add: uints_num word_size word_less_alt uint_2p_alt)
  apply simp
  done

lemma obj_at_delete_objects:
  "\<lbrace>\<lambda>s. Q (obj_at (P (interrupt_irq_node s) (arch_state s)) r s) \<and>
        r \<notin> {ptr..ptr + 2 ^ bits - 1}\<rbrace>
   delete_objects ptr bits
   \<lbrace>\<lambda>_ s. Q (obj_at (P (interrupt_irq_node s) (arch_state s)) r s)\<rbrace>"
  apply (simp add: delete_objects_def do_machine_op_def split_def)
  apply wp
  apply (simp add: detype_machine_state_update_comm)
  done

(* FIXME: move *)
crunch arch [wp]: retype_region "\<lambda>s. P (arch_state s)"
  (simp: crunch_simps)

lemma set_free_index_final_cap:
  "\<lbrace>\<lambda>s. P (is_final_cap' cap s) \<and> cte_wp_at ((=) src_cap) src s\<rbrace>
   set_cap (free_index_update f src_cap) src
   \<lbrace>\<lambda>rv s. P (is_final_cap' cap s) \<rbrace>"
  apply (simp add:is_final_cap'_def2)
  apply (clarsimp simp:valid_def)
  apply (drule set_cap_caps_of_state_monad)
  apply (erule subst[rotated])
  apply (rule_tac f = P in arg_cong)
  apply (subgoal_tac "\<And>slot. (cte_wp_at (\<lambda>c. gen_obj_refs cap \<inter> gen_obj_refs c \<noteq> {}) slot s
          = cte_wp_at (\<lambda>c. gen_obj_refs cap \<inter> gen_obj_refs c \<noteq> {}) slot b)")
   apply simp
  apply (clarsimp split:cap.splits
         simp:cte_wp_at_caps_of_state free_index_update_def
              gen_obj_refs_def)
  done

lemma set_cap_orth:
  "\<lbrace>\<lambda>s. P s \<and> Q cap' s\<rbrace> set_cap cap src \<lbrace>\<lambda>rv s. Q cap' s\<rbrace> \<Longrightarrow>
   \<lbrace>\<lambda>s. P s \<and> src\<noteq> dest \<and> (cte_wp_at ((=) cap') dest s \<longrightarrow> Q cap' s)\<rbrace>
   set_cap cap src
   \<lbrace>\<lambda>rv s. cte_wp_at ((=) cap') dest s \<longrightarrow> Q cap' s\<rbrace>"
   apply (clarsimp simp:valid_def cte_wp_at_caps_of_state)
   apply (drule_tac x = s in spec)
   apply (frule set_cap_caps_of_state_monad)
   apply clarsimp
   apply (drule(1) bspec)
   apply clarsimp
   done

lemma set_cap_empty_tables[wp]:
  "\<lbrace>\<lambda>s. P (obj_at (empty_table (set (second_level_tables (arch_state s)))) p s)\<rbrace>
     set_cap cap cref
   \<lbrace>\<lambda>rv s. P (obj_at (empty_table (set (second_level_tables (arch_state s)))) p s)\<rbrace>"
  apply (rule hoare_pre)
   apply (rule hoare_use_eq [where f=arch_state, OF set_cap_arch])
   apply (wp set_cap_obj_at_impossible)
  apply (clarsimp simp: empty_table_caps_of)
  done

lemma cte_wp_at_eq_to_op_eq:
  "cte_wp_at (\<lambda>c. c = cap) = cte_wp_at ((=) cap)"
  by (simp add: cte_wp_at_caps_of_state fun_eq_iff)

lemma max_index_upd_caps_overlap_reserved:
  "\<lbrace>\<lambda>s. invs s \<and> S \<subseteq> untyped_range cap \<and>
       descendants_range_in S slot s \<and> cte_wp_at ((=) cap) slot s \<and> is_untyped_cap cap\<rbrace>
  set_cap (max_free_index_update cap) slot
  \<lbrace>\<lambda>rv. caps_overlap_reserved S\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp:is_cap_simps)
  apply (wp set_untyped_cap_caps_overlap_reserved)
  apply (auto simp:cte_wp_at_caps_of_state max_free_index_def)
  done

lemma max_index_upd_invs_simple:
  "\<lbrace>\<lambda>s. descendants_range_in (untyped_range cap) cref s \<and>
         pspace_no_overlap_range_cover (obj_ref_of cap) (cap_bits cap) s \<and>
         invs s \<and> cte_wp_at ((=) cap) cref s \<and>  is_untyped_cap cap\<rbrace>
   set_cap  (max_free_index_update cap) cref \<lbrace>\<lambda>rv. invs\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp:is_cap_simps)
  apply (wp set_untyped_cap_invs_simple)
  apply (auto simp:cte_wp_at_caps_of_state max_free_index_def)
  done

lemma sts_pspace_no_overlap [wp]:
  "\<lbrace>pspace_no_overlap S\<rbrace> set_thread_state t st \<lbrace>\<lambda>rv. pspace_no_overlap S\<rbrace>"
  by (wp pspace_no_overlap_typ_at_lift)

lemma delete_objects_st_tcb_at:
  "\<lbrace>pred_tcb_at proj P t and invs and K (t \<notin> {ptr .. ptr + 2 ^ bits - 1})\<rbrace>
    delete_objects ptr bits
  \<lbrace>\<lambda>y. pred_tcb_at proj P t\<rbrace>"
  by (wp|simp add: delete_objects_def do_machine_op_def split_def)+

end


(*  Title:      HOL/Auth/n_german_lemma_inv__24_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

(*header{*The n_german Protocol Case Study*}*)

theory n_german_lemma_inv__24_on_rules imports n_german_lemma_on_inv__24
begin
section{*All lemmas on causal relation between inv__24*}
lemma lemma_inv__24_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__24  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__0Vsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__1Vsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqEVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__24) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__24) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*File: ContextVS.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory ContextVS imports VS begin
subsection{*Contextual closure*}

text{*\label{sec:contextVS}We show that the notion of security is closed w.r.t.~low
attacking contexts, i.e.~contextual programs into which a
secure program can be substituted and which itself employs only
\emph{obviously} low variables.*}

text{*Contexts are {\bf IMP} programs with (multiple) designated holes
(represented by constructor $\mathit{Ctxt\_Here}$).*}

datatype CtxtProg =
  Ctxt_Hole
| Ctxt_Skip
| Ctxt_Assign Var Expr
| Ctxt_Comp CtxtProg CtxtProg
| Ctxt_If BExpr CtxtProg CtxtProg
| Ctxt_While BExpr CtxtProg
| Ctxt_Call

text{*We let $C$, $D$ range over contextual programs. The substitution
operation is defined by structural recursion.*}

primrec Fill::"CtxtProg \<Rightarrow> IMP \<Rightarrow> IMP"
where
"Fill Ctxt_Hole c = c" |
"Fill Ctxt_Skip c = Skip" |
"Fill (Ctxt_Assign x e) c = Assign x e" |
"Fill (Ctxt_Comp C1 C2) c = Comp (Fill C1 c) (Fill C2 c)" |
"Fill (Ctxt_If b C1 C2) c = Iff b (Fill C1 c) (Fill C2 c)" |
"Fill (Ctxt_While b C) c = While b (Fill C c)" |
"Fill Ctxt_Call c = Call"

text{*Equally obvious are the definitions of the (syntactically)
mentioned variables of arithmetic and boolean expressions.*}

primrec EVars::"Expr \<Rightarrow> Var set"
where
"EVars (varE x) = {x}" |
"EVars (valE v) = {}" |
"EVars (opE f e1 e2) = EVars e1 \<union> EVars e2"

lemma low_Eval[rule_format]:
 "(\<forall> x . x \<in> EVars e \<longrightarrow> CONTEXT x = low) \<longrightarrow>
  (\<forall> s t . s \<approx> t \<longrightarrow> evalE e s = evalE e t)"
(*<*)
apply (induct e)
apply (simp add: twiddle_def)
apply simp
apply clarsimp
done
(*>*)

primrec BVars::"BExpr \<Rightarrow> Var set"
where
"BVars (compB f e1 e2) = EVars e1 \<union> EVars e2"

lemma low_EvalB[rule_format]:
 "(\<forall> x . x \<in> BVars b \<longrightarrow> CONTEXT x = low) \<longrightarrow>
  (\<forall> s t . s \<approx> t \<longrightarrow> evalB b s = evalB b t)"
(*<*)
apply (induct b)
apply (rename_tac Expr1 Expr2)
apply clarsimp
apply (subgoal_tac "evalE Expr1 s = evalE Expr1 t")
prefer 2 apply (rule low_Eval) apply fast apply assumption
apply (subgoal_tac "evalE Expr2 s = evalE Expr2 t")
prefer 2 apply (rule low_Eval) apply fast apply assumption
apply simp
done
(*>*)

text{*The variables possibly read from during the evaluation of $c$
are denoted by $\mathit{Vars\; c}$. Note that in the clause for
assignments the variable that is assigned to is not included in the
set.*}

primrec Vars::"IMP \<Rightarrow> Var set"
where
"Vars Skip = {}" |
"Vars (Assign x e) = EVars e" |
"Vars (Comp c d) = Vars c \<union> Vars d" |
"Vars (While b c) = BVars b \<union> Vars c" |
"Vars (Iff b c d) = BVars b \<union> Vars c \<union> Vars d" |
"Vars Call = {}"

text{*For contexts, we define when a set $X$ of variables is an upper
bound for the variables read from.*}

primrec CtxtVars::"Var set \<Rightarrow> CtxtProg \<Rightarrow> bool"
where
"CtxtVars X Ctxt_Hole = True" |
"CtxtVars X Ctxt_Skip = True" |
"CtxtVars X (Ctxt_Assign x e) = (EVars e \<subseteq> X)" |
"CtxtVars X (Ctxt_Comp C1 C2) = (CtxtVars X C1 \<and> CtxtVars X C2)" |
"CtxtVars X (Ctxt_If b C1 C2) = (BVars b \<subseteq> X \<and> CtxtVars X C1
                                             \<and>  CtxtVars X C2)" |
"CtxtVars X (Ctxt_While b C) = (BVars b \<subseteq> X \<and> CtxtVars X C)" |
"CtxtVars X Ctxt_Call = True"

(*<*)
lemma Secure_comp: "\<lbrakk>secure c1; secure c2\<rbrakk> \<Longrightarrow> secure (Comp c1 c2)"
apply (unfold secure_def)
apply (rule, rule, rule, rule)
apply (rule, rule, rule)
apply (unfold Sem_def)
apply (erule exE)+
apply (erule Sem_eval_cases)
apply (erule Sem_eval_cases)
apply (erule_tac x=s in allE, rotate_tac -1)
apply (erule_tac x=t in allE, rotate_tac -1)
apply (erule_tac x=r in allE, rotate_tac -1)
apply (erule_tac x=ra in allE)
apply (erule impE, assumption)
apply (erule impE, rule, assumption)
apply (erule impE, rule, assumption)
apply (erule_tac x=r in allE, rotate_tac -1)
apply (erule_tac x=ra in allE, rotate_tac -1)
apply (erule_tac x=ss in allE, rotate_tac -1)
apply (erule_tac x=tt in allE)
apply (erule impE, assumption)
apply (erule impE, rule, assumption)
apply (erule impE, rule, assumption)
apply assumption
done

lemma Secure_iff:
" \<lbrakk>secure c1; secure c2;
   \<forall> s ss. s \<approx> ss \<longrightarrow> evalB b s = evalB b ss\<rbrakk>
  \<Longrightarrow> secure (Iff b c1 c2)"
apply (unfold secure_def)
apply (rule, rule, rule, rule)
apply (rule, rule, rule)
apply (unfold Sem_def)
apply (erule exE)+
apply (erule_tac x=s in allE, erule_tac x=t in allE, erule impE, assumption)
apply (erule Sem_eval_cases)
apply (erule Sem_eval_cases)
apply (erule_tac x=s in allE, rotate_tac -1)
apply (erule_tac x=t in allE, rotate_tac -1)
apply (erule_tac x=ss in allE, rotate_tac -1)
apply (erule_tac x=tt in allE)
apply (erule impE, assumption)
apply (erule impE, rule, assumption)
apply (erule impE, rule, assumption)
apply assumption
apply fast
apply (erule Sem_eval_cases)
apply fast
apply (erule thin_rl)
apply (erule_tac x=s in allE, rotate_tac -1)
apply (erule_tac x=t in allE, rotate_tac -1)
apply (erule_tac x=ss in allE, rotate_tac -1)
apply (erule_tac x=tt in allE)
apply (erule impE, assumption)
apply (erule impE, rule, assumption)
apply (erule impE, rule, assumption)
apply assumption
done

lemma secure_while_aux[rule_format]:
"\<forall> n m . n \<le> k \<longrightarrow> m \<le> k \<longrightarrow>
  (\<forall> s t ss tt . (s , While b c \<rightarrow>\<^sub>n  ss) \<longrightarrow>
                 (t , While b c \<rightarrow>\<^sub>m  tt) \<longrightarrow>
                 secure c \<longrightarrow>
                 (\<forall>s ss. s \<approx> ss \<longrightarrow> evalB b s = evalB b ss) \<longrightarrow>
                 s \<approx> t \<longrightarrow> ss \<approx> tt)"
apply (induct k)
apply clarsimp apply (drule Sem_no_zero_height_derivs, clarsimp)
apply clarsimp
  apply (subgoal_tac "evalB b s = evalB b t")
  prefer 2 apply (erule thin_rl, fast)
  apply (erule Sem_eval_cases)
  prefer 2 apply (erule Sem_eval_cases, simp, simp)
  apply (erule Sem_eval_cases) prefer 2 apply simp
    apply clarsimp
    apply (subgoal_tac "r \<approx> ra", clarsimp)
    apply (erule thin_rl, unfold secure_def Sem_def) apply fast
done

lemma Secure_while:
" \<lbrakk>secure c;
   \<forall> s ss. s \<approx> ss \<longrightarrow> evalB b s = evalB b ss\<rbrakk>
  \<Longrightarrow> secure (While b c)"
apply (simp (no_asm_simp) add: secure_def)
apply (rule, rule, rule, rule)
apply (rule, rule, rule)
apply (unfold Sem_def) apply (erule exE)+
apply (rule secure_while_aux)
prefer 3 apply assumption
prefer 6 apply assumption
prefer 3 apply assumption
prefer 3 apply assumption
prefer 3 apply fast
apply (subgoal_tac "n \<le> n + na", assumption) apply (simp, simp)
done
(*>*)

text{*A constant representing the procedure body with holes.*}

consts Ctxt_Body::CtxtProg

text{*The following predicate expresses that all variables read from
by a command $c$ are contained in the set $X$ of low variables.*}

definition LOW::"Var set \<Rightarrow> CtxtProg \<Rightarrow> bool"
where "LOW X C = (CtxtVars X C \<and> (\<forall> x . x : X \<longrightarrow> CONTEXT x = low))"

(*<*)
lemma secureI_secureFillI_Aux[rule_format]:
"\<forall> n m . n \<le> k \<longrightarrow> m \<le> k \<longrightarrow>
       (\<forall> C d s t ss tt X . (s , d \<rightarrow>\<^sub>n t) \<longrightarrow>
                          (ss , d \<rightarrow>\<^sub>m  tt) \<longrightarrow>
                          s \<approx> ss \<longrightarrow>
                          d = Fill C c \<longrightarrow>
                          LOW X C \<longrightarrow>
                          LOW X Ctxt_Body \<longrightarrow>
                          body = Fill Ctxt_Body c \<longrightarrow> secure c \<longrightarrow> t \<approx> tt)"
apply (induct k)
apply clarsimp apply (drule Sem_no_zero_height_derivs, clarsimp)
apply clarsimp
apply (case_tac C)
(*Ctxt_Hole*)
apply clarsimp defer 1
(*Ctxt_Skip*)
apply clarsimp
  apply (erule Sem_eval_cases)+ apply clarsimp
(*Ctxt_Assign*)
apply clarsimp
  apply (erule thin_rl)
  apply (erule Sem_eval_cases)+ apply clarsimp
  apply (simp add: update_def LOW_def twiddle_def) apply clarsimp apply (rule low_Eval)
      apply fast
    apply (simp add: twiddle_def)
(*Ctxt_Comp*)
apply clarsimp apply (erule Sem_eval_cases) apply (erule Sem_eval_cases) apply clarsimp
  apply (subgoal_tac "r \<approx> ra")
  prefer 2 apply (simp add: LOW_def)
           apply (erule_tac x=na in allE, clarsimp)
  apply (simp add: LOW_def)
           apply (erule_tac x=ma in allE, clarsimp)
(*Ctxt_If*)
apply (rename_tac BExpr u v)
apply clarsimp
  apply (subgoal_tac "evalB BExpr s = evalB BExpr ss")
  prefer 2 apply (erule thin_rl, case_tac BExpr, clarsimp)
           apply (rename_tac Expr1 Expr2)
           apply (subgoal_tac "evalE Expr1 s = evalE Expr1 ss", clarsimp)
           apply (subgoal_tac "evalE Expr2 s = evalE Expr2 ss", clarsimp)
           apply (rule low_Eval) apply (simp add: LOW_def) apply fast apply clarsimp
           apply (rule low_Eval) apply (simp add: LOW_def) apply fast apply clarsimp
  apply (erule Sem_eval_cases) apply (erule Sem_eval_cases) prefer 2 apply clarsimp apply clarsimp
  apply (simp add: LOW_def)
           apply (erule_tac x=na in allE, clarsimp)
  apply (erule Sem_eval_cases) apply clarsimp
  apply (simp add: LOW_def)
           apply (erule_tac x=na in allE, clarsimp)
(*Ctxt_While*)
apply (rename_tac BExpr CtxtProg)
apply clarsimp
  apply (subgoal_tac "evalB BExpr s = evalB BExpr ss")
  prefer 2 apply (erule thin_rl, case_tac BExpr, clarsimp)
           apply (rename_tac Expr1 Expr2)
           apply (subgoal_tac "evalE Expr1 s = evalE Expr1 ss", clarsimp)
           apply (subgoal_tac "evalE Expr2 s = evalE Expr2 ss", clarsimp)
           apply (rule low_Eval) apply (simp add: LOW_def) apply fast apply clarsimp
           apply (rule low_Eval) apply (simp add: LOW_def) apply fast apply clarsimp
  apply (erule Sem_eval_cases) apply (erule Sem_eval_cases) prefer 2 apply clarsimp
  apply (subgoal_tac "r \<approx> ra")
  prefer 2
    apply (simp add: LOW_def)
           apply (erule_tac x=na in allE, clarsimp)
  apply (erule_tac x=ma in allE, clarsimp)
           apply (erule_tac x=mb in allE, clarsimp)
           apply (erule_tac x="Ctxt_While BExpr CtxtProg" in allE)
           apply (erule_tac x="While BExpr (Fill CtxtProg c)" in allE, clarsimp)

  apply (erule Sem_eval_cases) apply clarsimp
  apply clarsimp
(*Ctxt_Call*)
apply clarsimp apply (erule Sem_eval_cases) apply (erule Sem_eval_cases)
  apply (erule_tac x=na in allE, clarsimp)

(*The deferred goal from Ctxt\_Hole*)
  apply (unfold secure_def Sem_def)
  apply (erule thin_rl) apply fast
done
(*>*)

text{*By induction on the maximal height of the operational judgement
(hidden in the definition of $\mathit{secure}$) we can prove that the
security of $c$ implies that of $\mathit{Fill}\ C\ c$, provided that
the context and the procedure-context satisfy the $\mathit{LOW}$
predicate for some $X$, and that the "real" body is obtained by
substituting $c$ into the procedure context.*}

lemma secureI_secureFillI:
  "\<lbrakk>secure c; LOW X C; LOW X Ctxt_Body; body = Fill Ctxt_Body c\<rbrakk>
  \<Longrightarrow> secure (Fill C c)"
(*<*)
apply (simp (no_asm_simp) add: secure_def Sem_def)
apply clarsimp
apply (rule secureI_secureFillI_Aux)
prefer 3 apply assumption
prefer 4 apply assumption
prefer 3 apply assumption
apply (subgoal_tac "n \<le> n+na", assumption)
apply (erule thin_rl, simp)
apply (erule thin_rl, simp)
apply (erule thin_rl,fastforce)
apply assumption
apply assumption
apply assumption
apply assumption
done
(*>*)

text{*Consequently, a (low) variable representing the result of
the attacking context does not leak any unwanted information.*}

consts res::Var

theorem
  "\<lbrakk> secure c; LOW X C;  LOW X Ctxt_Body; s \<approx> ss; s,(Fill C c)\<Down>t;
     ss,(Fill C c)\<Down>tt; body = Fill Ctxt_Body c; CONTEXT res = low\<rbrakk>
  \<Longrightarrow> t res = tt res"
(*<*)
apply (drule secureI_secureFillI) apply assumption apply assumption apply assumption
apply (unfold secure_def)
apply (erule_tac x=s in allE, erule_tac x=ss in allE)
apply (erule_tac x=t in allE, erule_tac x=tt in allE, clarsimp)
apply (simp add: twiddle_def)
done
(*>*)
text{*End of theory ContextVS*}
end