theory HNR
imports NREST.NREST "Imperative_HOL_Time.SepAuto_Time" (* Refine_Monadic.RefineG_Recursion *)
  SepLogic_Misc
  "Refine_Imperative_HOL/Lib/Structured_Apply"
begin

section "hn_refine"

definition "\<And>T. hn_refine \<Gamma> c \<Gamma>' R m \<equiv> nofailT m \<longrightarrow>
    (\<forall>h as  n   M. pHeap h as n \<Turnstile> \<Gamma>  \<longrightarrow> m = REST M \<longrightarrow>
    (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
       (\<exists>ra Ca. M ra \<ge> Some Ca  \<and> n+Ca\<ge>t
           \<and> pHeap h' (new_addrs h as h') ((n+Ca)-t) \<Turnstile> \<Gamma>' * R ra r * true
          )
       \<and> relH {a . a < Heap.lim h \<and> a \<notin> as} h h' \<and> Heap.lim h \<le> Heap.lim h'))"

subsection "easy rules"

lemma hnr_FAILT[simp]: "hn_refine \<Gamma> c \<Gamma>' R FAILT"
  by(simp add: hn_refine_def)

subsection "Refine hnr"

lemma assumes "m \<le> m'"
    "hn_refine \<Gamma> c \<Gamma>' R m"
shows hnr_refine: "hn_refine \<Gamma> c \<Gamma>' R m'"
proof (cases m)
  case FAILi
  then show ?thesis using assms(1) by (auto simp:  hn_refine_def)
next
  case (REST x2)
  with assms(2)[unfolded hn_refine_def] have
      E: "(\<And>h as n M. pHeap h as n \<Turnstile> \<Gamma> \<Longrightarrow>
                m = SPECT M \<Longrightarrow>
                (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                          (\<exists>ra Ca. Some (enat Ca) \<le> M ra \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true) \<and>
                          relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'))"
    by auto
  show ?thesis unfolding hn_refine_def
  proof (clarsimp)
    fix h as n M'
    assume M': "m' = SPECT M'"
    with assms(1) obtain M where M: "m = SPECT M"
      by fastforce

    assume 2:  "pHeap h as n \<Turnstile> \<Gamma>"
    from E[OF 2 M] obtain h' t r ra Ca where
          ineq:  "Some (enat Ca) \<le> M ra"  and
          r: "execute c h = Some (r, h', t)" "t \<le> n + Ca"
             "pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true "
             "relH {a. a < heap.lim h \<and> a \<notin> as} h h'" "heap.lim h \<le> heap.lim h'"
      by blast

    from assms(1) M' M have  "M \<le> M'" by simp
    with ineq have ineq': "Some (enat Ca) \<le> M' ra"
      using dual_order.trans by(auto simp: le_fun_def)

    from r ineq'
    show "\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                         (\<exists>ra Ca. Some (enat Ca) \<le> M' ra \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true) \<and> relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'"
      by blast
  qed
qed

subsection "Frame rule"

lemma hnr_frame:
  assumes "hn_refine P' c Q' R m"
  assumes "P \<Longrightarrow>\<^sub>t F * P'"
  shows "hn_refine P c (F * Q') R m"
  using assms(2)
  unfolding hn_refine_def entailst_def
proof clarsimp
  fix h as n M
  assume "P \<Longrightarrow>\<^sub>A F * P' * true" "pHeap h as n \<Turnstile> P"
  then have "pHeap h as n \<Turnstile> F * P' * true" by(rule entailsD)
  then have H: "pHeap h as n \<Turnstile> P' * (F * true)"
    by (simp add: mult.assoc mult.left_commute)

  with assms(1)[unfolded hn_refine_def] have D1: "(\<And>h as n M. pHeap h as n \<Turnstile> P' \<Longrightarrow>
                m = SPECT M \<Longrightarrow>
                (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                          (\<exists>ra Ca. Some (enat Ca) \<le> M ra \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> Q' * R ra r * true) \<and>
                          relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'))"
    by auto

  from mod_star_convE[OF H]   obtain as1 as2 n1 n2 where  uni: "as = as1 \<union> as2"
    and a: "as1 \<inter> as2 = {}" and  n: "n = n1 + n2"
    and pH1: "pHeap h as1 n1 \<Turnstile> P'"
    and Fr': "pHeap h as2 n2 \<Turnstile> F * true"  by blast

  assume m: "m = SPECT M"

  from D1[OF pH1 m]  obtain h' t r ra Ca where
         1: "execute c h = Some (r, h', t)" "Some (enat Ca) \<le> M ra" and 2: "t \<le> n1 + Ca"
       and 3:                   "pHeap h' (new_addrs h as1 h') (n1 + Ca - t) \<Turnstile> Q' * R ra r * true"
       and 4:                   "relH {a. a < heap.lim h \<and> a \<notin> as1} h h'" and 5: "heap.lim h \<le> heap.lim h'"
    by blast

  have Fr: "pHeap h' as2 n2 \<Turnstile> F * true"
    apply(rule mod_relH[OF _ Fr'])
    apply(rule relH_subset) apply fact
    using Fr' a models_in_range by fastforce

  have na: "new_addrs h as1 h' \<inter> as2 = {}"
    using a models_in_range[OF Fr'] 4
    by (auto simp: new_addrs_def)

  have n': "n1 + Ca - t + n2 = n + Ca - t" using n 2 by auto
  have ne: "new_addrs h as1 h' \<union> as2 = new_addrs h as h'"
    using uni new_addrs_def by auto

  thm mod_star_convI
  have "pHeap h' (new_addrs h as1 h' \<union> as2) (n1 + Ca - t + n2) \<Turnstile> (Q' * R ra r * true) * (F * true)"
    by(rule mod_star_convI[OF na 3 Fr])
  then have "pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> (Q' * R ra r * true) * (F * true)"
    by(simp only: n' ne)
  then have 31: "pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> F * Q' * R ra r * true"
    apply(rule entailsD[rotated])
    by (simp add: assn_times_assoc entails_def mult.left_commute top_assn_reduce)

  have 41: "relH {a. a < heap.lim h \<and> a \<notin> as} h h'"
    apply(rule relH_subset) apply fact
    using uni by blast

  have 21: "t \<le> n + Ca" using 2 n by auto

  from 1 21 31 41 5 show " \<exists>h' t r. execute c h = Some (r, h', t) \<and>
                         (\<exists>ra Ca. Some (enat Ca) \<le> M ra \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> F * Q' * R ra r * true) \<and>
                         relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'"
    by auto
qed

subsection "Consequence rules"

lemma hn_refine_cons':
  assumes I: "P\<Longrightarrow>\<^sub>AP' * true"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<Longrightarrow>\<^sub>A Q' * true"
  assumes R': "\<And>x y. R x y \<Longrightarrow>\<^sub>A R' x y * true"
  shows "hn_refine P c Q' R' m"
proof -
  have "hn_refine P c Q R m"
    apply(rule hnr_frame[OF R, where F=emp,simplified])
    unfolding entailst_def by fact

  then have R2: "(\<And>h as n M. nofailT (SPECT M) \<Longrightarrow>
   pHeap h as n \<Turnstile> P \<Longrightarrow>
              m = SPECT M \<Longrightarrow>
              (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                        (\<exists>ra Ca. Some (enat Ca) \<le> M ra \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> Q * R ra r * true) \<and>
                        relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'))" unfolding hn_refine_def by auto

  show ?thesis unfolding hn_refine_def
  proof (safe,goal_cases)
    case (1 h as n M)
    from R2[OF 1] obtain h' t r ra Ca where a: "execute c h = Some (r, h', t)"
          "Some (enat Ca) \<le> M ra" "t \<le> n + Ca"
          "relH {a. a < heap.lim h \<and> a \<notin> as} h h'" "heap.lim h \<le> heap.lim h'"
       and b: "pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> Q * R ra r * true" by blast
    have b': "pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> Q' * R' ra r * true"
      apply(rule entailsD[OF _b])
      using I' R'
      by (smt assn_times_assoc ent_star_mono ent_true_drop(1) merge_true_star mult.left_commute)

    from a b' show ?case by blast
  qed
qed

lemma hn_refine_cons_pre':
  assumes I: "P\<Longrightarrow>\<^sub>AP' * true"
  assumes R: "hn_refine P' c Q R m"
  shows "hn_refine P c Q R m"
  apply(rule hn_refine_cons'[OF I R])
    by (auto simp add: entt_refl')

lemma hn_refine_preI:
  assumes "\<And>h. h\<Turnstile>\<Gamma> \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c \<Gamma>' R a"
  using assms unfolding hn_refine_def
  by blast

lemma hn_refine_cons:
  assumes I: "P\<Longrightarrow>\<^sub>tP'"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<Longrightarrow>\<^sub>t Q'"
  assumes R': "\<And>x y. R x y \<Longrightarrow>\<^sub>t R' x y"
  shows "hn_refine P c Q' R' m"
  by(rule hn_refine_cons'[OF assms[unfolded entailst_def]])

lemma hn_refine_cons_post':
  assumes R: "hn_refine P c Q R m"
  assumes I: "Q\<Longrightarrow>\<^sub>AQ'*true"
  shows "hn_refine P c Q' R m"
  using assms
  by (rule hn_refine_cons'[OF entt_refl' _ _ entt_refl'])

lemma hn_refine_cons_post:
  assumes R: "hn_refine P c Q R m"
  assumes I: "Q\<Longrightarrow>\<^sub>tQ'"
  shows "hn_refine P c Q' R m"
  using assms
  by (rule hn_refine_cons[OF entt_refl _ _ entt_refl])

lemma hn_refine_split_post:
  assumes "hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c (\<Gamma>' \<or>\<^sub>A \<Gamma>'') R a"
  apply (rule hn_refine_cons_post[OF assms])
  by (rule entt_disjI1_direct)

lemma hn_refine_post_other:
  assumes "hn_refine \<Gamma> c \<Gamma>'' R a"
  shows "hn_refine \<Gamma> c (\<Gamma>' \<or>\<^sub>A \<Gamma>'') R a"
  apply (rule hn_refine_cons_post[OF assms])
  by (rule entt_disjI2_direct)

lemma hn_refine_cons_pre:
  assumes I: "P\<Longrightarrow>\<^sub>tP'"
  assumes R: "hn_refine P' c Q R m"
  shows "hn_refine P c Q R m"
  by(rule hn_refine_cons_pre'[OF assms[unfolded entailst_def]])

definition hn_ctxt :: "('a\<Rightarrow>'c\<Rightarrow>assn) \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> assn"
  \<comment> \<open> Tag for refinement assertion \<close>
  where
  "\<And>P. hn_ctxt P a c \<equiv> P a c"

definition pure :: "('b \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> assn"
  \<comment> \<open> Pure binding, not involving the heap \<close>
  where "pure R \<equiv> (\<lambda>a c. \<up>((c,a)\<in>R))"

abbreviation "hn_val R \<equiv> hn_ctxt (pure R)"

lemma pure_app_eq: "pure R a c = \<up>((c,a)\<in>R)" by (auto simp: pure_def)

lemma pure_eq_conv[simp]: "pure R = pure R' \<longleftrightarrow> R=R'"
  unfolding pure_def
  apply (rule iffI)
  apply safe
  apply (meson pure_assn_eq_conv)
  apply (meson pure_assn_eq_conv)
  done

lemma pure_rel_eq_false_iff: "pure R x y = false \<longleftrightarrow> (y,x)\<notin>R"
  by (auto simp: pure_def)

definition "invalid_assn R x y \<equiv> \<up>(\<exists>h. h\<Turnstile>R x y) * true"

abbreviation "hn_invalid R \<equiv> hn_ctxt (invalid_assn R)"

lemma move_back_pure: "\<And>B P. \<up>B * P = P * \<up>B"
    by (simp add: assn_times_comm)
lemma move_back_pure': "\<And>Q B P. Q * \<up>B * P = Q * P * \<up>B"
    using assn_times_assoc assn_times_comm by auto
lemma consume_true: "\<And>R. true * R   * true = R   * true"
    by (metis mult.assoc mult.left_commute top_assn_reduce)

lemmas move = move_back_pure move_back_pure' consume_true

lemma invalidate_clone': "R x y \<Longrightarrow>\<^sub>A invalid_assn R x y * R x y * true"
    apply (rule entailsI)
    unfolding invalid_assn_def apply(simp add: move)
    apply (auto simp: mod_star_trueI)
    done

subsection \<open>Return\<close>

lemma hnr_RETURN_pass:
  "hn_refine (hn_ctxt R x p) (return p) (hn_invalid R x p) R (REST [x\<mapsto>1])"
  \<comment> \<open>Pass on a value from the heap as return value\<close>
  unfolding hn_refine_def
  apply (auto simp: hn_ctxt_def)
  subgoal for h as n
    using execute_return'[of p h] apply auto
    subgoal  apply(rule exI[where x=1]) apply (simp add: one_enat_def)
      apply(rule entailsD)  by(auto  simp: invalidate_clone')
    subgoal by(simp add:  relH_def)  done
  done

lemma hnr_RETURN_pure:
  assumes "(c,a)\<in>R"
  shows "hn_refine emp (return c) emp (pure R) (REST [a\<mapsto>1])"
  \<comment> \<open>Return pure value\<close>
  unfolding hn_refine_def
  apply (auto simp: hn_ctxt_def)
  subgoal for h as n
    using execute_return'[of c h] apply auto
    subgoal  apply(rule exI[where x=1]) apply (simp add: one_enat_def pure_def)
      apply(simp add: move assms)
      using entailsD entails_true by blast
    subgoal by(simp add:  relH_def)  done
  done

section "assert"

lemma hnr_ASSERT:
  assumes "\<Phi> \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R c'"
  shows "hn_refine \<Gamma> c \<Gamma>' R (do { ASSERT \<Phi>; c'})"
  using assms
  apply (cases \<Phi>)
  by(auto simp add: bind_ASSERT_eq_if)

section "ureturn"

lemma hnr_uRETURN_pure:
  assumes "(c,a)\<in>R"
  shows "hn_refine emp (ureturn c) emp (pure R) (RETURNT a)"
  \<comment> \<open>Return pure value\<close>
  unfolding hn_refine_def
  apply (auto simp: hn_ctxt_def)
  subgoal for h as n
    using execute_ureturn'[of c h] apply auto
    subgoal  apply(rule exI[where x=0]) apply (simp add: zero_enat_def pure_def)
      apply(simp add: move assms)
      using entailsD entails_true by blast
    subgoal by(simp add:  relH_def)  done
  done

lemma hnr_uRETURN_pass:
  "hn_refine (hn_ctxt R x p) (ureturn p) (hn_invalid R x p) R (RETURNT x)"
  \<comment> \<open>Pass on a value from the heap as return value\<close>
  unfolding hn_refine_def
  apply (auto simp: hn_ctxt_def)
  subgoal for h as n
    using execute_ureturn'[of p h] apply auto
    subgoal  apply(rule exI[where x=0]) apply (simp add: zero_enat_def)
      apply(rule entailsD)  by(auto  simp: invalidate_clone')
    subgoal by(simp add:  relH_def)  done
  done

subsubsection \<open>bind\<close>

lemma hnr_bind:
  assumes D1: "hn_refine \<Gamma> m' \<Gamma>1 Rh m"
  assumes D2:
    "\<And>x x'. RETURNT x \<le> m \<Longrightarrow> hn_refine (\<Gamma>1 * hn_ctxt Rh x x') (f' x') (\<Gamma>2 x x') R (f x)"
  assumes IMP: "\<And>x x'. \<Gamma>2 x x' \<Longrightarrow>\<^sub>A \<Gamma>' * hn_ctxt Rx x x' * true"
  shows "hn_refine \<Gamma> (m'\<bind>f') \<Gamma>' R (m\<bind>f)"
    unfolding hn_refine_def apply clarify
proof (goal_cases)
  case (1 h as n Mf)
  from 1(1) have nfm: "nofailT m" and nff: "\<And>x t. inresT m x t \<Longrightarrow> nofailT (f x)" by (auto simp: pw_bindT_nofailT)

  from nfm obtain M where M: "m = SPECT M" by fastforce

  from D1 nfm 1(2) M
  obtain r h' t ra Ca where execm: "execute m' h = Some (r, h', t)"
    and Mra: "M ra \<ge> Some (enat Ca)" and pH1: "pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> (\<Gamma>1 * Rh ra r) * true" and t: "t \<le> n + Ca"
    and relH1:  "relH {a. a < heap.lim h \<and> a \<notin> as} h h'" and hl1: "heap.lim h \<le> heap.lim h'"
    unfolding hn_refine_def by blast

  from M Mra have ram: "RETURNT ra \<le> m" apply (auto simp: le_fun_def RETURNT_def)
    using dual_order.trans by fastforce
  have noff: "nofailT (f ra)" apply(rule nff[where t=0]) using Mra M unfolding inresT_def
    by (smt le_some_optE nrest.simps(5) zero_enat_def zero_le)
  then obtain fM where fMra: "f ra = SPECT fM" by fastforce

  from D2[OF ram, of r] have D2': "\<And>h as n M.
       pHeap h as n \<Turnstile> \<Gamma>1 * Rh ra r \<Longrightarrow>
       f ra = SPECT M \<Longrightarrow>
       \<exists>h' t rb. execute (f' r) h = Some (rb, h', t) \<and>
                 (\<exists>raa Ca. M raa \<ge> Some (enat Ca) \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> \<Gamma>2 ra r * R raa rb * true) \<and>
                 relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'"   unfolding hn_refine_def hn_ctxt_def by auto

  from mod_star_convE[OF pH1]   obtain as1 as2 n1 n2 where  uni: "(new_addrs h as h') = as1 \<union> as2"
    and a: "as1 \<inter> as2 = {}" and  n: "(n + Ca - t) = n1 + n2"
    and pH1: "pHeap h' as1 n1 \<Turnstile> \<Gamma>1 * Rh ra r"
    and Fr': "pHeap h' as2 n2 \<Turnstile> true"  by blast

  from D2'[OF pH1 fMra] obtain h'' t' r' ra' Ca' where execf: "execute (f' r) h' = Some (r', h'', t')" and
    fMra': " fM ra' \<ge> Some (enat Ca')"
    and M'':    " pHeap h'' (new_addrs h' as1 h'') (n1  + Ca' - t') \<Turnstile> \<Gamma>2 ra r * R ra' r' * true"
    and t':" t' \<le> n1  + Ca'"
    and relH2': "relH {a. a < heap.lim h' \<and> a \<notin> as1} h' h''" and hl2: "heap.lim h' \<le> heap.lim h'' "
    by blast

  from Fr' have  Fr: "pHeap h'' as2 n2 \<Turnstile> true"
    using hl2 top_assn_rule by auto

  have disj: "new_addrs h' as1 h'' \<inter> as2 = {}"
    using a models_in_range[OF Fr'] hl2
    by (auto simp: in_range.simps new_addrs_def)

  have k: "{a. a < Heap.lim h' \<and> a \<notin> (new_addrs h as h')} \<subseteq> {a. a < Heap.lim h' \<and> a \<notin> as1}"
    using uni  by auto
  have relH2: "relH {a. a < heap.lim h' \<and> a \<notin> (new_addrs h as h')} h' h''"
    by(rule relH_subset[OF relH2' k])

      thm relH_subset
  have addrs: "(new_addrs h' as1 h'' \<union> as2) = (new_addrs h' (new_addrs h as h') h'')"
    using \<open>new_addrs h as h' = as1 \<union> as2\<close> new_addrs_def by auto

  have n12: " (n1 + Ca' - t' + n2) = (n + Ca - t) + Ca' - t'" using n t' by auto

  from mod_star_convI[OF disj M'' Fr] have
    M'': "pHeap h'' (new_addrs h' (new_addrs h as h') h'') ((n + Ca - t) + Ca' - t') \<Turnstile> \<Gamma>2 ra r * R ra' r' * true"
    unfolding n12  addrs by (metis assn_times_assoc assn_times_comm entailsD' entails_true)

  from Mra fMra' obtain Car Car' where PF: "M ra = Some Car" "fM ra' = Some Car'" by fastforce+

  thm execute_bind
  have t'': "n + Ca - t + Ca' - t' = n + (Ca + Ca') - (t + t')" using t t' by simp
  have
    "new_addrs h' (new_addrs h as h') h'' = new_addrs h as h''"
    using hl1 hl2
    by (auto simp add: new_addrs_def)
  with M'' have
    ende: "pHeap h'' (new_addrs h as h'') (n + (Ca + Ca') - (t + t')) \<Turnstile>  \<Gamma>2 ra r * R ra' r' * true"
    by (simp add: t'')
  thm Sup_upper
  have "Some (enat (Ca+Ca')) \<le> Some (Car+Car')"
    using PF Mra fMra' add_mono by fastforce
  also
  from  1(3) fMra M have
    "Some ((Car+Car')) \<le> Mf ra' "
    unfolding bindT_def  apply simp apply(drule nrest_Sup_SPECT_D[where x=ra'])
    apply simp apply(rule Sup_upper) apply auto
    apply(rule exI[where x="(map_option ((+) (Car)) \<circ> fM)"])
    using PF
    apply simp apply(rule exI[where x=ra]) apply(rule exI[where x="Car"]) by simp
  finally have "Some (enat (Ca+Ca')) \<le> Mf ra' " .

  show ?case
    apply(rule exI[where x=h''])
    apply(rule exI[where x="t+t'"])
    apply(rule exI[where x="r'"])
  proof (safe)
    show "execute (m' \<bind> f') h = Some (r', h'', t + t')"
      by (simp add: execute_bind(1)[OF execm] execf)
    show "\<exists>ra Ca. Mf ra \<ge> Some (enat Ca)\<and> t + t' \<le> n + Ca \<and> pHeap h'' (new_addrs h as h'') (n + Ca - (t + t')) \<Turnstile> \<Gamma>' * R ra r' * true "
      apply(rule exI[where x=ra'])
      apply(rule exI[where x="Ca+Ca'"])
    proof (safe)
      show "Mf ra' \<ge> Some (enat (Ca+Ca'))" apply fact done

      from IMP have "\<Gamma>2 ra r * R ra' r' * true \<Longrightarrow>\<^sub>A \<Gamma>' * R ra' r' * true"
      proof -
        have "\<forall>a aa ab ac. (ac * ab \<Longrightarrow>\<^sub>A a * true) \<or> \<not> (ac \<Longrightarrow>\<^sub>A aa * a)"
          by (metis (full_types) assn_times_assoc entails_trans2 entails_frame entails_true mult.left_commute)
        then have "\<forall>a aa ab. ab * (aa * a) \<Longrightarrow>\<^sub>A aa * true"
          by (metis (no_types) assn_times_assoc entails_frame entails_true)
        then show ?thesis
          by (metis (no_types) IMP assn_times_assoc entails_trans2 entails_frame)
      qed

      with ende  show "pHeap h'' (new_addrs h as h'') (n + (Ca + Ca') - (t + t')) \<Turnstile> \<Gamma>' * R ra' r' * true"
        using entailsD by blast
      show "t + t' \<le> n + (Ca + Ca')" using n t t' by simp
    qed
    note relH1
    also have "relH {a. a < Heap.lim h \<and> a \<notin> as} h' h''"
      apply (rule relH_subset[OF relH2])
      using hl1 hl2
      by (auto simp: new_addrs_def)
    finally show "relH {a. a < Heap.lim h \<and> a \<notin> as} h h''" .
    show "heap.lim h \<le> heap.lim h'' "
      using hl1 hl2 by simp
  qed
qed

subsubsection \<open>Recursion\<close>
(* from Refine_Imperative_HOL.Sepref_Basic *)

lemma hnr_RECT:
  assumes S: "\<And>cf af ax px. \<lbrakk>
    \<And>ax px. hn_refine (hn_ctxt Rx ax px * F) (cf px) (F' ax px) Ry (af ax)\<rbrakk>
    \<Longrightarrow> hn_refine (hn_ctxt Rx ax px * F) (cB cf px) (F' ax px) Ry (aB af ax)"
  assumes M: "(\<And>x. mono_Heap (\<lambda>f. cB f x))"
  shows "hn_refine
    (hn_ctxt Rx ax px * F) (heap.fixp_fun cB px) (F' ax px) Ry (NREST.RECT aB ax)"
  unfolding RECT_flat_gfp_def
proof (simp, intro conjI impI)
  assume "mono2 aB"
  hence "flatf_mono_ge aB" by(rule trimonoD_flatf_ge)
  have "\<forall>ax px.
    hn_refine (hn_ctxt Rx ax px * F) (heap.fixp_fun cB px) (F' ax px) Ry
      (flatf_gfp aB ax)"

    apply (rule flatf_ord.fixp_induct[OF _ \<open>flatf_mono_ge aB\<close>])

    apply (rule flatf_admissible_pointwise)
    apply simp

    apply (auto simp: hn_refine_def) [] (* have no idea what happens here ! *)

    apply clarsimp
    apply (subst heap.mono_body_fixp[of cB, OF M])
    apply (rule S)
    apply blast
    done
  thus "hn_refine (hn_ctxt Rx ax px * F)
     (ccpo.fixp (fun_lub Heap_lub) (fun_ord Heap_ord) cB px) (F' ax px) Ry
     (flatf_gfp aB ax)" by simp
qed

lemma hnr_If':
  assumes P: "\<Gamma> \<Longrightarrow>\<^sub>A \<Gamma>1 * hn_val bool_rel a a' * true"
  assumes RT: "a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') b' \<Gamma>2b R b"
  assumes RE: "\<not>a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') c' \<Gamma>2c R c"
  assumes IMP: "\<Gamma>2b \<or>\<^sub>A \<Gamma>2c \<Longrightarrow>\<^sub>A \<Gamma>' * true"
  shows "hn_refine \<Gamma> (if a' then b' else c') \<Gamma>' R (if a then b else c)"
  apply (rule hn_refine_cons'[OF P])
  apply (rule hn_refine_preI)
  apply (cases a; simp add: hn_ctxt_def pure_def)

      apply  (rule hn_refine_split_post)
      apply  (rule hn_refine_cons_pre'[OF _ RT])
        apply  (simp add: hn_ctxt_def pure_def entt_refl')
      apply  simp

    apply (rule hn_refine_post_other)
    apply (rule hn_refine_cons_pre'[OF _ RE])
        apply (simp add: hn_ctxt_def pure_def entt_refl')
      apply  simp
  apply  (rule IMP)
  apply  (rule entt_refl')
  done

lemma hnr_If:
  assumes P: "\<Gamma> \<Longrightarrow>\<^sub>t \<Gamma>1 * hn_val bool_rel a a'"
  assumes RT: "a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') b' \<Gamma>2b R b"
  assumes RE: "\<not>a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') c' \<Gamma>2c R c"
  assumes IMP: "\<Gamma>2b \<or>\<^sub>A \<Gamma>2c \<Longrightarrow>\<^sub>t \<Gamma>'"
  shows "hn_refine \<Gamma> (if a' then b' else c') \<Gamma>' R (if a then b else c)"
  apply (rule hn_refine_cons[OF P])
  apply1 (rule hn_refine_preI)
  applyF (cases a; simp add: hn_ctxt_def pure_def)
    focus
      apply1 (rule hn_refine_split_post)
        applyF (rule hn_refine_cons_pre[OF _ RT])
        applyS (simp add: hn_ctxt_def pure_def entt_refl)
        applyS simp
      solved
    solved
    apply1 (rule hn_refine_post_other)
    applyF (rule hn_refine_cons_pre[OF _ RE])
      applyS (simp add: hn_ctxt_def pure_def entt_refl)
      applyS simp
    solved
  solved
  applyS (rule IMP)
  applyS (rule entt_refl)
  done

subsection "how to extract a hoare triple from hn_refine"

lemma extract_cost_ub:
  assumes "hn_refine \<Gamma> c \<Gamma>' R (REST M)" "(\<And>c. c\<in>ran M \<Longrightarrow> c \<le> Cost_ub)"
  shows "<\<Gamma> * $Cost_ub> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up>(ra \<in> dom M)) >\<^sub>t"
  using assms(1)  unfolding hn_refine_def
  unfolding hoare_triple_def
  apply clarify
proof (goal_cases)
  case (1 h as \<sigma> r n t)
  from 1(2) have 2: "pHeap h as (n-Cost_ub) \<Turnstile> \<Gamma>" and  nf: "n\<ge>Cost_ub"
    using mod_timeCredit_dest by auto

  from 1(1) have 3: "\<And>h as n Ma.
       pHeap h as n \<Turnstile> \<Gamma> \<Longrightarrow>
      SPECT M = SPECT Ma \<Longrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
       (\<exists>ra Ca. Ma ra \<ge> Some (enat Ca) \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') ((n + Ca) - t) \<Turnstile> \<Gamma>' * R ra r * true) \<and>
      relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')"
    by auto

  thm effect_deterministic

  from 3[OF 2 ] obtain h' t' r' where E: "execute c h = Some (r', h', t') " and
    R:  "(\<exists>ra Ca. M ra \<ge> Some (enat Ca) \<and>
                    pHeap h' (new_addrs h as h') (n - Cost_ub + Ca - t') \<Turnstile> \<Gamma>' * R ra r' * true \<and> t' \<le> n - Cost_ub + Ca) \<and>
           relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'" by blast

  have F: "\<sigma> = Some h'" and prime: "r' = r" "t' = t"
    using E 1(3) run.cases apply force
    using E 1(3) run.cases apply force
    using E 1(3) run.cases by force
  then have sig: "the \<sigma> = h'" by auto
  from R  have
    B: "(\<exists>ra Ca. M ra \<ge> Some (enat Ca) \<and>
     pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Cost_ub + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true \<and>
        t \<le> n - Cost_ub + Ca )" and C:
    "relH {a. a < heap.lim h \<and> a \<notin> as} h (the \<sigma>)" "heap.lim h \<le> heap.lim (the \<sigma>) "
    unfolding prime sig by auto

  from B obtain ra Ca where i: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Cost_ub + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true"
    and ii:  "t \<le> n - Cost_ub + Ca"  and ineq: "M ra \<ge> Some (enat Ca)"
    using B by auto

  from ineq have radom: "ra \<in> dom M" using domIff by fastforce
  then obtain Mra where Mra: "M ra = Some Mra" by blast
  with assms(2) have "Mra \<le> enat Cost_ub" by (meson ranI)
  with Mra ineq have "Some (enat Ca) \<le> Some (enat Cost_ub)"
    using dual_order.trans by fastforce
  then have ie: "Ca \<le> Cost_ub" by auto

  have pr: "(n - Cost_ub + Ca - t) = (n - t) - (Cost_ub - Ca)" using ie ii nf by auto
  have pl: "(n - (t + (Cost_ub - Ca)) + (Cost_ub - Ca)) = n-t" using ii nf by auto

  have "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>) \<union> {}) ((n - t) - (Cost_ub - Ca) + (Cost_ub - Ca)) \<Turnstile> \<Gamma>' * R ra r * true * true"
    apply(rule mod_star_convI)  apply simp
     apply(rule i[unfolded pr])  by (simp add: top_assn_rule)

  then have H: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * true * true"
    by (simp add: pl)

  have "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * \<up> (ra \<in> dom M) * true"
    apply(rule entailsD[OF _ H]) using radom by auto2
  then have "\<exists>ra. pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * \<up> (ra \<in> dom M) * true"
    by blast
  then have H': "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> (\<exists>\<^sub>Ara. \<Gamma>' *  R ra r * \<up> (ra \<in> dom M) * true)"
    using mod_ex_dist by blast
  have H: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (ra \<in> dom M)) * true"
    apply(rule entailsD[OF _ H']) by auto2

  from ii ie nf have T: "t \<le> n " by auto

  show ?case
    apply safe
    subgoal using F by auto
    subgoal using H by simp
    subgoal by fact
     apply fact apply fact done
qed

lemma extraction_example: "hn_refine \<Gamma> c \<Gamma>' (\<lambda>ra r. \<up>(ra = r)) (REST [length xs\<mapsto> enat (Costs)]) \<Longrightarrow>
           <\<Gamma> * $Costs> c <\<lambda>r. \<Gamma>' * \<up>(r = length xs) >\<^sub>t"
  unfolding hn_refine_def
  unfolding hoare_triple_def
  apply clarify
proof (goal_cases)
  case (1 h as \<sigma> r n t)
  from 1(2) have 2: "pHeap h as (n-Costs) \<Turnstile> \<Gamma>" and  nf: "n\<ge>Costs"
    using mod_timeCredit_dest by auto

  from 1(1) have 3: "\<And>h as n M.
       pHeap h as n \<Turnstile> \<Gamma> \<Longrightarrow>
      SPECT [length xs \<mapsto> enat (Costs)] = SPECT M \<Longrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
       (\<exists>ra Ca. M ra \<ge> Some (enat Ca) \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') ((n + Ca) - t) \<Turnstile> \<Gamma>' * \<up> (ra = r) * true) \<and>
      relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')"
      by auto

    thm effect_deterministic

    from 3[OF 2 ] obtain h' t' r' where E: "execute c h = Some (r', h', t') " and
          R:  "(\<exists>ra Ca. [length xs \<mapsto> enat (Costs)] ra \<ge> Some (enat Ca) \<and>
                    pHeap h' (new_addrs h as h') (n - Costs + Ca - t') \<Turnstile> \<Gamma>' * \<up> (ra = r') * true \<and> t' \<le> n - Costs + Ca) \<and>
           relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'" by blast

    have F: "\<sigma> = Some h'" and prime: "r' = r" "t' = t"
      using E 1(3) run.cases apply force
      using E 1(3) run.cases apply force
      using E 1(3) run.cases by force
    then have sig: "the \<sigma> = h'" by auto
    from R  have
    B: "(\<exists>ra  Ca. [length xs \<mapsto> enat (Costs)] ra \<ge> Some (enat Ca) \<and>
     pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Costs + Ca - t) \<Turnstile> \<Gamma>' * (\<lambda>ra r. \<up>(ra = r)) ra r * true \<and>
        t \<le> n - Costs + Ca )" and C:
  "relH {a. a < heap.lim h \<and> a \<notin> as} h (the \<sigma>)" "heap.lim h \<le> heap.lim (the \<sigma>) "
      unfolding prime sig by auto

   have p2: "\<And>ra Ca. ([length xs \<mapsto> enat (Costs)] ra \<ge> Some (enat Ca)) =
                (ra = length xs \<and> Ca \<le> Costs)" by auto

  from B obtain Ca where i: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Costs + Ca - t) \<Turnstile> \<Gamma>' * (\<lambda>ra r. \<up>(ra = r)) (length xs) r * true"
      and ii:  "t \<le> n - Costs + Ca"  and ineq: "Ca \<le> Costs"

    using B unfolding p2 using nf by auto

  have pr: "(n - Costs + Ca - t) = (n - t) - (Costs - Ca)" using ineq ii nf by auto
  have pl: "(n - (t + (Costs - Ca)) + (Costs - Ca)) = n-t" using ineq ii nf by auto

  have "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>) \<union> {}) ((n - t) - (Costs - Ca) + (Costs - Ca)) \<Turnstile> \<Gamma>' * (\<lambda>ra r. \<up>(ra = r)) (length xs) r * true * true"
    apply(rule mod_star_convI)  apply simp
    apply(rule i[unfolded pr])  by (simp add: top_assn_rule)

  then have H: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * \<up> (r = length xs) * true"
    apply (simp add: pl)
    apply (simp add: assn_times_assoc top_assn_reduce)  by argo

  from ii ineq nf have T: "t \<le> n " by auto

  show ?case
    apply safe
    subgoal using F by auto
    subgoal using H by simp
    subgoal by fact
    apply fact apply fact done

qed

subsection "how to show a hnr predicate from a hoaretriple"

lemma run_and_execute: "(\<forall>\<sigma> t r. run c (Some h) \<sigma> r t \<longrightarrow> \<sigma> \<noteq> None \<and> P (the \<sigma>) r t)
        \<longleftrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and> P h' r t)"
  apply rule
  subgoal by (metis option.sel run.intros(2) run.intros(3) timeFrame.elims)
  subgoal by (metis (mono_tags) not_None_eq option.sel prod.sel(1) prod.sel(2) run_to_execute)
  done

lemma hoare_alt:
  "<P> c <\<lambda>r. Q r > = (\<forall>h as n.
        pHeap h as n \<Turnstile> P \<longrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
        (pHeap h' (new_addrs h as h') (n - t) \<Turnstile> Q r \<and>
        t \<le> n \<and> relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')))" (is "?L = (\<forall>h as n. ?H h as n \<longrightarrow> (\<exists>h' t r. _ \<and> ?P h as h' n t r))")
proof -
  have "?L = (\<forall>h as n. pHeap h as n \<Turnstile> P \<longrightarrow>
                  (\<forall> \<sigma> t r. run c (Some h) \<sigma> r t \<longrightarrow> \<sigma> \<noteq> None \<and> (?P h as (the \<sigma>) n t r)))"
    unfolding hoare_triple_def by auto
  also have "\<dots> =  (\<forall>h as n. pHeap h as n \<Turnstile> P \<longrightarrow>
              (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                         ?P h as h' n t r))" apply(subst run_and_execute) by simp
  finally show ?thesis .
qed

lemma extract_cost_otherway:
  assumes
    "\<Gamma> * $Cost_lb \<Longrightarrow>\<^sub>A G * F"
    "<G> c <\<lambda>r. Q r >"
    "\<And>r. Q r * F \<Longrightarrow>\<^sub>A \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up>(ra \<in> dom M)) * true"
    "(\<And>c. c\<in>ran M \<Longrightarrow> Cost_lb \<le> c)"
  shows "hn_refine \<Gamma> c \<Gamma>' R (REST M)"
proof -
  note pre_rule[OF assms(1) frame_rule[OF assms(2)]]
  then have TR: "\<And>h as n. pHeap h as n \<Turnstile> \<Gamma> * $ Cost_lb \<Longrightarrow>
           (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                     pHeap h' (new_addrs h as h') (n - t) \<Turnstile> Q r * F \<and> t \<le> n \<and> relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')"
    unfolding hoare_alt by simp

  show ?thesis
    unfolding hn_refine_def apply auto
  proof -
    fix h as n
    assume "pHeap h as n \<Turnstile> \<Gamma>"
    then have "pHeap h as (n+Cost_lb) \<Turnstile> \<Gamma> * $ Cost_lb"
      by (simp add: mod_timeCredit_dest)
    from TR[OF this] obtain h' t r where "execute c h = Some (r, h', t)"
           and h: "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile> Q r * F"
           and 3: "t \<le> n + Cost_lb" "relH {a. a < heap.lim h \<and> a \<notin> as} h h'" "heap.lim h \<le> heap.lim h'"
      by blast

    from h assms(3) have h': "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (ra \<in> dom M)) * true"
      by (simp add: entails_def)
    then have "\<exists>ra. pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' *  R ra r * \<up> (ra \<in> dom M) * true"
      by(simp add: ex_distrib_star' ex_distrib_star[symmetric] mod_ex_dist assn_times_assoc)
    then obtain ra where h'': "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' *  R ra r * \<up> (ra \<in> dom M) * true"
        by blast
    have "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   (\<Gamma>' *  R ra r * true) * \<up> (ra \<in> dom M)"
      apply(rule entailsD[OF _ h''])  by (simp add: entails_triv move_back_pure')
    then have h'': "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' *  R ra r * true" and radom: "ra \<in> dom M"
      using mod_pure_star_dist  by auto

    show "\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                       (\<exists>ra Ca. Some (enat Ca) \<le> M ra \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true) \<and>
                       relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'"
      apply(rule exI[where x=h']) apply(rule exI[where x=t]) apply(rule exI[where x=r])
      apply safe apply fact
          apply(rule exI[where x=ra])
        apply(rule exI[where x=Cost_lb])
        apply safe
      subgoal using assms(4) radom using ranI by force
      subgoal by fact
      subgoal using h'' mod_star_trueI by blast
       apply fact apply fact done
  qed
qed

end


theory Example_Semantics
imports "../Call_Return_Unfolding" "../Primitive_Matchers/Common_Primitive_Matcher"
begin

section\<open>Examples Big Step Semantics\<close>
text\<open>We use a primitive matcher which always applies. We don't care about matching in this example.\<close>
  fun applies_Yes :: "('a, 'p) matcher" where
  "applies_Yes m p = True"

  definition "m=Match (Src (IpAddr (0::ipv4addr)))"
  lemma[simp]: "Semantics.matches applies_Yes m p" by (simp add: m_def)

  lemma "[''FORWARD'' \<mapsto> [(Rule m Log), (Rule m Accept), (Rule m Drop)]],applies_Yes,p\<turnstile>
      \<langle>[Rule MatchAny (Call ''FORWARD'')], Undecided\<rangle> \<Rightarrow> (Decision FinalAllow)"
  apply(rule call_result)
    apply(auto)
  apply(rule seq_cons)
   apply(auto intro:Semantics.log)
  apply(rule seq_cons)
   apply(auto intro: Semantics.accept)
  apply(rule Semantics.decision)
  done

  lemma "[''FORWARD'' \<mapsto> [(Rule m Log), (Rule m (Call ''foo'')), (Rule m Accept)],
          ''foo'' \<mapsto> [(Rule m Log), (Rule m Return)]],applies_Yes,p\<turnstile>
      \<langle>[Rule MatchAny (Call ''FORWARD'')], Undecided\<rangle> \<Rightarrow> (Decision FinalAllow)"
  apply(rule call_result)
    apply(auto)
  apply(rule seq_cons)
   apply(auto intro: Semantics.log)
  apply(rule seq_cons)
   apply(rule Semantics.call_return[where rs\<^sub>1="[Rule m Log]" and rs\<^sub>2="[]"])
      apply(simp)+
   apply(auto intro: Semantics.log)
  apply(auto intro: Semantics.accept)
  done

  lemma "[''FORWARD'' \<mapsto> [Rule m (Call ''foo''), Rule m Drop], ''foo'' \<mapsto> []],applies_Yes,p\<turnstile>
            \<langle>[Rule MatchAny (Call ''FORWARD'')], Undecided\<rangle> \<Rightarrow> (Decision FinalDeny)"
  apply(rule call_result)
    apply(auto)
  apply(rule Semantics.seq_cons)
   apply(rule Semantics.call_result)
     apply(auto)
   apply(rule Semantics.skip)
  apply(auto intro: deny)
  done

  lemma "((\<lambda>rs. process_call [''FORWARD'' \<mapsto> [Rule m (Call ''foo''), Rule m Drop], ''foo'' \<mapsto> []] rs)^^2)
                    [Rule MatchAny (Call ''FORWARD'')]
         = [Rule (MatchAnd MatchAny m) Drop]" by eval

  hide_const m

  definition "pkt=\<lparr>p_iiface=''+'', p_oiface=''+'', p_src=0, p_dst=0,
                   p_proto=TCP, p_sport=0, p_dport=0, p_tcp_flags = {TCP_SYN},
                   p_payload='''',p_tag_ctstate= CT_New\<rparr>"

  text\<open>We tune the primitive matcher to support everything we need in the example. Note that the undefined cases cannot be handled with these exact semantics!\<close>
  fun applies_exampleMatchExact :: "(32 common_primitive, 32 tagged_packet) matcher" where
  "applies_exampleMatchExact (Src (IpAddr addr)) p \<longleftrightarrow> p_src p = addr" |
  "applies_exampleMatchExact (Dst (IpAddr addr)) p \<longleftrightarrow> p_dst p = addr" |
  "applies_exampleMatchExact (Prot ProtoAny) p \<longleftrightarrow> True" |
  "applies_exampleMatchExact (Prot (Proto pr)) p \<longleftrightarrow> p_proto p = pr"
  (* not exhaustive, only an example!!*)

  lemma "[''FORWARD'' \<mapsto> [ Rule (MatchAnd (Match (Src (IpAddr 0))) (Match (Dst (IpAddr 0)))) Reject,
                          Rule (Match (Dst (IpAddr 0))) Log,
                          Rule (Match (Prot (Proto TCP))) Accept,
                          Rule (Match (Prot (Proto TCP))) Drop]
         ],applies_exampleMatchExact, pkt\<lparr>p_src:=(ipv4addr_of_dotdecimal (1,2,3,4)), p_dst:=(ipv4addr_of_dotdecimal (0,0,0,0))\<rparr>\<turnstile>
            \<langle>[Rule MatchAny (Call ''FORWARD'')], Undecided\<rangle> \<Rightarrow> (Decision FinalAllow)"
  apply(rule call_result)
    apply(auto)
  apply(rule Semantics.seq_cons)
   apply(auto intro: Semantics.nomatch simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
  apply(rule Semantics.seq_cons)
   apply(auto intro: Semantics.log simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
  apply(rule Semantics.seq_cons)
   apply(auto simp add: pkt_def intro: Semantics.accept)
  apply(auto intro: Semantics.decision)
  done

end


(*  Title:      HOL/Auth/n_mutualEx_on_ini.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_mutualEx Protocol Case Study*}

theory n_mutualEx_on_ini imports n_mutualEx_base
begin
lemma iniImply_inv__1:
assumes a1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__1  p__Inv0 p__Inv1)"
and a2: "formEval (andList (allInitSpecs N)) s"
shows "formEval f s"
using a1 a2 by auto

lemma iniImply_inv__2:
assumes a1: "(\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__2  p__Inv0)"
and a2: "formEval (andList (allInitSpecs N)) s"
shows "formEval f s"
using a1 a2 by auto

lemma iniImply_inv__3:
assumes a1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)"
and a2: "formEval (andList (allInitSpecs N)) s"
shows "formEval f s"
using a1 a2 by auto

lemma iniImply_inv__4:
assumes a1: "(\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__4  p__Inv0)"
and a2: "formEval (andList (allInitSpecs N)) s"
shows "formEval f s"
using a1 a2 by auto

lemma iniImply_inv__5:
assumes a1: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__5  p__Inv0 p__Inv1)"
and a2: "formEval (andList (allInitSpecs N)) s"
shows "formEval f s"
using a1 a2 by auto
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)
 *)

theory CommonOpsLemmas

imports
  "CommonOps"
        "../../lib/$L4V_ARCH/WordSetup"
begin

lemma fold_all_htd_updates':
  "ptr_retyp (p :: ('a :: c_type) ptr)
    = all_htd_updates TYPE('a) 1 (ptr_val p) 1"
  "(if P then (f :: heap_typ_desc \<Rightarrow> heap_typ_desc) else g) s
    = (if P then f s else g s)"
  "\<lbrakk> n < 2 ^ 32 \<rbrakk> \<Longrightarrow>
    ptr_retyps n p = all_htd_updates TYPE('a) 1 (ptr_val p) (of_nat n)"
  "\<lbrakk> n < 2 ^ 32 \<rbrakk> \<Longrightarrow>
    ptr_retyps (2 ^ n) p = all_htd_updates TYPE('a) 3 (ptr_val p) (of_nat n)"
  "n < 2 ^ 32 \<Longrightarrow> typ_clear_region x n = all_htd_updates TYPE(word32) 0 x (of_nat n)"
  "n < 2 ^ 32 \<Longrightarrow> typ_region_bytes x n = all_htd_updates TYPE(word32) 2 x (of_nat n)"
  "\<lbrakk> n < 2 ^ 32 \<rbrakk> \<Longrightarrow>
    ptr_arr_retyps n p = all_htd_updates TYPE('a) 4 (ptr_val p) (of_nat n)"
  "\<lbrakk> n < 2 ^ 32 \<rbrakk> \<Longrightarrow>
    ptr_arr_retyps (2 ^ n) p = all_htd_updates TYPE('a) 5 (ptr_val p) (of_nat n)"
  by (simp_all add: all_htd_updates_def unat_of_nat fun_eq_iff of_nat_neq_0)

lemma unat_lt2p_word32:
  "unat (w :: word32) < 2 ^ 32"
  by (rule order_less_le_trans, rule unat_lt2p, simp)

lemmas fold_all_htd_updates
    = fold_all_htd_updates' fold_all_htd_updates'(3-)[OF unat_lt2p_word32]

lemma signed_div_range_check:
  assumes len: "size a > 1"
  shows
  "(sint a sdiv sint b = sint (a sdiv b))
    = (a \<noteq> (- (2 ^ (size a - 1))) \<or> b \<noteq> -1)"
proof -
  have sints: "(sint (1 :: 'a word)) = 1"
       "(sint (-1 :: 'a word)) = -1"
       "(sint (0 :: 'a word)) = 0"
    using len
    apply (simp_all add: word_size)
    done
  have abs_sint_gt_1:
    "b \<noteq> 0 \<and> b \<noteq> 1 \<and> b \<noteq> -1 \<Longrightarrow> abs (sint b) > 1"
    apply (fold word_sint.Rep_inject,
        simp only: sints abs_if split: if_split)
    apply arith
    done
  have mag: "(a \<noteq> (- (2 ^ (size a - 1))) \<or> (b \<noteq> -1 \<and> b \<noteq> 1))
    \<Longrightarrow> abs (abs (sint a) div abs (sint b)) < 2 ^ (size a - 1)"
    using word_sint.Rep_inject[where x=a and y="- (2 ^ (size a - 1))"]
          word_sint.Rep_inject[where x=b and y=1]
    apply (simp add: word_size sint_int_min sints)
    apply (simp add: nonneg_mod_div)
    apply (cases "b = 0")
     apply simp
    apply (erule impCE)
     apply (rule order_le_less_trans, rule zdiv_le_dividend, simp_all)
     apply (cut_tac x=a in sint_range')
     apply (clarsimp simp add: abs_if word_size)
    apply (cases "a = 0", simp_all)
    apply (rule order_less_le_trans, rule int_div_less_self, simp_all)
     apply (rule abs_sint_gt_1, simp)
    apply (cut_tac x=a in sint_range')
    apply (clarsimp simp add: abs_if word_size)
    done
  show ?thesis using mag len
    apply (cases "b = 1")
     apply (case_tac "size a", simp_all)[1]
     apply (case_tac nat, simp_all add: sint_word_ariths word_size)[1]
    apply (simp add: sdiv_int_def sdiv_word_def sint_sbintrunc'
                     sbintrunc_eq_in_range range_sbintrunc sgn_if)
    apply (safe, simp_all add: word_size sint_int_min)
    done
qed

lemma ptr_add_assertion_uintD:
  "ptr_add_assertion ptr (uint (x :: ('a :: len) word)) strong htd
    \<longrightarrow> (x = 0 \<or> array_assertion ptr (if strong then unat (x + 1) else unat x) htd)"
  using unat_lt2p[where x=x]
  by (simp add: ptr_add_assertion_def uint_0_iff Word.unat_def[symmetric]
                unat_plus_if_size linorder_not_less word_size
                le_Suc_eq array_assertion_shrink_right
           del: unat_lt2p)

lemma sint_uint_sless_0_if:
  "sint x = (if x <s 0 then - uint (- x) else uint (x :: ('a :: len) word))"
  apply (simp add: word_sint_msb_eq word_sless_alt
                   word_size uint_word_ariths)
  apply (clarsimp simp: zmod_zminus1_eq_if uint_0_iff)
  done

lemma ptr_add_assertion_sintD:
  "ptr_add_assertion ptr (sint (x :: ('a :: len) word)) strong htd
    \<longrightarrow> (x = 0 \<or> (x <s 0 \<and> array_assertion (ptr +\<^sub>p sint x)
            (unat (- x)) htd)
        \<or> (x \<noteq> 0 \<and> \<not> x <s 0 \<and> array_assertion ptr (if strong then unat (x + 1) else unat x) htd))"
  using unat_lt2p[where x=x]
  apply (simp add: ptr_add_assertion_def word_sless_alt
                   sint_uint_sless_0_if[THEN arg_cong[where f="\<lambda>x. - x"]]
                   sint_uint_sless_0_if[THEN arg_cong[where f=nat]]
                   Word.unat_def[symmetric]
                   unat_plus_if_size le_Suc_eq linorder_not_less
                   word_size
           del: unat_lt2p)
  apply (simp add: array_assertion_shrink_right)
  apply (auto simp: linorder_not_less)
  done

end


(*  Title:      HOL/Auth/n_german_lemma_on_inv__51.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_on_inv__51 imports n_german_base
begin
section{*All lemmas on causal relation between inv__51 and some rule r*}
lemma n_RecvInvAckVsinv__51:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv1 p__Inv2 where a2:"p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv1)\<or>(i~=p__Inv1\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i=p__Inv1)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i~=p__Inv1\<and>i~=p__Inv2)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__51:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv1 p__Inv2 where a2:"p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv1)\<or>(i~=p__Inv1\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv1)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv1\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__51:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv1 p__Inv2 where a2:"p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv1)\<or>(i~=p__Inv1\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv1)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv1\<and>i~=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendReqE__part__1Vsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_StoreVsinv__51:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvGntSVsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvGntS  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqEVsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE N i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvGntEVsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvGntE  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendInvAckVsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInvAck  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendInv__part__0Vsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqE__part__0Vsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendInv__part__1Vsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqS  i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqSVsinv__51:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqS N i" and
  a2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

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

(* License: BSD, terms see file ./LICENSE *)

theory Vanilla32
imports "../../lib/WordLib" CTypes
begin

section "Words and Pointers"

instantiation unit :: c_type
begin
instance ..
end

definition "unit_tag \<equiv> TypDesc (TypScalar 1 0
      (\<lparr> field_access = (\<lambda>v bs. [0]), field_update = (\<lambda>bs v. ())\<rparr>)) ''unit''"

declare unit_tag_def [simp]

defs (overloaded)
  typ_info_unit [simp]: "typ_info_t (x::unit itself) \<equiv> unit_tag"

instantiation unit :: mem_type
begin
  definition
    to_bytes_unit :: "unit \<Rightarrow> byte list" where
    "to_bytes_unit a \<equiv> [0]"

  definition
    from_bytes_unit :: "byte list \<Rightarrow> unit" where
    "from_bytes_unit bs \<equiv> ()"

  definition
    size_of_unit :: "unit itself \<Rightarrow> nat" where
    "size_of_unit x \<equiv> 0"

  definition
    align_of_unit :: "unit itself \<Rightarrow> nat" where
    "align_of_unit x \<equiv> 1"

  instance
    apply intro_classes
    apply (auto simp: size_of_def align_of_def align_field_def addr_card
                      wf_lf_def fd_cons_desc_def
                      fd_cons_double_update_def fd_cons_update_access_def
                      fd_cons_access_update_def fd_cons_length_def)
  done
end

definition
  "bogus_log2lessthree (n::nat) ==
             if n = 64 then (3::nat)
             else if n = 32 then 2
             else if n = 16 then 1
             else if n = 8 then 0
             else undefined"
definition
  "len_exp (x::('a::len) itself) \<equiv> bogus_log2lessthree (len_of TYPE('a))"

lemma lx8' [simp] : "len_exp (x::8 itself) = 0"
by (simp add: len_exp_def bogus_log2lessthree_def)

lemma lx16' [simp]: "len_exp (x::16 itself) = 1"
by (simp add: len_exp_def bogus_log2lessthree_def)

lemma lx32' [simp]: "len_exp (x::32 itself) = 2"
by (simp add: len_exp_def bogus_log2lessthree_def)

lemma lx64' [simp]: "len_exp (x::64 itself) = 3"
by (simp add: len_exp_def bogus_log2lessthree_def)

lemma lx_signed' [simp]: "len_exp (x::('a::len) signed itself) = len_exp (TYPE('a))"
  by (simp add: len_exp_def)

class len8 = len +
  (* this constraint gives us (in the most convoluted way possible) that we're only
     interested in words with a length that is divisible by 8 *)
  assumes len8_bytes: "len_of TYPE('a::len) = 8 * (2^len_exp TYPE('a))"
  (* len8_len class gives us that the words are \<le> than 128 bits.
     This is a wacky restriction really, but we're really only interested in words
     up to 64 bits, so who cares. *)
  assumes len8_width: "len_of TYPE('a::len) \<le> 128"
begin

lemma len8_size:
  "len_of TYPE('a) div 8 < addr_card"
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply(simp add: addr_card)
apply(rule len8_width)
done

lemma len8_dv8:
  "8 dvd len_of TYPE('a)"
  by (simp add: len8_bytes)

lemma len8_pow:
  "\<exists>k. len_of TYPE('a) div 8 = 2^k"
  by (simp add: len8_bytes)

end

fun
  nat_to_bin_string :: "nat \<Rightarrow> char list"
  where
  ntbs: "nat_to_bin_string n = (if (n = 0) then ''0'' else (if n mod 2 = 1 then CHR ''1'' else CHR ''0'') # nat_to_bin_string (n div 2))"

declare nat_to_bin_string.simps [simp del]

lemma nat_to_bin_string_simps:
  "nat_to_bin_string 0 = ''0''"
  "n > 0 \<Longrightarrow> nat_to_bin_string n =
      (if n mod 2 = 1 then CHR ''1'' else CHR ''0'') # nat_to_bin_string (n div 2)"
  apply (induct n, auto simp: nat_to_bin_string.simps)
  done

(* Little-endian encoding *)
definition
  word_tag :: "'a::len8 word itself \<Rightarrow> 'a word typ_info"
where
  "word_tag (w::'a::len8 word itself) \<equiv> TypDesc (TypScalar (len_of TYPE('a) div 8) (len_exp TYPE('a)) \<lparr> field_access = \<lambda>v bs. (rev o word_rsplit) v, field_update = \<lambda>bs v. (word_rcat (rev bs)::'a::len8 word) \<rparr>)  (''word'' @  nat_to_bin_string (len_of TYPE('a)) )"

instantiation word :: (len8) c_type
begin
instance ..
end

instance signed :: (len8) len8
  apply intro_classes
   apply (metis len8_bytes len_exp_def len_signed)
  apply (metis len8_width len_signed)
  done

defs (overloaded)
  typ_info_word: "typ_info_t (w::'a::len8 word itself) \<equiv> word_tag w"

defs (overloaded)
  typ_name_itself_word: "typ_name_itself (w::'a::len8 word itself) \<equiv> typ_name (typ_info_t w)"

lemma align_of_word:
  "align_of TYPE('a::len8 word) = len_of TYPE('a) div 8"
  by (simp add: align_of_def typ_info_word word_tag_def len8_bytes)

instantiation word :: (len8) mem_type
begin

instance
proof intro_classes
  show "\<And>bs v w. length bs = size_of TYPE('a word) \<longrightarrow>
       update_ti_t (typ_info_t TYPE('a word)) bs v =
       update_ti_t (typ_info_t TYPE('a word)) bs w"
    by (simp add: typ_info_word word_tag_def size_of_def)
next
  show "wf_desc (typ_info_t TYPE('a word))"
    by (simp add: typ_info_word word_tag_def)
next
  have "8 dvd len_of TYPE('a)" by (rule len8_dv8)
  moreover have "0 < len_of TYPE('a)" by simp
  ultimately have "0 < len_of TYPE('a) div 8" by - (erule dvdE, simp)
  thus "wf_size_desc (typ_info_t TYPE('a word))"
    by (simp add: typ_info_word word_tag_def len8_pow)
next
  have "8 dvd len_of TYPE('a)" by (rule len8_dv8)
  thus "wf_lf (lf_set (typ_info_t TYPE('a word)) [])"
  by (auto simp: typ_info_word word_tag_def wf_lf_def
    fd_cons_def fd_cons_double_update_def fd_cons_update_access_def
    word_rcat_rsplit fd_cons_access_update_def fd_cons_length_def
    length_word_rsplit_exp_size' word_size fd_cons_update_normalise_def
    fd_cons_desc_def
    field_norm_def elim: dvdE)
next
  show "size_of TYPE('a word) < addr_card"
    by (simp add: size_of_def typ_info_word word_tag_def)
       (rule len8_size)
next
  show "align_of TYPE('a word) dvd size_of TYPE('a word)"
    by (clarsimp simp: size_of_def align_of_word typ_info_word
                       word_tag_def)
next
  show "align_field (typ_info_t TYPE('a word))"
    by (clarsimp simp: typ_info_word word_tag_def align_field_def)
qed

end

instantiation word :: (len8) simple_mem_type
begin

instance
  apply intro_classes
  apply(clarsimp simp: typ_info_word word_tag_def typ_uinfo_t_def)
  done

end

class len_eq1 = len +
  assumes len_eq1: "len_of TYPE('a::len) = 1"
instance num1 :: len_eq1
by (intro_classes, simp)

(* naming scheme len_lg<digit1><digit2> means the log of the length is between
   digit1 and digit2 inclusive *)
class len_lg01 = len +
  assumes len_lg01: "len_of TYPE('a::len) \<in> {1,2}"
instance bit0 :: (len_eq1) len_lg01
by (intro_classes, simp add: len_eq1)
instance num1 :: len_lg01
by (intro_classes, simp)

class len_lg02 = len +
  assumes len_lg02: "len_of TYPE('a::len) \<in> {1,2,4}"
instance bit0 :: (len_lg01) len_lg02
apply intro_classes
apply (insert len_lg01[where 'a = 'a])
apply simp
done
instance num1 :: len_lg02
by (intro_classes, simp)

class len_lg03 = len +
  assumes len_lg03: "len_of TYPE('a::len) \<in> {1,2,4,8}"
instance bit0 :: (len_lg02) len_lg03
apply intro_classes
apply (insert len_lg02[where 'a = 'a])
apply simp
done
instance num1 :: len_lg03
by (intro_classes, simp)

class len_lg14 = len +
  assumes len_lg14: "len_of TYPE('a::len) \<in> {2,4,8,16}"
instance bit0 :: (len_lg03) len_lg14
apply intro_classes
apply (insert len_lg03[where 'a = 'a])
apply simp
done

class len_lg25 = len +
  assumes len_lg25: "len_of TYPE('a::len) \<in> {4,8,16,32}"
instance bit0 :: (len_lg14) len_lg25
apply intro_classes
apply (insert len_lg14[where 'a = 'a])
apply simp
done

instance bit0 :: (len_lg25) len8
apply intro_classes
  apply simp
  apply (insert len_lg25[where 'a = 'a])
  apply (simp add: len_exp_def)
  apply (erule disjE)
    apply (simp add: bogus_log2lessthree_def len8_bytes len8_width)
  apply (erule disjE)
    apply (simp add: bogus_log2lessthree_def)
  apply (erule disjE)
    apply (simp add: bogus_log2lessthree_def)
  apply (simp add: bogus_log2lessthree_def)
apply simp
apply auto
done

instance signed :: (len_eq1) len_eq1     using len_eq1  by (intro_classes, simp)
instance signed :: (len_lg01) len_lg01   using len_lg01 by (intro_classes, simp)
instance signed :: (len_lg02) len_lg02   using len_lg02 by (intro_classes, simp)
instance signed :: (len_lg03) len_lg03   using len_lg03 by (intro_classes, simp)
instance signed :: (len_lg14) len_lg14   using len_lg14 by (intro_classes, simp)
instance signed :: (len_lg25) len_lg25   using len_lg25 by (intro_classes, simp)

lemma
  "to_bytes (1*256*256*256 + 2*256*256 + 3*256 + (4::32 word)) bs = [4, 3, 2, 1]"
  by (simp add: to_bytes_def typ_info_word word_tag_def Let_def)

lemma size_td_words [simp]:
  "size_td (typ_info_t TYPE(8 word)) = 1"
  "size_td (typ_info_t TYPE(16 word)) = 2"
  "size_td (typ_info_t TYPE(32 word)) = 4"
  "size_td (typ_info_t TYPE(64 word)) = 8"
  by (auto simp: typ_info_word word_tag_def)

lemma align_td_words [simp]:
  "align_td (typ_info_t TYPE(8 word)) = 0"
  "align_td (typ_info_t TYPE(16 word)) = 1"
  "align_td (typ_info_t TYPE(32 word)) = 2"
  "align_td (typ_info_t TYPE(64 word)) = 3"
  by (auto simp: typ_info_word word_tag_def len8_bytes)

lemma size_of_words [simp]:
  "size_of TYPE(8 word) = 1"
  "size_of TYPE(16 word) = 2"
  "size_of TYPE(32 word) = 4"
  "size_of TYPE(64 word) = 8"
  by (auto simp: size_of_def)

lemma align_of_words [simp]:
  "align_of TYPE(8 word) = 1"
  "align_of TYPE(16 word) = 2"
  "align_of TYPE(32 word) = 4"
  "align_of TYPE(64 word) = 8"
  by (auto simp: align_of_word)

lemma size_td_swords [simp]:
  "size_td (typ_info_t TYPE(8 sword)) = 1"
  "size_td (typ_info_t TYPE(16 sword)) = 2"
  "size_td (typ_info_t TYPE(32 sword)) = 4"
  "size_td (typ_info_t TYPE(64 sword)) = 8"
  by (auto simp: typ_info_word word_tag_def)

lemma align_td_swords [simp]:
  "align_td (typ_info_t TYPE(8 sword)) = 0"
  "align_td (typ_info_t TYPE(16 sword)) = 1"
  "align_td (typ_info_t TYPE(32 sword)) = 2"
  "align_td (typ_info_t TYPE(64 sword)) = 3"
  by (auto simp: typ_info_word word_tag_def len8_bytes)

lemma size_of_swords [simp]:
  "size_of TYPE(8 sword) = 1"
  "size_of TYPE(16 sword) = 2"
  "size_of TYPE(32 sword) = 4"
  "size_of TYPE(64 sword) = 8"
  by (auto simp: size_of_def)

lemma align_of_swords [simp]:
  "align_of TYPE(8 sword) = 1"
  "align_of TYPE(16 sword) = 2"
  "align_of TYPE(32 sword) = 4"
  "align_of TYPE(64 sword) = 8"
  by (auto simp: align_of_word)

instantiation ptr :: (type) c_type
begin
instance ..
end

defs (overloaded)
  typ_info_ptr:
  "typ_info_t (p::'a::c_type ptr itself) \<equiv> TypDesc
    (TypScalar 4 2 \<lparr> field_access = \<lambda>p bs. rev (word_rsplit (ptr_val p)),
        field_update = \<lambda>bs v. Ptr (word_rcat (rev bs)::addr) \<rparr> )
    (typ_name_itself TYPE('a) @ ''+ptr'')"

defs (overloaded)
  typ_name_itself_ptr:
  "typ_name_itself (p::'a::c_type ptr itself) \<equiv>
    typ_name_itself TYPE('a) @ ''+ptr''"

defs (overloaded)
  typ_name_itself_unit [simp]:
  "typ_name_itself (p::unit itself) \<equiv> ''void''"

lemma align_of_ptr [simp]:
  "align_of (p::'a::c_type ptr itself) = 4"
  by (simp add: align_of_def typ_info_ptr)

instantiation ptr :: (c_type) mem_type
begin
instance
  apply (intro_classes)
    apply (auto simp:  to_bytes_def from_bytes_def
                 length_word_rsplit_exp_size' word_size
                 word_rcat_rsplit size_of_def  addr_card
                 typ_info_ptr fd_cons_double_update_def
                 fd_cons_update_access_def fd_cons_access_update_def
                 fd_cons_length_def fd_cons_update_normalise_def field_norm_def
                 super_update_bs_def word_rsplit_rcat_size norm_bytes_def
                 fd_consistent_def fd_cons_def wf_lf_def
                 fd_cons_desc_def align_field_def)
  done
end

instantiation ptr :: (c_type) simple_mem_type
begin
instance
  apply intro_classes
  apply(clarsimp simp: typ_info_ptr typ_uinfo_t_def)
  done
end

lemma size_td_ptr [simp]:
  "size_td (typ_info_t TYPE('a::c_type ptr)) = 4"
  by (simp add: typ_info_ptr)

lemma size_of_ptr [simp]:
  "size_of TYPE('a::c_type ptr) = 4"
  by (simp add: size_of_def)

lemma align_td_ptr [simp]: "align_td (typ_info_t TYPE('a::c_type ptr)) = 2"
  by (simp add: typ_info_ptr)

lemma ptr_add_word32_signed [simp]:
  fixes a :: "32 word ptr"
  shows "ptr_val (a +\<^sub>p x) = ptr_val a + 4 * of_int x"
  by (cases a) (simp add: ptr_add_def scast_id)

lemma ptr_add_word32 [simp]:
  fixes a :: "32 word ptr" and x :: "32 word"
  shows "ptr_val (a +\<^sub>p uint x) = ptr_val a + 4 * x"
  by (cases a) (simp add: ptr_add_def scast_id)

lemma ptr_add_0_id[simp]:"x +\<^sub>p 0 = x"
  by (clarsimp simp:ptr_add_def)

lemma from_bytes_ptr_to_bytes_ptr:
  "from_bytes (to_bytes (v::32 word) bs) = (Ptr v :: 'a::c_type ptr)"
  by (simp add: from_bytes_def to_bytes_def typ_info_ptr word_tag_def
                typ_info_word word_size
                length_word_rsplit_exp_size' word_rcat_rsplit)

lemma ptr_aligned_coerceI:
  "ptr_aligned (ptr_coerce x::32 word ptr) \<Longrightarrow>
      ptr_aligned (x::'a::mem_type ptr ptr)"
  by (simp add: ptr_aligned_def)

lemma lift_ptr_ptr [simp]:
  "\<And>p::'a::mem_type ptr ptr.
  lift h (ptr_coerce p) = ptr_val (lift h p)"
  by (simp add: lift_def h_val_def from_bytes_def
                typ_info_word word_tag_def typ_info_ptr)

lemmas Vanilla32_tags [simp] =
  typ_info_word typ_info_ptr typ_name_itself_ptr word_tag_def
  typ_name_itself_word

lemma ptr_typ_name [simp]:
  "typ_name (typ_info_t TYPE(('a :: c_type) ptr)) =  typ_name_itself TYPE('a) @ ''+ptr'' "
  by simp

lemma word_typ_name [simp]:
  "typ_name (typ_info_t TYPE('a::len8 word)) = ''word'' @ nat_to_bin_string (len_of TYPE('a))"
  by simp

lemma typ_name_words [simp]:
   "typ_name (typ_uinfo_t TYPE(8 word))  = ''word00010''"
   "typ_name (typ_uinfo_t TYPE(16 word)) = ''word000010''"
   "typ_name (typ_uinfo_t TYPE(32 word)) = ''word0000010''"
   "typ_name (typ_uinfo_t TYPE(64 word)) = ''word00000010''"
   "typ_name (typ_info_t  TYPE(8 word))  = ''word00010''"
   "typ_name (typ_info_t  TYPE(16 word)) = ''word000010''"
   "typ_name (typ_info_t  TYPE(32 word)) = ''word0000010''"
   "typ_name (typ_info_t  TYPE(64 word)) = ''word00000010''"
  by (auto simp: typ_uinfo_t_def nat_to_bin_string.simps)

lemma typ_name_swords [simp]:
   "typ_name (typ_uinfo_t TYPE(8 sword))  = ''word00010''"
   "typ_name (typ_uinfo_t TYPE(16 sword)) = ''word000010''"
   "typ_name (typ_uinfo_t TYPE(32 sword)) = ''word0000010''"
   "typ_name (typ_uinfo_t TYPE(64 sword)) = ''word00000010''"
   "typ_name (typ_info_t  TYPE(8 sword))  = ''word00010''"
   "typ_name (typ_info_t  TYPE(16 sword)) = ''word000010''"
   "typ_name (typ_info_t  TYPE(32 sword)) = ''word0000010''"
   "typ_name (typ_info_t  TYPE(64 sword)) = ''word00000010''"
  by (auto simp: typ_uinfo_t_def nat_to_bin_string.simps)

lemma ptr_arith[simp]:
  "(x +\<^sub>p a = y +\<^sub>p a) = ((x::('a::c_type) ptr) = (y::'a ptr))"
  by (clarsimp simp:ptr_add_def)

lemma ptr_arith'[simp]:
  "(ptr_coerce (x +\<^sub>p a) = ptr_coerce (y +\<^sub>p a)) = ((x::('a::c_type) ptr) = (y::'a ptr))"
  by (clarsimp simp:ptr_add_def)

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

(* License: BSD, terms see file ./LICENSE *)

theory ArrayAssertion

imports
  "ArraysMemInstance"
  "StructSupport"

begin

lemma array_tag_n_eq:
  "(array_tag_n n :: ('a :: c_type['b :: finite]) field_desc typ_desc) =
  TypDesc (TypAggregate
    (map (\<lambda>n. DTPair (adjust_ti (typ_info_t TYPE('a)) (\<lambda>x. index x n)
            (\<lambda>x f. Arrays.update f n x)) (replicate n CHR ''1'')) [0..<n]))
  (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @ nat_to_bin_string (card (UNIV :: 'b :: finite set)))"
  apply (induct n)
   apply (simp add: typ_info_array array_tag_def eval_nat_numeral array_tag_n.simps empty_typ_info_def)
   apply (simp add: typ_info_array array_tag_def eval_nat_numeral array_tag_n.simps empty_typ_info_def)
   apply (simp add: ti_typ_combine_def Let_def)
   done

lemma typ_info_array':
  "typ_info_t TYPE ('a :: c_type['b :: finite]) =
  TypDesc (TypAggregate
    (map (\<lambda>n. DTPair (adjust_ti (typ_info_t TYPE('a)) (\<lambda>x. index x n)
            (\<lambda>x f. Arrays.update f n x)) (replicate n CHR ''1'')) [0..<(card (UNIV :: 'b :: finite set))]))
  (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @ nat_to_bin_string (card (UNIV :: 'b :: finite set)))"
  by (simp add: typ_info_array array_tag_def array_tag_n_eq)

definition
  "uinfo_array_tag_n_m (v :: 'a itself) n m = TypDesc
    (TypAggregate (map (\<lambda>i. DTPair (typ_uinfo_t TYPE('a)) (replicate i CHR ''1'')) [0 ..< n]))
    (typ_name (typ_uinfo_t TYPE('a :: c_type)) @ ''_array_'' @ nat_to_bin_string m)"

lemma map_td_list_map:
  "map_td_list f = map (map_td_pair f)"
  apply (rule ext)
  apply (induct_tac x, simp_all)
  done

lemma uinfo_array_tag_n_m_eq:
  "n \<le> CARD('b)
    \<Longrightarrow> export_uinfo (array_tag_n n :: (('a :: wf_type)['b :: finite]) field_desc typ_desc)
        = uinfo_array_tag_n_m TYPE ('a) n (CARD('b))"
  apply (clarsimp simp: uinfo_array_tag_n_m_def array_tag_n_eq
                        map_td_list_map o_def adjust_ti_def map_td_map)
  apply (simp add: typ_uinfo_t_def export_uinfo_def)
  apply (rule map_td_extI)
   apply simp
  apply (clarsimp simp: field_norm_blah)
  done

lemma typ_uinfo_array_tag_n_m_eq:
  "typ_uinfo_t TYPE (('a :: wf_type)['b :: finite])
        = uinfo_array_tag_n_m TYPE ('a) (CARD('b)) (CARD('b))"
  by (simp add: typ_uinfo_t_def typ_info_array array_tag_def
                uinfo_array_tag_n_m_eq)

text {* Alternative to h_t_valid for arrays. This allows reasoning
about arrays of variable width. *}
definition
  h_t_array_valid :: "heap_typ_desc \<Rightarrow> ('a :: c_type) ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "h_t_array_valid htd ptr n = valid_footprint htd (ptr_val ptr) (uinfo_array_tag_n_m TYPE ('a) n n)"

text {* Assertion that pointer p is within an array that continues
for at least n more elements. *}
definition
  "array_assertion (p :: ('a :: c_type) ptr) n htd
    = (\<exists>q i j. h_t_array_valid htd q j
        \<and> p = CTypesDefs.ptr_add q (int i) \<and> i < j \<and> i + n \<le> j)"

lemma array_assertion_shrink_right:
  "array_assertion p n htd \<Longrightarrow> n' \<le> n \<Longrightarrow> array_assertion p n' htd"
  by (fastforce simp: array_assertion_def)

lemma array_assertion_shrink_leftD:
  "array_assertion p n htd \<Longrightarrow> j < n \<Longrightarrow> array_assertion (CTypesDefs.ptr_add p (int j)) (n - j) htd"
  apply (clarsimp simp: array_assertion_def)
  apply (rule exI, rule_tac x="i + j" in exI, rule exI, erule conjI)
  apply (simp add: CTypesDefs.ptr_add_def field_simps)
  done

lemma array_assertion_shrink_leftI:
  "array_assertion (CTypesDefs.ptr_add p (- (int j))) (n + j) htd
    \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> array_assertion p n htd"
  apply (drule_tac j=j in array_assertion_shrink_leftD, simp)
  apply (simp add: CTypesDefs.ptr_add_def)
  done

lemma h_t_array_valid:
  "h_t_valid htd gd (p :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> h_t_array_valid htd (ptr_coerce p :: 'a ptr) (CARD('b))"
  by (clarsimp simp: h_t_valid_def h_t_array_valid_def
                     typ_uinfo_array_tag_n_m_eq)

lemma array_ptr_valid_array_assertionD:
  "h_t_valid htd gd (p :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> array_assertion (ptr_coerce p :: 'a ptr) (CARD('b)) htd"
  apply (clarsimp simp: array_assertion_def dest!: h_t_array_valid)
  apply (fastforce intro: exI[where x=0])
  done

lemma array_ptr_valid_array_assertionI:
  "h_t_valid htd gd (q :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> q = ptr_coerce p
    \<Longrightarrow> n \<le> CARD('b)
    \<Longrightarrow> array_assertion (p :: 'a ptr) n htd"
  by (auto dest: array_ptr_valid_array_assertionD
           simp: array_assertion_shrink_right)

text {* Derived from array_assertion, an appropriate assertion for performing
a pointer addition, or for dereferencing a pointer addition (the strong case).

In either case, there must be an array connecting the two ends of the pointer
transition, with the caveat that the last address can be just out of the array
if the pointer is not dereferenced, thus the strong/weak distinction.

If the pointer doesn't actually move, nothing is learned.
*}
definition
  ptr_add_assertion :: "('a :: c_type) ptr \<Rightarrow> int \<Rightarrow> bool \<Rightarrow> heap_typ_desc \<Rightarrow> bool"
where
  "ptr_add_assertion ptr offs strong htd \<equiv> offs = 0
    \<or> array_assertion (if offs < 0 then CTypesDefs.ptr_add ptr offs else ptr)
        (if offs < 0 then nat (- offs) else if strong then Suc (nat offs) else nat offs)
        htd"

lemma ptr_add_assertion_positive:
  "offs \<ge> 0 \<Longrightarrow> ptr_add_assertion ptr offs strong htd
    = (offs = 0 \<or> array_assertion ptr (case strong of True \<Rightarrow> Suc (nat offs)
        | False \<Rightarrow> nat offs) htd)"
  by (simp add: ptr_add_assertion_def)

lemma ptr_add_assertion_negative:
  "offs < 0 \<Longrightarrow> ptr_add_assertion ptr offs strong htd
    = array_assertion (CTypesDefs.ptr_add ptr offs) (nat (- offs)) htd"
  by (simp add: ptr_add_assertion_def)

lemma ptr_add_assertion_uint[simp]:
  "ptr_add_assertion ptr (uint offs) strong htd
    = (offs = 0 \<or> array_assertion ptr
        (case strong of True \<Rightarrow> Suc (unat offs) | False \<Rightarrow> unat offs) htd)"
  by (simp add: ptr_add_assertion_positive uint_0_iff unat_def
         split: bool.split)

text {* Ignore char and void pointers. The C standard specifies that arithmetic on
char and void pointers doesn't create any special checks. *}

definition
  ptr_add_assertion' :: "('a :: c_type) ptr \<Rightarrow> int \<Rightarrow> bool \<Rightarrow> heap_typ_desc \<Rightarrow> bool"
where
  "ptr_add_assertion' ptr offs strong htd = (typ_uinfo_t TYPE('a) = typ_uinfo_t TYPE(word8)
    \<or> typ_uinfo_t TYPE ('a) = typ_uinfo_t TYPE(unit)
    \<or> ptr_add_assertion ptr offs strong htd)"

(* Useful for clearing away these assumptions. *)
lemma td_diff_from_typ_name:
  "typ_name td \<noteq> typ_name td' \<Longrightarrow> td \<noteq> td'"
  by clarsimp

lemma typ_name_void:
  "typ_name (typ_uinfo_t TYPE(unit)) = ''unit''"
 by (simp add: typ_uinfo_t_def)

lemmas ptr_add_assertion' = ptr_add_assertion'_def td_diff_from_typ_name typ_name_void

text {* Mechanism for retyping a range of memory to a non-constant array size. *}

definition
  ptr_arr_retyps :: "nat \<Rightarrow> ('a :: c_type) ptr \<Rightarrow> heap_typ_desc \<Rightarrow> heap_typ_desc"
where
  "ptr_arr_retyps n p \<equiv>
    htd_update_list (ptr_val p)
        (map (\<lambda>i. list_map (typ_slice_t (uinfo_array_tag_n_m TYPE('a) n n) i))
            [0..<n * size_of TYPE('a)])"

lemma ptr_arr_retyps_to_retyp:
  "n = CARD('b :: finite)
    \<Longrightarrow> ptr_arr_retyps n (p :: ('c :: wf_type) ptr) = ptr_retyp (ptr_coerce p :: ('c['b]) ptr)"
  apply (rule ext)
  apply (simp add: ptr_arr_retyps_def ptr_retyp_def typ_slices_def
                   typ_uinfo_array_tag_n_m_eq)
  done

end


theory TA_Games_Misc
  imports
    Main
    "HOL-Library.Sublist"
    "HOL-Library.Linear_Temporal_Logic_on_Streams" Transition_Systems_and_Automata.Sequence_LTL
    TA_Library.Instantiate_Existentials
    TA_Library.Graphs
begin

paragraph \<open>Unused\<close>

lemma strict_suffix_Cons_iff:
  "strict_suffix xs (x # ys) \<longleftrightarrow> xs = ys \<or> strict_suffix xs ys"
  by (metis suffix_Cons suffix_ConsD' suffix_order.less_le)

lemma ev_alt_def_strong:
  "ev \<phi> w \<longleftrightarrow> (\<exists>u v. w = u @- v \<and> \<phi> v \<and> (\<forall>x. suffix x u \<and> x \<noteq> [] \<longrightarrow> \<not> \<phi> (x @- v)))"
  apply safe
  subgoal premises prems
    using prems apply (induction rule: ev_induct_strong)
     apply (rule exI[where x = "[]"], simp; fail)
    apply (elim exE)
    subgoal for xs u v
      using stream.collapse[symmetric, of xs]
      by (inst_existentials "shd xs # u" v) (auto simp: suffix_Cons)
  done
  unfolding ev_alt_def by auto

paragraph \<open>Misc\<close>

lemma snocE:
  assumes "xs \<noteq> []"
  obtains x xs' where "xs = xs' @ [x]"
  using assms by (intro that[of "butlast xs" "last xs"]) (simp add: snoc_eq_iff_butlast)

end


(* Authors: Gerwin Klein and Rafal Kolanski, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

theory Sep_Tactics_Test
imports "../Sep_Tactics"
begin

text {* Substitution and forward/backward reasoning *}

typedecl p
typedecl val
typedecl heap

axiomatization where heap_sep_algebra: "OFCLASS(heap, sep_algebra_class)"
instance heap :: sep_algebra by (rule heap_sep_algebra)

axiomatization
  points_to :: "p \<Rightarrow> val \<Rightarrow> heap \<Rightarrow> bool" and
  val :: "heap \<Rightarrow> p \<Rightarrow> val"
where
  points_to: "(points_to p v ** P) h \<Longrightarrow> val h p = v"

lemma
  "\<lbrakk> Q2 (val h p); (K ** T ** blub ** P ** points_to p v ** P ** J) h \<rbrakk>
   \<Longrightarrow> Q (val h p) (val h p)"
  apply (sep_subst (2) points_to)
  apply (sep_subst (asm) points_to)
  apply (sep_subst points_to)
  oops

lemma
  "\<lbrakk> Q2 (val h p); (K ** T ** blub ** P ** points_to p v ** P ** J) h \<rbrakk>
   \<Longrightarrow> Q (val h p) (val h p)"
  apply (sep_drule points_to)
  apply simp
  oops

lemma
  "\<lbrakk> Q2 (val h p); (K ** T ** blub ** P ** points_to p v ** P ** J) h \<rbrakk>
   \<Longrightarrow> Q (val h p) (val h p)"
  apply (sep_frule points_to)
  apply simp
  oops

consts
  update :: "p \<Rightarrow> val \<Rightarrow> heap \<Rightarrow> heap"

schematic_lemma
  assumes a: "\<And>P. (stuff p ** P) H \<Longrightarrow> (other_stuff p v ** P) (update p v H)"
  shows "(X ** Y ** other_stuff p ?v) (update p v H)"
  apply (sep_rule a)
  oops

text {* Example of low-level rewrites *}

lemma "\<lbrakk> unrelated s ; (P ** Q ** R) s \<rbrakk> \<Longrightarrow> (A ** B ** Q ** P) s"
  apply (tactic {* dtac (mk_sep_select_rule @{context} true (3,1)) 1 *})
  apply (tactic {* rtac (mk_sep_select_rule @{context} false (4,2)) 1 *})
  (* now sep_conj_impl1 can be used *)
  apply (erule (1) sep_conj_impl)
  oops

text {* Conjunct selection *}

lemma "(A ** B ** Q ** P) s"
  apply (sep_select 1)
  apply (sep_select 3)
  apply (sep_select 4)
  oops

lemma "\<lbrakk> also unrelated; (A ** B ** Q ** P) s \<rbrakk> \<Longrightarrow> unrelated"
  apply (sep_select_asm 2)
  oops

section {* Test cases for @{text sep_cancel}. *}

lemma
  assumes forward: "\<And>s g p v. A g p v s \<Longrightarrow> AA g p s "
  shows "\<And>xv yv P s y x s. (A g x yv ** A g y yv ** P) s \<Longrightarrow> (AA g y ** sep_true) s"
  by (sep_cancel add: forward)

lemma
  assumes forward: "\<And>s. generic s \<Longrightarrow> instance s"
  shows "(A ** generic ** B) s \<Longrightarrow> (instance ** sep_true) s"
  by (sep_cancel add: forward)

lemma "\<lbrakk> (A ** B) sa ; (A ** Y) s \<rbrakk> \<Longrightarrow> (A ** X) s"
  apply (sep_cancel)
  oops

lemma "\<lbrakk> (A ** B) sa ; (A ** Y) s \<rbrakk> \<Longrightarrow> (\<lambda>s. (A ** X) s) s"
  apply (sep_cancel)
  oops

schematic_lemma "\<lbrakk> (B ** A ** C) s \<rbrakk> \<Longrightarrow> (\<lambda>s. (A ** ?X) s) s"
  by (sep_cancel)

(* test backtracking on premises with same state *)
lemma
  assumes forward: "\<And>s. generic s \<Longrightarrow> instance s"
  shows "\<lbrakk> (A ** B) s ; (generic ** Y) s \<rbrakk> \<Longrightarrow> (X ** instance) s"
  apply (sep_cancel add: forward)
  oops

lemma
  assumes forward: "\<And>s. generic s \<Longrightarrow> instance s"
  shows "generic s \<Longrightarrow> instance s"
  by (sep_cancel add: forward)

lemma
  assumes forward: "\<And>s. generic s \<Longrightarrow> instance s"
  assumes forward2: "\<And>s. instance s \<Longrightarrow> instance2 s"
  shows "generic s \<Longrightarrow> (instance2 ** sep_true) s"
  by (sep_cancel_blast add: forward forward2)

end


(*File: ContextVS.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory ContextVS imports VS begin
subsection\<open>Contextual closure\<close>

text\<open>\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.\<close>

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

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\<open>We let $C$, $D$ range over contextual programs. The substitution
operation is defined by structural recursion.\<close>

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\<open>Equally obvious are the definitions of the (syntactically)
mentioned variables of arithmetic and boolean expressions.\<close>

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\<open>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.\<close>

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\<open>For contexts, we define when a set $X$ of variables is an upper
bound for the variables read from.\<close>

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\<open>A constant representing the procedure body with holes.\<close>

consts Ctxt_Body::CtxtProg

text\<open>The following predicate expresses that all variables read from
by a command $c$ are contained in the set $X$ of low variables.\<close>

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\<open>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.\<close>

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\<open>Consequently, a (low) variable representing the result of
the attacking context does not leak any unwanted information.\<close>

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\<open>End of theory ContextVS\<close>
end