section "Unique Identifiers (Part 2)"
theory unique_ids2
  imports unique_ids
    invariant_simps
    unique_ids
    single_invocation_correctness2
    "Case_Labeling.Case_Labeling"
    execution_invariants2
    execution_invariants_s
    execution_invariants_unused
    impl_language
    topological_sort
begin

definition
  "new_unique_not_in_invocOp iop uidv \<equiv>
\<forall>i op. iop i \<triangleq> op \<longrightarrow> uidv \<notin> uniqueIds op "

definition
  "new_unique_not_in_calls iop uidv \<equiv>
\<forall>i op r. iop i \<triangleq> Call op r \<longrightarrow> uidv \<notin> uniqueIds op "

definition
  "new_unique_not_in_calls_result iop uidv \<equiv>
\<forall>i op r. iop i \<triangleq> Call op r \<longrightarrow> uidv \<notin> uniqueIds r "

definition
"new_unique_not_in_invocRes ires uidv \<equiv>
\<forall>i r. ires i \<triangleq> r \<longrightarrow> uidv \<notin> uniqueIds r "

definition
"new_unique_not_in_other_invocations i S uidv \<equiv>
(\<forall>i'. i' \<noteq> i \<longrightarrow> (\<exists>uids. uidv \<notin> uids \<and> invocation_cannot_guess_ids uids i' S))"

lemmas use_new_unique_not_in_other_invocations = new_unique_not_in_other_invocations_def[THEN meta_eq_to_obj_eq, THEN iffD1, rule_format]

(*
lemma show_new_unique_not_in_other_invocations:
  assumes a1: "new_unique_not_in_other_invocations i S uidv"
    and a2: "\<And>i' uids ls ls' impl. \<lbrakk>i' \<noteq> i; los i' \<triangleq> ls; los' i' \<triangleq> ls'; p i' \<triangleq> impl;  invocations_cannot_guess_ids uids ls impl\<rbrakk> \<Longrightarrow> procedure_cannot_guess_ids uids ls' impl"
    and a3: "dom los = dom los'"
  shows "new_unique_not_in_other_invocations i los' p uidv"
proof (auto simp add: new_unique_not_in_other_invocations_def)
  fix i' ls impl
  assume b1: "i' \<noteq> i"
    and b2: "los' i' \<triangleq> ls"
    and b3: "p i' \<triangleq> impl"

  obtain ls_pre where b4: "los i' \<triangleq> ls_pre"
    using a3 b2 by force

  from a1 obtain uids where b5: " uidv \<notin> uids" and b6: "procedure_cannot_guess_ids uids ls_pre impl"
    by (meson b1 b3 b4 new_unique_not_in_other_invocations_def)

  have "procedure_cannot_guess_ids uids ls impl"
    using b1 b4 b2 b3 b6 by (rule a2)

  show "\<exists>uids.  uidv \<notin> uids \<and> procedure_cannot_guess_ids uids ls impl"
    using \<open>procedure_cannot_guess_ids uids ls impl\<close> b5 by auto
qed
*)

definition uid_is_private where
"uid_is_private i S uidv  \<equiv>
      new_unique_not_in_invocOp (invocOp S) uidv
    \<and> new_unique_not_in_calls (calls S) uidv
    \<and> new_unique_not_in_calls_result (calls S) uidv
    \<and> new_unique_not_in_invocRes (invocRes S) uidv
    \<and> uidv \<notin> (knownIds S)
    \<and> generatedIds S uidv \<triangleq> i
    \<and> new_unique_not_in_other_invocations i S uidv"

definition uid_is_private' where
"uid_is_private' i s_calls s_invocOp s_invocRes s_knownIds uidv  \<equiv>
      new_unique_not_in_invocOp s_invocOp uidv
    \<and> new_unique_not_in_calls s_calls uidv
    \<and> new_unique_not_in_calls_result s_calls uidv
    \<and> new_unique_not_in_invocRes s_invocRes uidv
    \<and> uidv \<notin> s_knownIds
    "

text \<open>
\DefineSnippet{uid_is_private2}{
  @{thm [display] uid_is_private'_def}
}%EndSnippet

\DefineSnippet{new_unique_not_in_invocOp}{
  @{thm [display] new_unique_not_in_invocOp_def}
}%EndSnippet

\DefineSnippet{new_unique_not_in_calls}{
  @{thm [display] new_unique_not_in_calls_def}
}%EndSnippet

\DefineSnippet{new_unique_not_in_calls_result}{
  @{thm [display] new_unique_not_in_calls_result_def}
}%EndSnippet

\DefineSnippet{new_unique_not_in_invocRes}{
  @{thm [display] new_unique_not_in_invocRes_def}
}%EndSnippet

\<close>

abbreviation
"uid_is_private_S i S uidv \<equiv>
  uid_is_private' i (calls S) (invocOp S) (invocRes S) (knownIds S) uidv"

lemma uid_is_private'_implies:
"uid_is_private i S uidv
 \<Longrightarrow> uid_is_private' i (calls S) (invocOp S) (invocRes S) (knownIds S) uidv"
  by (auto simp add: uid_is_private_def uid_is_private'_def)

lemma growth_still_hidden_step_other:
  assumes S_wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and p1: "uid_is_private i S uidv"
    and step: "S ~~ (i', a) \<leadsto> S'"
    and other: "i' \<noteq> i"
  shows "uid_is_private i S' uidv"
proof -

  have priv_S: "uid_is_private i S uidv"
    by (simp add: p1)

  have i1: "new_unique_not_in_invocOp (invocOp S) uidv "
    by (meson priv_S uid_is_private_def)

  have i2: "new_unique_not_in_calls (calls S) uidv "
    by (meson priv_S uid_is_private_def)
  have i3: "new_unique_not_in_calls_result (calls S) uidv"
    by (meson priv_S uid_is_private_def)
  have i4: "new_unique_not_in_invocRes (invocRes S) uidv"
    by (meson priv_S uid_is_private_def)
  have i5: "uidv \<notin> knownIds S"
    by (meson priv_S uid_is_private_def)
  have i6: "new_unique_not_in_other_invocations i S uidv"
    by (meson priv_S uid_is_private_def)

  have still_generated: "generatedIds S uidv \<triangleq> i"
    by (meson priv_S uid_is_private_def)

  have inv6': "new_unique_not_in_other_invocations i S' uidv"
    if "uidv \<notin> action_inputs a"
    unfolding new_unique_not_in_other_invocations_def
  proof (intro allI impI)
    fix i''
    assume a0: "i'' \<noteq> i"

    obtain uids where "uidv \<notin> uids" and "invocation_cannot_guess_ids uids i'' S"
      by (metis a0 i6 new_unique_not_in_other_invocations_def)

    show "\<exists>uids. uidv \<notin> uids \<and> invocation_cannot_guess_ids uids i'' S'"
    proof (cases "i'' = i'")
      case True

      from `invocation_cannot_guess_ids uids i'' S`
      have "invocation_cannot_guess_ids (uids \<union> action_inputs a) i'' S'"
      proof (rule show_invocation_cannot_guess_ids_step)
        show "S ~~ (i'', a) \<leadsto> S'"
          by (simp add: True local.step)
      qed

      then show ?thesis
        using UnE \<open>uidv \<notin> uids\<close> that by auto
    next
      case False

      from `invocation_cannot_guess_ids uids i'' S` step
      have "invocation_cannot_guess_ids uids i'' S'"
        by (rule show_invocation_cannot_guess_ids_step_other, use False in simp)

      then show ?thesis
        using \<open>uidv \<notin> uids\<close> by blast
    qed
  qed

  note invs = i1 i2 i3 i4 i5 i6 inv6' still_generated

  have S'_wf: "state_wellFormed S'" if noFail: "a \<noteq> ACrash"
    using S_wf local.step noFail state_wellFormed_combine1 by blast

  from `S ~~ (i', a) \<leadsto> S'`
  show ?thesis
  proof (induct rule: step.cases)
    case (local S i2 ls f ls')

    from local
    show ?case
      using invs by (auto simp add: uid_is_private_def  split: if_splits)

  next
    case (newId S i' ls f ls' uid uidv ls'')
    show ?case
      using invs  `uid = to_nat uidv` `generatedIds S uid = None` newId by (auto simp add: uid_is_private_def)

  next
    case (beginAtomic S i ls f ls' t vis snapshot)
    then show ?case using invs by (auto simp add: uid_is_private_def  split: if_splits)
  next
    case (endAtomic S i ls f ls' t)
    then show ?case using invs
      by (auto simp add: uid_is_private_def   split: if_splits)

  next
    case (dbop S i' ls f Op ls' t c res vis)

    have "i' \<noteq> i"
      using dbop.hyps(2) other by blast

    obtain uids where  uids1: " uidv \<notin> uids" and uids2: "invocation_cannot_guess_ids uids i' S"
      by (metis \<open>i' \<noteq> i\<close> dbop.hyps(1) i6 new_unique_not_in_other_invocations_def)

    from uids2 step
    have "uniqueIds Op \<subseteq> uids"
      by (fuzzy_rule use_invocation_cannot_guess_ids_dbop, use dbop in auto)

    with uids1 have uids2: " uidv \<notin> uniqueIds Op"
      by auto

    have qcngi: "queries_cannot_guess_ids (querySpec (prog S))"
      using dbop.hyps(1) prog_wf program_wellFormed_def by blast

    have uids3: " uidv \<notin> uniqueIds res"
    proof (rule notI)
      assume " uidv \<in> uniqueIds res "

      from qcngi `querySpec (prog S) Op (getContext S i') res` ` uidv \<in> uniqueIds res` ` uidv \<notin> uniqueIds Op`
      have "\<exists>cId opr res. calls (getContext S i') cId \<triangleq> Call opr res \<and>  uidv \<in> uniqueIds opr"
        by (rule queries_cannot_guess_ids_def2[THEN iffD1, rule_format])

      thus False
        apply (auto simp add: getContextH_def restrict_map_def split: option.splits if_splits)
        using dbop.hyps(1) i2 new_unique_not_in_calls_def by fastforce
    qed

    show ?case
      unfolding uid_is_private_def
    proof (intro conjI)
      show "new_unique_not_in_invocOp (invocOp S') uidv"
        using dbop.hyps(1) i1 by (auto simp add: dbop)
      show "new_unique_not_in_calls (calls S') uidv"
        using dbop.hyps(1) i2 by (auto simp add: dbop new_unique_not_in_calls_def uids2)
      show "new_unique_not_in_calls_result (calls S') uidv"
        using dbop.hyps(1) i3 by (auto simp add: dbop new_unique_not_in_calls_result_def uids3)
      show "new_unique_not_in_invocRes (invocRes S') uidv"
       using dbop.hyps(1) i4 by (auto simp add: dbop)
      show "uidv \<notin> knownIds S'"
        using dbop.hyps(1) i5  by (auto simp add: dbop)
      show "generatedIds S' uidv \<triangleq> i"
        using dbop.hyps(1) still_generated by (auto simp add: dbop)
      show "new_unique_not_in_other_invocations i S' uidv "
        using dbop.hyps(2) inv6' uids3 by auto
    qed

  next
    case (invocation S i proc initialState impl)
    then show ?case using invs by (auto simp add: uid_is_private_def new_unique_not_in_invocOp_def)

  next
    case (return S i ls f res)
    then show ?case using invs apply (auto simp add: uid_is_private_def)
       apply (auto simp add: new_unique_not_in_invocRes_def)
      apply (metis action_outputs.simps(7) i6 invocation_cannot_guess_ids_step local.step new_unique_not_in_other_invocations_def other )
      by (metis action_outputs.simps(7) i6 invocation_cannot_guess_ids_step local.step new_unique_not_in_other_invocations_def other)

  next
    case (crash S i ls)
    then show ?case
      using invs
      by (auto simp add: uid_is_private_def new_unique_not_in_other_invocations_def)

  next
    case (invCheck S res i)
    then show ?case using invs by (auto simp add: uid_is_private_def)
  qed
qed

lemma growth_still_hidden_steps_other:
  assumes S_wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and p1: "uid_is_private i S uidv"
    and steps: "S ~~ tr \<leadsto>* S'"
    and other: "\<forall>(i',a)\<in>set tr. i' \<noteq> i"
    and no_fail: "\<forall>i. (i, ACrash) \<notin> set tr"
  shows "uid_is_private i S' uidv"
using steps   p1 other no_fail proof (induct rule: steps_induct)
  case initial
  then show ?case by simp
next
  case (step S' tr a S'')

  show ?case
    using  `S' ~~ a \<leadsto> S''`
  proof (fuzzy_rule growth_still_hidden_step_other)
    show "state_wellFormed S'"
      using S_wf state_wellFormed_combine step.prems step.steps by fastforce

    show "a = (get_invoc a, get_action a)" by force
    show "get_invoc a \<noteq> i"
      using local.step by auto
    show "program_wellFormed (prog S')"
      using prog_wf step.steps steps_do_not_change_prog by fastforce
    show "uid_is_private i S' uidv"
      using step by auto
  qed
qed

lemma growth_still_hidden:
  assumes g: "state_monotonicGrowth i S S'"
    and prog_wf: "program_wellFormed (prog S)"
    and p1: "uid_is_private i S uidv"
  shows "uid_is_private i S' uidv"
proof -
  from g obtain tr
    where wf: "state_wellFormed S"
      and steps: "S ~~ tr \<leadsto>* S'"
      and no_i: "\<forall>x\<in>set tr. case x of (i', a) \<Rightarrow> i' \<noteq> i"
      and no_fail: "\<forall>i. (i, ACrash) \<notin> set tr"
    by (auto simp add: state_monotonicGrowth_def)

  from steps no_i wf no_fail prog_wf p1
  show ?thesis
    using growth_still_hidden_steps_other by blast
qed

lemma step_to_steps:
  assumes "S ~~ a \<leadsto> S'"
  shows " S ~~ [a] \<leadsto>* S'"
  by (simp add: assms steps_single)

lemma step_to_steps_ex:
  assumes "S ~~ a \<leadsto> S'"
  shows "\<exists>tr. S ~~ tr \<leadsto>* S'"
  by (rule exI[where x="[a]"], simp add: assms steps_single)

lemma step_s_to_step:
  assumes steps_s: "S ~~ (i, a, ok) \<leadsto>\<^sub>S S'"
    and no_AInvoc: "\<And>p. a \<noteq> AInvoc p"
    and no_beginAtomic: "\<And>t txns. a \<noteq> ABeginAtomic t txns"
  shows " S ~~ (i, a) \<leadsto> S'"
  using steps_s proof cases
  case (local ls f ls')
  thus "S ~~ (i, a) \<leadsto> S'"
    by (auto simp add: step.simps)
next
  case (newId ls f ls' uid uidv ls'')
  thus "S ~~ (i, a) \<leadsto> S'"
    by (auto simp add: step.simps)
next
  case (beginAtomic ls f ls' t S'a vis vis')
  thus ?thesis using no_beginAtomic by auto
next
  case (endAtomic ls f ls' t)
  thus "S ~~ (i, a) \<leadsto> S'"
    by (auto simp add: step.simps)
next
  case (dbop ls f Op ls' t c res vis)
  thus "S ~~ (i, a) \<leadsto> S'"
    by (auto simp add: step.simps)
next
  case (invocation proc initState impl S')
  with no_AInvoc have False by auto
  thus ?thesis
    ..
next
  case (return ls f res)
  thus "S ~~ (i, a) \<leadsto> S'"
    by (auto simp add: step.simps)
qed

lemma step_s_beginAtomic_to_steps:
  assumes step_s: "S ~~ (i, ABeginAtomic t txns, ok) \<leadsto>\<^sub>S S'"
  shows "\<exists>Sx tr. (S ~~ tr \<leadsto>* Sx) \<and> (\<forall>(i',a)\<in>set tr.  i' \<noteq> i) \<and> (\<forall>i. (i, ACrash) \<notin> set tr)  \<and>  Sx ~~ (i, ABeginAtomic t txns) \<leadsto> S'"
  using assms proof cases
  case (beginAtomic ls f ls' S'a vis)

  from `state_monotonicGrowth i S S'a`
  obtain tr where x1: "S ~~ tr \<leadsto>* S'a"
    and x2: "\<forall>(i',a)\<in>set tr.  i' \<noteq> i"
    and x3: "\<forall>i. (i, ACrash) \<notin> set tr"
    by (auto simp add: state_monotonicGrowth_def)

  have "S'a ~~ (i, ABeginAtomic t txns) \<leadsto> S'"
    using beginAtomic by (auto simp add: step.simps)

  with x1 x2 x3
  show ?thesis
    using steps_step by blast
qed

lemma  show_invocation_cannot_guess_ids_steps_other:
  assumes icgi: "invocation_cannot_guess_ids uids i S"
    and steps: "S ~~ tr \<leadsto>* S'"
    and other: "\<forall>(i',a)\<in>set tr. i' \<noteq> i"
  shows "invocation_cannot_guess_ids uids i S'"
  using steps icgi other
proof (induct rule: steps_induct)
case initial
  then show ?case
    by simp
next
  case (step S' tr a S'')
  then show ?case
    using show_invocation_cannot_guess_ids_step_other
    by (smt Un_iff case_prodE insert_iff list.set(1) list.set(2) prod.sel(1) set_append )
qed

lemma  show_invocation_cannot_guess_ids_step_s_other:
  assumes "invocation_cannot_guess_ids uids i S"
    and step: "S ~~ (i', a) \<leadsto>\<^sub>S S'"
    and "i' \<noteq> i"
    and no_beginAtomic: "\<And>t txns. fst a \<noteq> ABeginAtomic t txns"
    and no_AInvoc: "\<And>p. fst a \<noteq> AInvoc p"
  shows "invocation_cannot_guess_ids uids i S'"
proof -
  have "S ~~ (i', fst a) \<leadsto> S'"
  proof (rule step_s_to_step)
    show "S ~~ (i', fst a, snd a) \<leadsto>\<^sub>S S'"
      using step by simp
  qed (simp add: no_AInvoc no_beginAtomic)+

  with `invocation_cannot_guess_ids uids i S`
  show "invocation_cannot_guess_ids uids i S'"
    using `i' \<noteq> i` show_invocation_cannot_guess_ids_step_other by blast
qed

lemma invocation_cannot_guess_ids_steps:
  assumes "invocation_cannot_guess_ids uids i S"
    and "S ~~ tr \<leadsto>* S'"
  shows "invocation_cannot_guess_ids (uids \<union> trace_inputs tr i) i S'"
proof (rule show_invocation_cannot_guess_ids)
  fix x tra a S'a
  assume a0: "S' ~~ tra @ [(i, a)] \<leadsto>* S'a"
    and a1: "x \<in> action_outputs a"
    and a2: "x \<notin> uids \<union> trace_inputs tr i"

  have "S ~~ ((tr@tra) @ [(i,a)]) \<leadsto>* S'a"
    using a0 assms(2) steps_append2 by force

  from use_invocation_cannot_guess_ids[OF  `invocation_cannot_guess_ids uids i S` `S ~~ ((tr@tra) @ [(i,a)]) \<leadsto>* S'a`]
  have "trace_outputs ((tr @ tra) @ [(i, a)]) i \<subseteq> trace_inputs (tr @ tra) i \<union> uids" .
  hence "action_outputs a \<subseteq> trace_inputs (tr @ tra) i \<union> uids"
    by (auto simp add: trace_outputs_def)

  with `x \<in> action_outputs a` `x \<notin> uids \<union> trace_inputs tr i`
  show "x \<in> trace_inputs tra i"
    by (auto simp add: trace_inputs_append)
qed

lemma new_unique_not_in_other_invocations_maintained:
  assumes "new_unique_not_in_other_invocations i S x"
    and "S ~~ (i, action, Inv) \<leadsto>\<^sub>S S'"
    and no_AInvoc: "\<And>p. action \<noteq> AInvoc p"
    and no_beginAtomic: "\<And>t txns. action \<noteq> ABeginAtomic t txns"
  shows "new_unique_not_in_other_invocations i S' x"
  unfolding new_unique_not_in_other_invocations_def
proof (intro allI impI)
  fix i'
  assume a0: "i' \<noteq> i"

  obtain uids where "x \<notin> uids" and "invocation_cannot_guess_ids uids i' S"
    by (meson a0 assms(1) new_unique_not_in_other_invocations_def)

  from `S ~~ (i, action, Inv) \<leadsto>\<^sub>S S'`
  have "S ~~ (i, action) \<leadsto> S'"
    by (simp add: no_AInvoc no_beginAtomic step_s_to_step)

  have "invocation_cannot_guess_ids uids i' S'"

    using \<open>S ~~ (i, action) \<leadsto> S'\<close> \<open>invocation_cannot_guess_ids uids i' S\<close> a0 show_invocation_cannot_guess_ids_step_other by blast

  thus "\<exists>uids. x \<notin> uids \<and> invocation_cannot_guess_ids uids i' S'"
    using \<open>x \<notin> uids\<close> by blast
qed

lemma uid_is_private_step_same:
  assumes S_wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and p1: "uid_is_private i S uidv"
    and step: "S ~~ (i, a) \<leadsto> S'"
    and other: "uidv \<notin> action_outputs a"
  shows "uid_is_private i S' uidv"
proof -

  from `uid_is_private i S uidv`
  have pre1: "new_unique_not_in_invocOp (invocOp S) uidv"
    and pre2: "new_unique_not_in_calls (calls S) uidv"
    and pre3: "new_unique_not_in_calls_result (calls S) uidv"
    and pre4: "new_unique_not_in_invocRes (invocRes S) uidv"
    and pre5: "uidv \<notin> knownIds S"
    and pre6: "generatedIds S uidv \<triangleq> i"
    and pre7: "new_unique_not_in_other_invocations i S uidv"
    unfolding uid_is_private_def
    by auto
  note pre = this

  have x: "new_unique_not_in_other_invocations i S' uidv"
    by (smt local.step new_unique_not_in_other_invocations_def pre7 show_invocation_cannot_guess_ids_step_other)

  from step
  show ?thesis
  proof cases
    case (local ls f ok ls')
    show ?thesis
      using x by (auto simp add: uid_is_private_def local pre)
  next
    case (newId ls f ls' uid uidv ls'')
    then show ?thesis using x by (auto simp add: uid_is_private_def local pre)
  next
    case (beginAtomic ls f ls' t vis snapshot)
    then show ?thesis using x by (auto simp add: uid_is_private_def local pre)
  next
    case (endAtomic ls f ls' t)
    then show ?thesis using x by (auto simp add: uid_is_private_def local pre)
  next
    case (dbop ls f Op ls' t c res vis)

    from `uidv \<notin> action_outputs a`
    have "uidv \<notin> uniqueIds Op"
      by (simp add: local.dbop(1))

    obtain uids
        where "uids\<subseteq>dom (generatedIds S)"
          and "invocation_cannot_guess_ids uids i S"
      using S_wf prog_wf wf_knownIds_subset_generatedIds_h(1) by blast

    have qcgi: "query_cannot_guess_ids (uniqueIds Op) (querySpec (prog S) Op)"
      using prog_wf program_wellFormed_def queries_cannot_guess_ids_def by blast

    have  "uidv \<notin> uniqueIds res"
    proof
      assume "uidv \<in> uniqueIds res"
      from query_cannot_guess_ids_def2[THEN iffD1, rule_format, OF qcgi `querySpec (prog S) Op (getContext S i) res` `uidv \<in> uniqueIds res` `uidv \<notin> uniqueIds Op`]
      obtain cId opr res
        where "calls (getContext S i) cId \<triangleq> Call opr res"
          and "uidv \<in> uniqueIds opr"
        by blast

      from `calls (getContext S i) cId \<triangleq> Call opr res`
      have "cId \<in> vis" and "calls S cId \<triangleq> Call opr res"
        by (auto simp add: getContextH_def restrict_map_def `visibleCalls S i \<triangleq> vis` split: if_splits option.splits)

      from `new_unique_not_in_calls (calls S) uidv`
      show False
        by (meson \<open>calls S cId \<triangleq> Call opr res\<close> \<open>uidv \<in> uniqueIds opr\<close> new_unique_not_in_calls_def)
    qed

    show ?thesis
      unfolding uid_is_private_def
    proof (intro conjI)
      show "new_unique_not_in_invocOp (invocOp S') uidv"
        using pre by (auto  simp add: dbop)
      show "new_unique_not_in_calls (calls S') uidv"
        using pre by (auto  simp add: dbop \<open>uidv \<notin> uniqueIds Op\<close> new_unique_not_in_calls_def)
      show "new_unique_not_in_calls_result (calls S') uidv"
        using pre \<open>uidv \<notin> uniqueIds res\<close> by (auto  simp add: dbop new_unique_not_in_calls_result_def)
      show "new_unique_not_in_invocRes (invocRes S') uidv"
        using pre by (auto  simp add: dbop)
      show "uidv \<notin> knownIds S'"
        using pre by (auto  simp add: dbop)
      show "generatedIds S' uidv \<triangleq> i"
        using pre by (auto  simp add: dbop)
      show "new_unique_not_in_other_invocations i S' uidv"
        using x by simp
    qed
  next
    case (invocation proc initialState impl)
    show ?thesis
      unfolding uid_is_private_def
    proof (intro conjI)
      show "new_unique_not_in_invocOp (invocOp S') uidv"
        using pre by (auto  simp add: invocation S_wf wf_generated_ids_invocation_exists)
      show "new_unique_not_in_calls (calls S') uidv"
        using pre by (auto  simp add: invocation)
      show "new_unique_not_in_calls_result (calls S') uidv"
        using pre by (auto  simp add: invocation)
      show "new_unique_not_in_invocRes (invocRes S') uidv"
        using pre by (auto  simp add: invocation)
      show "uidv \<notin> knownIds S'"
        using pre by (auto  simp add: invocation)
      show "generatedIds S' uidv \<triangleq> i"
        using pre by (auto  simp add: invocation)
      show "new_unique_not_in_other_invocations i S' uidv"
        using x by simp

    qed
  next
    case (return ls f res)

    have "uidv \<notin> uniqueIds res"
      using local.return(1) other by auto

    show ?thesis
      unfolding uid_is_private_def
    proof (intro conjI)
      show "new_unique_not_in_invocOp (invocOp S') uidv"
        using pre by (auto  simp add: invocation return)
      show "new_unique_not_in_calls (calls S') uidv"
        using pre by (auto  simp add: invocation return)
      show "new_unique_not_in_calls_result (calls S') uidv"
        using pre by (auto  simp add: invocation return)
      show "new_unique_not_in_invocRes (invocRes S') uidv"
        using pre by (auto  simp add: invocation return \<open>uidv \<notin> uniqueIds res\<close> new_unique_not_in_invocRes_def)
      show "uidv \<notin> knownIds S'"
        using pre \<open>uidv \<notin> uniqueIds res\<close> by (auto  simp add: invocation return)
      show "generatedIds S' uidv \<triangleq> i"
        using pre by (auto  simp add: invocation return)
      show "new_unique_not_in_other_invocations i S' uidv"
        using x by simp

    qed
  next
    case (crash ls)
    then show ?thesis using x by (auto simp add: uid_is_private_def local pre)
  next
    case (invCheck res)
    then show ?thesis using x by (auto simp add: uid_is_private_def local pre)
  qed
qed

lemma uid_is_private_step_s_same:
  assumes S_wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and p1: "uid_is_private i S uidv"
    and step: "S ~~ (i, a, Inv) \<leadsto>\<^sub>S S'"
    and other: "uidv \<notin> action_outputs a"
  shows "uid_is_private i S' uidv"
proof -

  from `uid_is_private i S uidv`
  have pre1: "new_unique_not_in_invocOp (invocOp S) uidv"
    and pre2: "new_unique_not_in_calls (calls S) uidv"
    and pre3: "new_unique_not_in_calls_result (calls S) uidv"
    and pre4: "new_unique_not_in_invocRes (invocRes S) uidv"
    and pre5: "uidv \<notin> knownIds S"
    and pre6: "generatedIds S uidv \<triangleq> i"
    and pre7: "new_unique_not_in_other_invocations i S uidv"
    unfolding uid_is_private_def
    by auto
  note pre = this

  {
    assume no_AInvoc: "\<And>p. a \<noteq> AInvoc p"
    and no_beginAtomic: "\<And>t txns. a \<noteq> ABeginAtomic t txns"
    with step
    have "S ~~ (i, a) \<leadsto> S'"
      using step_s_to_step by blast
    hence ?thesis
      using S_wf other p1 prog_wf uid_is_private_step_same by blast
  }
  moreover
  {
    fix p
    assume AInvoc: "a = AInvoc p"

    with step
    have "invocOp S i = None"
      by (auto simp add: step_s.simps)

    from wf_generated_ids_invocation_exists[OF S_wf `invocOp S i = None`]
    have not_generated: "generatedIds S uid \<noteq> Some i" for uid .

    with `generatedIds S uidv \<triangleq> i`
    have False
      by blast

    hence ?thesis ..
  }
  moreover
  {
    fix t vis'
    assume "a = ABeginAtomic t vis'"

    from step
    obtain ls f ls' S'a vis vis'
      where c0: "a = ABeginAtomic t vis'"
        and c1: "Inv = True"
        and c2: "localState S i \<triangleq> ls"
        and c3: "currentProc S i \<triangleq> f"
        and c4: "f ls = BeginAtomic ls'"
        and c5: "currentTx S i = None"
        and c6: "txStatus S t = None"
        and c7: "prog S'a = prog S"
        and c8: "state_monotonicGrowth i S S'a"
        and c10: "invariant_all S'a"
        and c11: "\<And>tx. txStatus S'a tx \<noteq> Some Uncommitted"
        and c12: "state_wellFormed S'a"
        and c13: "state_wellFormed S'"
        and c14: "localState S'a i \<triangleq> ls"
        and c15: "currentProc S'a i \<triangleq> f"
        and c16: "currentTx S'a i = None"
        and c17: "visibleCalls S i \<triangleq> vis"
        and c18: "visibleCalls S'a i \<triangleq> vis"
        and c19: "chooseSnapshot vis' vis S'a"
        and c20: "consistentSnapshot S'a vis'"
        and c21: "txStatus S'a t = None"
        and c22: "\<And>c. callOrigin S'a c \<noteq> Some t"
        and c23: "txOrigin S'a t = None"
        and c24: "S' = S'a \<lparr>txStatus := txStatus S'a(t \<mapsto> Uncommitted), txOrigin := txOrigin S'a(t \<mapsto> i), currentTx := currentTx S'a(i \<mapsto> t), localState := localState S'a(i \<mapsto> ls'), visibleCalls := visibleCalls S'a(i \<mapsto> vis')\<rparr>"
      by (auto simp add: step_s.simps `a = ABeginAtomic t vis'`)
    note c = this

    from growth_still_hidden[OF `state_monotonicGrowth i S S'a` `program_wellFormed (prog S)` `uid_is_private i S uidv`]
    have "uid_is_private i S'a uidv" .

    from `uid_is_private i S'a uidv`
    have pre'1: "new_unique_not_in_invocOp (invocOp S'a) uidv"
      and pre'2: "new_unique_not_in_calls (calls S'a) uidv"
      and pre'3: "new_unique_not_in_calls_result (calls S'a) uidv"
      and pre'4: "new_unique_not_in_invocRes (invocRes S'a) uidv"
      and pre'5: "uidv \<notin> knownIds S'a"
      and pre'6: "generatedIds S'a uidv \<triangleq> i"
      and pre'7: "new_unique_not_in_other_invocations i S'a uidv"
      unfolding uid_is_private_def
      by auto
    note pre' = this

    have ?thesis
      unfolding uid_is_private_def
    proof (intro conjI)
      show "new_unique_not_in_invocOp (invocOp S') uidv"
        using pre' by (auto  simp add: c)
      show "new_unique_not_in_calls (calls S') uidv"
        using pre' by (auto  simp add: c)
      show "new_unique_not_in_calls_result (calls S') uidv"
        using pre' by (auto  simp add: c)
      show "new_unique_not_in_invocRes (invocRes S') uidv"
        using pre' by (auto  simp add: c)
      show "uidv \<notin> knownIds S'"
        using pre' by (auto  simp add: c)
      show "generatedIds S' uidv \<triangleq> i"
        using pre' by (auto  simp add: c)

      from step
      have "S ~~ (i, ABeginAtomic t vis', Inv) \<leadsto>\<^sub>S S'"
        by (simp add: \<open>a = ABeginAtomic t vis'\<close>)

      have "S'a ~~ (i, ABeginAtomic t vis') \<leadsto> S'"
        using c by (auto simp add: step.simps)

      show "new_unique_not_in_other_invocations i S' uidv"
        by (metis \<open>S'a ~~ (i, ABeginAtomic t vis') \<leadsto> S'\<close> c0 c12 c7 c8 growth_still_hidden other p1 prog_wf uid_is_private_def uid_is_private_step_same)

    qed

  }
  ultimately show ?thesis
    by blast
qed

lemma wf_invocation_cannot_guess_ids_not_generated:
  assumes S_wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and not_generated: "generatedIds S uid = None"
  shows "new_unique_not_in_other_invocations i S uid"
  unfolding new_unique_not_in_other_invocations_def
proof (intro allI impI)
  fix i'
  assume a0: "i' \<noteq> i"

  from wf_knownIds_subset_generatedIds_h(1)[OF S_wf prog_wf]
  obtain uids where "uids\<subseteq>dom (generatedIds S)"
    and "invocation_cannot_guess_ids uids i' S"
    by blast

  thus "\<exists>uids. uid \<notin> uids \<and> invocation_cannot_guess_ids uids i' S"
    using not_generated by blast
qed

lemma trace_inputs_if_no_op:
  assumes "initialState progr ~~ tr \<leadsto>* S"
and "invocOp S i = None"
shows "trace_inputs tr i = {}"
using assms proof (induct rule: steps_induct)
  case initial
  then show ?case
    by (simp add: trace_inputs_empty)
next
  case (step S' tr a S'')
  then show ?case
    by (auto simp add: trace_inputs_append trace_inputs_cons trace_inputs_empty step.simps invocation_ops_if_localstate_nonempty)
qed

lemma invocation_cannot_guess_ids_initialStates:
  assumes "invocations_cannot_guess_ids progr"
    and "invocations_cannot_guess_ids progr"
    and "S \<in> initialStates' progr i"
  shows "invocation_cannot_guess_ids (uniqueIds (the (invocOp S i))) i S"
proof -

  from `invocations_cannot_guess_ids progr`
  have "invocation_cannot_guess_ids {} i (initialState progr)"
    by (auto simp add: invocations_cannot_guess_ids_def)

  from `S \<in> initialStates' progr i`
  obtain Sa proc initState impl
    where a0: "S = Sa         \<lparr>localState := localState Sa(i \<mapsto> initState), currentProc := currentProc Sa(i \<mapsto> impl),            visibleCalls := visibleCalls Sa(i \<mapsto> {}), invocOp := invocOp Sa(i \<mapsto> proc)\<rparr>"
      and a1: "progr = prog Sa"
      and a2: "procedure (prog Sa) proc = (initState, impl)"
      and a3: "uniqueIds proc \<subseteq> knownIds Sa"
      and a4: "invariant_all' Sa"
      and a5: "state_wellFormed Sa"
      and a6: "invocOp Sa i = None"
      and a7: "\<forall>tx. txStatus Sa tx \<noteq> Some Uncommitted"
      and a8: "\<forall>tx. txOrigin Sa tx \<noteq> Some i"
    by (auto simp add:initialStates'_def)
  note a = this

  from `state_wellFormed Sa`
  obtain tr where "\<forall>i. (i, ACrash) \<notin> set tr" and "initialState (prog Sa) ~~ tr \<leadsto>* Sa"
    unfolding state_wellFormed_def by auto

  from `invocation_cannot_guess_ids {} i (initialState progr)`
    and `initialState (prog Sa) ~~ tr \<leadsto>* Sa`
  have "invocation_cannot_guess_ids {} i Sa"
    using a1 a6 invocation_cannot_guess_ids_steps trace_inputs_if_no_op by fastforce

  have [simp]: "localState Sa i = None"
    using a5 a6 wf_localState_to_invocOp by blast

  have "Sa ~~(i, AInvoc proc) \<leadsto> S"
    using a by (auto simp add: step.simps)

  with `invocation_cannot_guess_ids {} i Sa`
  show ?thesis
  proof (fuzzy_rule show_invocation_cannot_guess_ids_step)
    show "{} \<union> action_inputs (AInvoc proc) = uniqueIds (the (invocOp S i))"
      by (auto simp add: a0)
  qed
qed

end


theory "ConstantGas"

imports
   "InstructionAux" "../../ProgramInAvl"

begin

declare stack_1_1_op_def [simp del]
declare jump_def [simp del]

lemma lemma_stack_2_1_op :
"stack_2_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_gas v = vctx_gas nv"
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
done

lemma lemma_sstore :
"sstore v c = InstructionContinue nv \<Longrightarrow>
 vctx_gas v = vctx_gas nv"
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
done

lemma lemma_stack_3_1_op :
"stack_3_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_gas v = vctx_gas nv"
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(cases "tl (tl (vctx_stack v))")
apply(simp)
apply(auto)
done

lemma lemma_stack_1_1_op :
"stack_1_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_gas v = vctx_gas nv"
apply(auto simp:stack_1_1_op_def)
apply(cases "vctx_stack v")
apply(auto split:option.split)
done

theorem lemma_jump [simp] :
"jump v c = InstructionContinue nv \<Longrightarrow>
 vctx_gas v = vctx_gas nv"
apply(auto simp:jump_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "program_content (cctx_program c)
                   (uint (hd (vctx_stack v)))")
apply auto
apply(cases "get_some (program_content (cctx_program c)
                   (uint (hd (vctx_stack v))))")
apply auto
apply(cases "get_pc (program_content (cctx_program c)
                   (uint (hd (vctx_stack v))))")
apply auto
done

theorem lemma_jump_foo [simp] :
"jump (v\<lparr>vctx_stack := a # lista\<rparr>) c = InstructionContinue nv \<Longrightarrow>
 vctx_gas v = vctx_gas nv"
apply(auto simp:jump_def)
apply(cases "program_content (cctx_program c)
                   (uint a)")
apply auto
apply(cases "get_some (program_content (cctx_program c)
                   (uint a))")
apply auto
apply(cases "get_pc (program_content (cctx_program c)
                   (uint a))")
apply auto
done

(* declare cut_memory.simps [simp del] *)

theorem no_modify_gas :
  "instruction_aux v c inst = InstructionContinue nv \<Longrightarrow>
   vctx_gas v = vctx_gas nv"
apply(cases inst)
apply(auto simp:instruction_aux_def)
apply(cases "get_bits (Some inst)",
   auto simp:lemma_stack_2_1_op lemma_stack_3_1_op lemma_stack_1_1_op)
apply(cases "get_sarith (Some inst)",
   auto simp:lemma_stack_2_1_op lemma_stack_3_1_op lemma_stack_1_1_op)
apply(cases "get_arith (Some inst)",
   auto simp:lemma_stack_2_1_op lemma_stack_3_1_op lemma_stack_1_1_op)

apply(auto simp:sha3_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(simp)
apply(auto split:option.split)
apply(cases "get_info (Some inst)")
apply(auto simp:lemma_stack_2_1_op lemma_stack_3_1_op lemma_stack_1_1_op)
apply(cases "index (vctx_stack v) (nat (uint (get_dup (Some inst))))")
apply(auto split:option.split)
apply(cases "get_memory (Some inst)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto split:option.split)
apply(cases "get_storage (Some inst)")
apply(auto simp:lemma_stack_2_1_op lemma_stack_3_1_op
   lemma_stack_1_1_op lemma_sstore)
apply(cases "get_pc (Some inst)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto simp:strict_if_def split:option.split)
apply(cases "hd (tl (vctx_stack v)) = 0")
apply(auto simp:blockedInstructionContinue_def split:option.split)

apply(cases "get_stack inst")
apply(auto simp:lemma_stack_2_1_op lemma_stack_3_1_op lemma_stack_1_1_op)
apply(cases "vctx_stack v")
apply(auto split:option.split)
apply(cases "index (vctx_stack v)
              (nat (uint (get_swap (Some inst))))")
apply(auto split:option.split)
apply(cases "index (vctx_stack v) (Suc (nat (uint (get_swap (Some inst)))))")
apply(auto split:option.split)
apply(cases "index (vctx_stack v) 0")
apply(auto split:option.split)
apply(cases "get_log (Some inst)")
apply(auto)
apply(cases "get_misc (Some inst)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) < hd (vctx_stack v)")
apply(auto)

apply(cases "vctx_stack v")
apply(simp)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(cases "tl (tl (vctx_stack v))")
apply(simp)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(simp)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(simp)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(simp)
apply(cases "tl (tl (tl (tl (tl (tl (vctx_stack v))))))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) <
    hd (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (tl (vctx_stack v))))))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) <
    hd (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) <
    vctx_value_sent v")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
done

lemma new_memory :
  "0 \<le> vctx_memory_usage v \<Longrightarrow> 0 \<le> new_memory_consumption inst v"
apply (cases inst)
apply(auto)
apply (cases "get_arith (Some inst)")
apply(auto)
apply (cases "get_memory (Some inst)")
apply(auto)
apply (cases "get_misc (Some inst)")
apply(auto)
done

lemma new_memory_cons :
  "vctx_memory_usage v \<le> new_memory_consumption inst v"
apply (cases inst)
apply(auto)
apply (cases "get_arith (Some inst)")
apply(auto)
apply (cases "get_memory (Some inst)")
apply(auto)
apply (cases "get_misc (Some inst)")
apply(auto)
done

fun no_spend_gas :: "inst \<Rightarrow> bool" where
"no_spend_gas (Unknown _) = True"
| "no_spend_gas (Misc STOP) = True"
| "no_spend_gas (Misc RETURN) = True"
| "no_spend_gas (Misc SUICIDE) = True"
| "no_spend_gas _ = False"

lemma third_component_stop :
  "no_spend_gas inst \<Longrightarrow>
  thirdComponentOfC inst s0 s1 s2 s3 recipient_empty orig new_val remaining_gas blocknumber \<ge> 0"
apply(cases inst)
apply (auto )
apply(cases "get_misc (Some inst)")
apply (auto simp: Csuicide_def)
done

lemma uint_pos : "uint x \<ge> 0"
apply auto
done

lemma pos_div : "(x::int) \<ge> 0 \<Longrightarrow> x div 32 \<ge> 0"
apply arith
done

lemma simple_mem : "0 < 3 + 3 * ((uint s2 + 31) div 32)"
proof -
have "uint s2 \<ge> 0" by auto
then have "uint s2 + (31::int) \<ge> 0" by arith
then have "((uint s2 + 31) div 32) \<ge> 0" by arith
then show "0 < 3 + 3 * ((uint s2 + 31) div 32)" by arith
qed

lemma simple_mem2 : "0 < 700 + 3 * ((uint s2 + 31) div 32)"
proof -
have "uint s2 \<ge> 0" by auto
then have "uint s2 + (31::int) \<ge> 0" by arith
then have "((uint s2 + 31) div 32) \<ge> 0" by arith
then show "0 < 700 + 3 * ((uint s2 + 31) div 32)" by arith
qed

lemma simple_mem3 : "0 < 20 + 3 * ((uint s2 + 31) div 32)"
proof -
have "uint s2 \<ge> 0" by auto
then have "uint s2 + (31::int) \<ge> 0" by arith
then have "((uint s2 + 31) div 32) \<ge> 0" by arith
then show "0 < 20 + 3 * ((uint s2 + 31) div 32)" by arith
qed

lemma simple : "(x::int) \<ge> 0 \<Longrightarrow> 0 < 3 + 3 * x"
apply arith
done

lemma arith_log : assumes a: "0 < x" shows "0 < x + 8 * uint y"
proof -
have "uint y \<ge> 0" by auto
then have b: "uint y * 8 \<ge> 0" by arith
then show "0 < x + 8 * uint y" using a by arith
qed

lemma lemma_gascap :
   "Cgascap s0 s1 recipient_empty
         remaining_gas blocknumber \<ge> 0"
apply(auto simp:Cgascap_def)
done

lemma misc_calc :
"0 < x \<Longrightarrow> 0 < Cgascap s0 s1 recipient_empty
         remaining_gas blocknumber + x"
using lemma_gascap
  by (simp add: add.commute add_pos_nonneg)

lemma sha3_calc : "0 < 30 + 6 * ((uint x + 31) div 32)"
proof -
  have "uint x \<ge> 0" by auto
  then have "((uint x + 31) div 32) \<ge> 0" by arith
  then show ?thesis by arith
qed

fun log256floor_nat  :: " int \<Rightarrow> nat "  where
     " log256floor_nat x = (
  if x \<le>( 255 :: int) then( 0 :: nat )
  else( 1 :: nat) + log256floor_nat (x div( 256 :: int)))"

declare log256floor.simps [simp del]
declare log256floor_nat.simps [simp del]

lemma abs_stuff : "abs (x div 256) \<le> abs (x::int)"
apply arith
done

lemma log_nat : "log256floor x = int (log256floor_nat x)"
(* apply(cases " x \<le>( 255 :: int)") *)
apply(induction x rule:log256floor.induct)
apply(cases " x \<le>( 255 :: int)")
apply(subst log256floor_nat.simps)
apply(subst log256floor.simps)
apply(simp)
apply(subst log256floor_nat.simps)
apply(subst log256floor.simps)
apply(simp)
done

lemma log_floor_calc : "log256floor x \<ge> 0"
apply(auto simp:log_nat)
done

lemma exp_case : assumes a:"inst = Arith x4" and
       b:"get_arith (Some inst) = EXP" shows
       "0 < thirdComponentOfC (Arith x4)
            s0 s1 s2 s3 recipient_empty
            orig new_val remaining_gas
            blocknumber"
proof -
from a and b have d: "x4 = EXP" by auto
have c: "thirdComponentOfC (Arith EXP)
            s0 s1 s2 s3 recipient_empty
            orig new_val remaining_gas
            blocknumber =
 ( Gexp + (if s1 =((word_of_int 0) ::  256 word) then
 ( 0 :: int) else Gexpbyte * (( 1 :: int) + log256floor (Word.uint s1))))"
by auto
from log_floor_calc have "0 \<le> Gexpbyte * (( 1 :: int) + log256floor (Word.uint s1))" by auto
then have "(if s1 =((word_of_int 0) ::  256 word) then
 ( 0 :: int) else Gexpbyte * (( 1 :: int) + log256floor (Word.uint s1)))
 \<ge> 0" by auto
then have " Gexp + (if s1 =((word_of_int 0) ::  256 word) then
 ( 0 :: int) else Gexpbyte * (( 1 :: int) + log256floor (Word.uint s1)))
 > 0" by auto
then show ?thesis using c and d by auto
qed

lemma exp_calc : "0 < 60 + 50 * log256floor (uint s1)"
proof -
have "log256floor (uint s1) \<ge> 0" by (auto simp:log_floor_calc)
then show ?thesis by arith
qed

lemma third_component :
  "\<not> no_spend_gas inst \<Longrightarrow>
   thirdComponentOfC inst s0 s1 s2 s3 recipient_empty orig new_val remaining_gas blocknumber > 0"
apply (cases inst)
apply (auto)
apply (cases "get_bits (Some inst)")
apply (auto)
apply (cases "get_sarith (Some inst)")
apply (auto)
defer
defer
apply (cases "get_info (Some inst)")
apply (auto)
apply (cases "get_memory (Some inst)")
apply (auto)
apply(auto simp:simple_mem simple_mem2 simple_mem3)
apply (cases "get_storage (Some inst)")
apply (auto)
apply(simp add:Csstore_def)
apply (cases "get_pc (Some inst)")
apply (auto)
apply (cases "get_stack inst")
apply (auto)
apply (cases "get_log (Some inst)")
apply (auto simp:arith_log)
apply (cases "get_misc (Some inst)")
apply (auto simp: lemma_gascap
  Cxfer_def Cnew_def misc_calc)
apply (cases "get_arith (Some inst)")
apply (auto)
apply (cases "get_arith (Some inst)")
apply (auto)
apply (auto simp:exp_calc)
apply(simp add:sha3_calc)
done

lemma foo : assumes a:"0 \<le> vctx_memory_usage v"
shows "3 * new_memory_consumption inst v +
         new_memory_consumption inst v *
         new_memory_consumption inst
          v div
         512 \<ge>
         3 * vctx_memory_usage v +
          vctx_memory_usage v *
          vctx_memory_usage v div
          512"
proof -
from new_memory_cons and a have b: "new_memory_consumption inst v \<ge> 0"
  by smt

from new_memory_cons and a have
 "new_memory_consumption inst v *
         new_memory_consumption inst v \<ge>
   vctx_memory_usage v * vctx_memory_usage v"
  by (simp add: mult_mono')
then have
 "new_memory_consumption inst v *
         new_memory_consumption inst v div 512 \<ge>
   vctx_memory_usage v * vctx_memory_usage v div 512"
  by (simp add: zdiv_mono1)
then show ?thesis using a and b
  by (smt new_memory_cons)
qed

lemma lemma1 :
  "0 \<le> vctx_memory_usage v \<Longrightarrow> 0 \<le> x \<Longrightarrow>
  0 \<le> 3 *
         new_memory_consumption inst v +
         new_memory_consumption inst v *
         new_memory_consumption inst
          v div
         512 -
         (3 * vctx_memory_usage v +
          vctx_memory_usage v *
          vctx_memory_usage v div
          512) + x"
using foo apply auto
done

lemma lemma2 :
  "0 \<le> vctx_memory_usage v \<Longrightarrow> 0 < x \<Longrightarrow>
  0 < 3 *
         new_memory_consumption inst v +
         new_memory_consumption inst v *
         new_memory_consumption inst
          v div
         512 -
         (3 * vctx_memory_usage v +
          vctx_memory_usage v *
          vctx_memory_usage v div
          512) + x"
using foo
  by smt

declare vctx_next_instruction_default_def [simp del]

lemma third_component2 :
  "\<not> no_spend_gas inst \<Longrightarrow>
   thirdComponentOfC inst s0 s1 s2 s3 recipient_empty orig new_val remaining_gas blocknumber \<ge> 0"
using third_component
  by (simp add: dual_order.order_iff_strict)

declare thirdComponentOfC_def [simp del]

lemma lemma_predict :
  "0 \<le> vctx_memory_usage v \<Longrightarrow>
   predict_gas inst v c \<ge> 0"
apply (cases "no_spend_gas (vctx_next_instruction_default v c)")
apply (auto simp:third_component_stop lemma1)
apply (rule lemma1)
apply(auto)
using third_component2
apply(auto)
done

lemma lemma_predict2 :
  "0 \<le> vctx_memory_usage v \<Longrightarrow>
   \<not>no_spend_gas (vctx_next_instruction_default v c) \<Longrightarrow>
   predict_gas inst v c > 0"
apply (auto simp:third_component lemma2)
done

declare predict_gas_def [simp del]

lemma lemma_next :
"vctx_next_instruction_default (v\<lparr>vctx_gas := x \<rparr>) c =
  vctx_next_instruction_default v c"
apply(auto simp:vctx_next_instruction_default_def)
done

theorem gas_smaller :
  "0 \<le> vctx_memory_usage v \<Longrightarrow>
   instruction_sem v c inst = InstructionContinue nv \<Longrightarrow>
   \<not>no_spend_gas (vctx_next_instruction_default v c) \<Longrightarrow>
   vctx_gas nv < vctx_gas v"
apply(subst (asm) inst_gas)
apply(cases "instruction_aux v c inst")
defer
apply(simp)
apply(simp)
apply(auto simp:no_modify_gas lemma_next)
apply(auto simp:lemma_predict2)
done

theorem gas_maybe_smaller :
  "0 \<le> vctx_memory_usage v \<Longrightarrow>
   instruction_sem v c inst = InstructionContinue nv \<Longrightarrow>
   no_spend_gas (vctx_next_instruction_default v c) \<Longrightarrow>
   vctx_gas nv \<le> vctx_gas v"
apply(subst (asm) inst_gas)
apply(cases "instruction_aux v c inst")
defer
apply(simp)
apply(simp)
apply(auto simp:no_modify_gas lemma_next)
apply(auto simp:lemma_predict)
done

(* memory usage grows *)

lemma lemma_stack_2_1_op2 :
"stack_2_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_memory_usage v = vctx_memory_usage nv"
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
done

lemma lemma_sstore2 :
"sstore v c = InstructionContinue nv \<Longrightarrow>
 vctx_memory_usage v = vctx_memory_usage nv"
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
done

lemma lemma_stack_3_1_op2 :
"stack_3_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_memory_usage v = vctx_memory_usage nv"
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(cases "tl (tl (vctx_stack v))")
apply(simp)
apply(auto)
done

lemma lemma_stack_1_1_op2 :
"stack_1_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_memory_usage v = vctx_memory_usage nv"
apply(auto simp:stack_1_1_op_def)
apply(cases "vctx_stack v")
apply(auto split:option.split)
done

theorem lemma_jump2 [simp] :
"jump v c = InstructionContinue nv \<Longrightarrow>
 vctx_memory_usage v = vctx_memory_usage nv"
apply(auto simp:jump_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "program_content (cctx_program c)
                   (uint (hd (vctx_stack v)))")
apply auto
apply(cases "get_some (program_content (cctx_program c)
                   (uint (hd (vctx_stack v))))")
apply auto
apply(cases "get_pc (program_content (cctx_program c)
                   (uint (hd (vctx_stack v))))")
apply auto
done

theorem lemma_jump_foo2 [simp] :
"jump (v\<lparr>vctx_stack := a # lista\<rparr>) c = InstructionContinue nv \<Longrightarrow>
 vctx_memory_usage v = vctx_memory_usage nv"
apply(auto simp:jump_def)
apply(cases "program_content (cctx_program c)
                   (uint a)")
apply auto
apply(cases "get_some (program_content (cctx_program c)
                   (uint a))")
apply auto
apply(cases "get_pc (program_content (cctx_program c)
                   (uint a))")
apply auto
done

theorem memory_usage_grows :
  "instruction_aux v c inst = InstructionContinue nv \<Longrightarrow>
   vctx_memory_usage v \<le> vctx_memory_usage nv"
apply(cases inst)
apply(auto simp:instruction_aux_def)
apply(cases "get_bits (Some inst)",
   auto simp:lemma_stack_2_1_op2 lemma_stack_3_1_op2 lemma_stack_1_1_op2)
apply(cases "get_sarith (Some inst)",
   auto simp:lemma_stack_2_1_op2 lemma_stack_3_1_op2 lemma_stack_1_1_op2)
apply(cases "get_arith (Some inst)",
   auto simp:lemma_stack_2_1_op2 lemma_stack_3_1_op2 lemma_stack_1_1_op2)

apply(auto simp:sha3_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
apply(cases "get_info (Some inst)")
apply(auto simp:lemma_stack_2_1_op2 lemma_stack_3_1_op2 lemma_stack_1_1_op2)
apply(cases "index (vctx_stack v) (nat (uint (get_dup (Some inst))))")
apply(auto split:option.split)
apply(cases "get_memory (Some inst)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto split:option.split)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto split:option.split)
apply(cases "get_storage (Some inst)")
apply(auto simp:lemma_stack_2_1_op2 lemma_stack_3_1_op2
   lemma_stack_1_1_op2 lemma_sstore2)
apply(cases "get_pc (Some inst)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto simp:strict_if_def split:option.split)
apply(cases "hd (tl (vctx_stack v)) = 0")
apply(auto simp:blockedInstructionContinue_def split:option.split)

apply(cases "get_stack inst")
apply(auto simp:lemma_stack_2_1_op2 lemma_stack_3_1_op2 lemma_stack_1_1_op2)
apply(cases "vctx_stack v")
apply(auto split:option.split)
apply(cases "index (vctx_stack v)
              (nat (uint (get_swap (Some inst))))")
apply(auto split:option.split)
apply(cases "index (vctx_stack v) (Suc (nat (uint (get_swap (Some inst)))))")
apply(auto split:option.split)
apply(cases "index (vctx_stack v) 0")
apply(auto split:option.split)
apply(cases "get_log (Some inst)")
apply(auto)
apply(cases "get_misc (Some inst)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) < hd (vctx_stack v)")
apply(auto)

apply(cases "vctx_stack v")
apply(simp)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(cases "tl (tl (vctx_stack v))")
apply(simp)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(simp)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(simp)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(simp)
apply(cases "tl (tl (tl (tl (tl (tl (vctx_stack v))))))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) <
    hd (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (tl (vctx_stack v))))))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) <
    hd (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) <
    vctx_value_sent v")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
done

declare check_annotations_def [simp del]
declare vctx_next_instruction_def [simp del]

lemma gas_left :
  "program_step c (InstructionContinue v) = InstructionContinue nv \<Longrightarrow>
   vctx_gas nv \<ge> 0"
apply(auto simp:program_step_def)
apply(subst (asm) inst_gas)

apply(cases "\<not> check_annotations v c")
apply(auto)
apply(cases "vctx_next_instruction v c")
apply(auto)
apply(cases "check_resources v c (vctx_stack v)
  (get_some (vctx_next_instruction v c))")
apply(auto)

apply(cases "instruction_aux v c (get_some (vctx_next_instruction v c))")

apply(auto simp:no_modify_gas subtract_gas.simps)
apply(auto simp:check_resources_def)
using lemma_predict
  by (simp add: no_modify_gas)

lemma iter_reorder :
   "program_iter n c (program_step c v) =
    program_step c (program_iter n c v)"
apply(induction n arbitrary:v)
apply(auto)
done

lemma iter_gas_left :
  "vctx_gas v \<ge> 0 \<Longrightarrow>
   program_iter n c (InstructionContinue v) = InstructionContinue nv \<Longrightarrow>
   vctx_gas nv \<ge> 0"
apply(cases n)
apply(auto simp:iter_reorder)
using gas_left and  program_step_continue
  by metis

declare instruction_sem_def [simp del]

lemma no_spend_gas_exit :
   "instruction_aux v c inst = InstructionContinue nv \<Longrightarrow>
    no_spend_gas inst \<Longrightarrow>
    False"
apply(cases inst)
apply(auto simp:instruction_aux_def)
apply(cases "get_misc (Some inst)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "vctx_stack v")
apply(auto)
done

lemma step_gas_less :
  "0 \<le> vctx_memory_usage v \<Longrightarrow>
   program_step c (InstructionContinue v) = InstructionContinue nv \<Longrightarrow>
   vctx_gas nv < vctx_gas v"
apply(auto simp:program_step_def)

apply(cases "\<not> check_annotations v c")
apply(auto)
apply(cases "vctx_next_instruction v c")
apply(auto)
apply(cases "check_resources v c (vctx_stack v)
  (get_some (vctx_next_instruction v c))")
apply(auto)

apply(cases "instruction_sem v c (get_some (vctx_next_instruction v c))")
apply(auto)
apply(cases "\<not>no_spend_gas (vctx_next_instruction_default v c)")
using gas_smaller apply blast
apply auto
apply(simp add:vctx_next_instruction_default_def)
apply(subst (asm) inst_gas)
apply(cases "instruction_aux v c (get_some (vctx_next_instruction v c))")
apply(auto)
using no_spend_gas_exit
apply blast
done

lemma step_memory_usage :
 "0 \<le> vctx_memory_usage v \<Longrightarrow>
  program_step c (InstructionContinue v) =
         InstructionContinue nv \<Longrightarrow>
  0 \<le> vctx_memory_usage nv"
apply(auto simp:program_step_def)
apply(subst (asm) inst_gas)

apply(cases "\<not> check_annotations v c")
apply(auto)
apply(cases "vctx_next_instruction v c")
apply(auto)
apply(cases "check_resources v c (vctx_stack v)
  (get_some (vctx_next_instruction v c))")
apply(auto)
apply(cases "instruction_aux v c (get_some (vctx_next_instruction v c))")
apply(auto)
  using memory_usage_grows by force

lemma iter_gas_less_aux :
  "(
           0 \<le> vctx_memory_usage v2 \<Longrightarrow>
           program_iter n c
            (InstructionContinue v2) =
           InstructionContinue nv \<Longrightarrow>
           vctx_gas nv + int n
           \<le> vctx_gas v2 \<and>
           0 \<le> vctx_memory_usage nv) \<Longrightarrow>
       0 \<le> vctx_memory_usage v \<Longrightarrow>
       program_iter n c
        (program_step c
          (InstructionContinue v)) =
       InstructionContinue nv \<Longrightarrow>
       program_step c (InstructionContinue v) =
         InstructionContinue v2 \<Longrightarrow>
       0 \<le> vctx_memory_usage nv"
using step_memory_usage
apply fastforce
done

fun get_continue :: "instruction_result \<Rightarrow> variable_ctx" where
"get_continue (InstructionContinue v) = v"

lemma get_continue_lemma :
"program_iter n c
        (program_step c
          (InstructionContinue v)) =
       InstructionContinue nv \<Longrightarrow>
       program_step c
        (InstructionContinue v) =
       InstructionContinue
        (get_continue
          (program_step c
            (InstructionContinue v)))"
apply(cases "program_step c
            (InstructionContinue v)")
apply(auto)
using program_iter_failure apply blast
using program_iter_env apply blast
done

lemma iter_gas_less_aux2 :
"(0 \<le> vctx_memory_usage v2 \<Longrightarrow>
             program_iter n c
              (InstructionContinue v2) =
             InstructionContinue nv \<Longrightarrow>
             vctx_gas nv + int n
             \<le> vctx_gas v2 \<and>
             0 \<le> vctx_memory_usage
                   nv) \<Longrightarrow>
       0 \<le> vctx_memory_usage v \<Longrightarrow>
       program_iter n c
        (program_step c
          (InstructionContinue v)) =
       InstructionContinue nv \<Longrightarrow>
      program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
       vctx_gas nv  + (1 + int n) \<le> vctx_gas v"
using step_gas_less
  by (smt step_memory_usage)

lemma iter_gas_less :
  "0 \<le> vctx_memory_usage v \<Longrightarrow>
   program_iter n c (InstructionContinue v) = InstructionContinue nv \<Longrightarrow>
   (vctx_gas nv + n \<le> vctx_gas v \<and> 0 \<le> vctx_memory_usage nv)"
apply(induction n arbitrary:v)
apply(simp)
apply(auto)
defer

apply(rule_tac v=v and n=n and ?v2.0 = "get_continue (program_step c
          (InstructionContinue v))" in iter_gas_less_aux)
apply(auto)
using get_continue_lemma apply blast

apply(rule_tac v=v and n=n and ?v2.0 = "get_continue (program_step c
          (InstructionContinue v))" in iter_gas_less_aux2)
apply(auto)
using get_continue_lemma apply blast
done

lemma gas_will_run_out_aux :
  assumes a:"0 \<le> vctx_memory_usage v" and
   b:"vctx_gas v \<ge> 0" and
   c:"program_iter (nat (vctx_gas v)+1) c (InstructionContinue v) = InstructionContinue nv"
   shows "False"
proof -
   from iter_gas_less and a and c
   have "vctx_gas nv  + (nat (vctx_gas v)+1) \<le> vctx_gas v" by blast
   then have "vctx_gas nv < 0"
     by linarith
   then show False
     by (smt assms(3) b iter_gas_left)
qed

lemma gas_will_run_out :
  "0 \<le> vctx_memory_usage v \<Longrightarrow>
   vctx_gas v \<ge> 0 \<Longrightarrow>
   program_sem  stopper c (nat (vctx_gas v)+1) (InstructionContinue v) = InstructionContinue nv \<Longrightarrow>
   False"
apply(subst (asm) program_iter_is_sem)
using gas_will_run_out_aux apply blast
done

end


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

theory ExampleSystem
imports Access
begin

context begin interpretation Arch . (*FIXME: arch_split*)

definition
  nat_to_bl :: "nat \<Rightarrow> nat \<Rightarrow> bool list option"
where
  "nat_to_bl bits n \<equiv>
    if n \<ge> 2^bits then
      None
    else
      Some $ bin_to_bl bits (of_nat n)"

lemma nat_to_bl_id [simp]: "nat_to_bl (size (x :: (('a::len) word))) (unat x) = Some (to_bl x)"
  apply (clarsimp simp: nat_to_bl_def to_bl_def)
  apply (auto simp: uint_nat le_def word_size)
  done

(*---------------------------------------------------------*)

subsection \<open>Purpose\<close>

text \<open>

This file defines some example systems using the access control
definitions. The aim is a sanity check of the AC definitions, to
ensure they enable to reason about reasonable systems.

In particular, we want to make sure that

  . the function state_objs_to_policy does not connect everything to
  everything (Example 1)
  . we can talk about components sharing cnodes
  . we can talk about components sharing frames
  . we can have more than 1 untrusted component
  . we can have an EP between two untrusted components

\<close>

(*---------------------------------------------------------*)

subsection \<open>Generic functions / lemmas\<close>

text \<open>Defining the authority between labels.

In addition to the intuitive authority we want, we need to add all the
authority required to have a wellformed graph. So we define
complete_AgentAuthGraph to add these 'extra' authorities (at least all
the ones not depending on the current label). These are:

  . self-authority (each label needs all the authorities to itself).
  . if Control edge is present between 2 labels then we add all
    authorities between them.
  . Control authority is transitive: we add an Control edge
    between 2 labels if we can connect them via Control
    edges. Actually we add all authorities because of the second
    clause.

\<close>

definition
  complete_AuthGraph :: "'a auth_graph \<Rightarrow> 'a set \<Rightarrow> 'a auth_graph"
where
  "complete_AuthGraph g ls \<equiv>
     g \<union> {(l,a,l) | a l. l \<in> ls}"

text \<open>converting a nat to a bool list of size 10 - for the cnodes\<close>

definition
  the_nat_to_bl :: "nat \<Rightarrow> nat \<Rightarrow> bool list"
where
  "the_nat_to_bl sz n \<equiv> the (nat_to_bl sz n)"

definition
  the_nat_to_bl_10  :: "nat \<Rightarrow> bool list"
where
  "the_nat_to_bl_10 n \<equiv> the_nat_to_bl 10 n"

lemma tcb_cnode_index_nat_to_bl:
  "n<10 \<Longrightarrow> the_nat_to_bl_10 n \<noteq> tcb_cnode_index n"
  by (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def
                     tcb_cnode_index_def
                     nat_to_bl_def to_bl_def bin_to_bl_aux_def)

(*---------------------------------------------------------*)
subsection \<open>Example 1\<close>

text \<open>

This example aims at checking that we can extract a reasonable policy
from the state, i.e. that the function state_objs_to_policy does not connect
everything to everything.

This example is a system Sys1 made of 2 main components UT1 and T1,
connected through and endpoint EP1. EP1 is made of one single kernel
object: obj1_9, the endpoint. Both UT1 and T1 contains:

  . one TCB (obj1_3079 and obj1_3080 resp.)
  . one vspace made up of one page directory (obj1_6063 and obj1_3065 resp.)
  . each pd contains a single page table (obj1_3072 and obj1_3077 resp.)
  . one cspace made up of one cnode (obj1_6 and obj1_7 resp.)
  . each cspace contains 4 caps:
         one to the tcb
         one to the cnode itself
         one to the vspace
         one to the ep

UT1 can send to the ep while T1 can receive from it.

Attempt to ASCII art:

          --------    ----                      ----     --------
          |       |   |  |                      |  |     |      |
          V       |   |  V     S             R  |  V     |      V
obj1_3079(tcb)-->obj1_6(cnode)--->obj1_9(ep)<---obj1_7(cnode)<--obj1_3080(tcb)
  |               |                                   |            |
  V               |                                   |            V
obj1_3063(pd)<-----                                    -------> obj1_3065(pd)
  |                                                                |
  V                                                                V
obj1_3072(pt)                                                      obj1_3077(pt)

(the references are derived from the dump of the SAC system)

The aim is to be able to prove

  pas_refined Sys1PAS s1

where Sys1PAS is the label graph defining the AC policy for Sys1 and
s1 is the state of Sys1 described above.

This shows that the aag extracted from s1 (by state_objs_to_policy) is
included in the policy graph Sys1PAS.

\<close>

subsubsection \<open>Defining the State\<close>

text \<open>We need to define the asids of each pd and pt to ensure that
the object is included in the right ASID-label\<close>

text \<open>UT1's ASID\<close>

definition
  asid1_3063 :: machine_word
where
  "asid1_3063 \<equiv> 1<<asid_low_bits"

text \<open>T1's ASID\<close>

definition
  asid1_3065 :: machine_word
where
  "asid1_3065 \<equiv> 2<<asid_low_bits"

lemma "asid_high_bits_of asid1_3065 \<noteq> asid_high_bits_of asid1_3063"
by (simp add: asid1_3063_def asid_high_bits_of_def asid1_3065_def asid_low_bits_def)

text \<open>UT1's CSpace\<close>

definition
  caps1_6 :: cnode_contents
where
  "caps1_6 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 3079,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 6 undefined undefined,
        (the_nat_to_bl_10 3)
            \<mapsto> ArchObjectCap (PageDirectoryCap 3063
                                             (Some asid1_3063)),
        (the_nat_to_bl_10 318)
            \<mapsto> EndpointCap  9 0 {AllowSend} )"

definition
  obj1_6 :: kernel_object
where
  "obj1_6 \<equiv> CNode 10 caps1_6"

text \<open>T1's Cspace\<close>

definition
  caps1_7 :: cnode_contents
where
  "caps1_7 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 3080,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 7 undefined undefined,
        (the_nat_to_bl_10 3)
           \<mapsto> ArchObjectCap (PageDirectoryCap 3065
                                            (Some asid1_3065)),
        (the_nat_to_bl_10 318)
           \<mapsto> EndpointCap  9 0 {AllowRecv}) "

definition
  obj1_7 :: kernel_object
where
  "obj1_7 \<equiv> CNode 10 caps1_7"

text \<open>endpoint between UT1 and T1\<close>

definition
  obj1_9 :: kernel_object
where
  "obj1_9 \<equiv> Endpoint IdleEP"

text \<open>UT1's VSpace (PageDirectory)\<close>

definition
  pt1_3072 :: "word8 \<Rightarrow> pte "
where
  "pt1_3072 \<equiv> (\<lambda>_. InvalidPTE)"

definition
  obj1_3072 :: kernel_object
where
  "obj1_3072 \<equiv> ArchObj (PageTable pt1_3072)"

definition
  pd1_3063 :: "12 word \<Rightarrow> pde "
where
  "pd1_3063 \<equiv>
    (\<lambda>_. InvalidPDE)
     (0 := PageTablePDE
              (addrFromPPtr 3072)
              undefined
              undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj1_3063 :: kernel_object
where
  "obj1_3063 \<equiv> ArchObj (PageDirectory pd1_3063)"

text \<open>T1's VSpace (PageDirectory)\<close>

definition
  pt1_3077 :: "word8 \<Rightarrow> pte "
where
  "pt1_3077 \<equiv>
    (\<lambda>_. InvalidPTE)"

definition
  obj1_3077 :: kernel_object
where
  "obj1_3077 \<equiv> ArchObj (PageTable pt1_3077)"

definition
  pd1_3065 :: "12 word \<Rightarrow> pde "
where
  "pd1_3065 \<equiv>
    (\<lambda>_. InvalidPDE)
     (0 := PageTablePDE
             (addrFromPPtr 3077)
             undefined
             undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj1_3065 :: kernel_object
where
  "obj1_3065 \<equiv> ArchObj (PageDirectory pd1_3065)"

text \<open>UT1's tcb\<close>

definition
  obj1_3079 :: kernel_object
where
  "obj1_3079 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 6 undefined undefined,
     tcb_vtable             = ArchObjectCap (PageDirectoryCap 3063 (Some asid1_3063)),
     tcb_reply              = ReplyCap 3079 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = Running,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch               = \<lparr>tcb_context = undefined\<rparr> \<rparr>"

text \<open>T1's tcb\<close>

definition
  obj1_3080 :: kernel_object
where
  "obj1_3080 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 7 undefined undefined,
     tcb_vtable             = ArchObjectCap (PageDirectoryCap 3065 (Some asid1_3065)),
     tcb_reply              = ReplyCap 3080 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = BlockedOnReceive 9 \<lparr> receiver_can_grant = False \<rparr>,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch               = \<lparr>tcb_context = undefined\<rparr>\<rparr>"

definition
 "obj1_10 \<equiv> CNode 10 (Map.empty([] \<mapsto> cap.NullCap))"

(* the boolean in BlockedOnReceive is True if the object can receive but not send.
but Tom says it only matters if the sender can grant - which is not the case of the UT1 - I think *)

definition
  kh1 :: kheap
where
  "kh1 \<equiv> [ 6 \<mapsto> obj1_6,
          7 \<mapsto> obj1_7,
          9 \<mapsto> obj1_9,
          10 \<mapsto> obj1_10,
          3063 \<mapsto> obj1_3063,
          3065 \<mapsto> obj1_3065,
          3072 \<mapsto> obj1_3072,
          3077 \<mapsto> obj1_3077,
          3079 \<mapsto> obj1_3079,
          3080 \<mapsto> obj1_3080 ]"

lemmas kh1_obj_def =
  obj1_6_def obj1_7_def obj1_9_def obj1_10_def obj1_3063_def obj1_3065_def
  obj1_3072_def obj1_3077_def obj1_3079_def obj1_3080_def

definition exst1 :: "det_ext" where
  "exst1 \<equiv> \<lparr>work_units_completed_internal = undefined,
             scheduler_action_internal = undefined,
             ekheap_internal = \<lambda>x. None,
             domain_list_internal = undefined,
             domain_index_internal = undefined,
             cur_domain_internal = undefined,
             domain_time_internal = undefined,
             ready_queues_internal = undefined,
             cdt_list_internal = undefined\<rparr>"

definition
  s1 :: "det_ext state"
where
  "s1 \<equiv>  \<lparr>
    kheap = kh1,
    cdt = Map.empty,
    is_original_cap = undefined,
    cur_thread = undefined,
    idle_thread = undefined,
    machine_state = undefined,
    interrupt_irq_node = (\<lambda>_. 10),
    interrupt_states = undefined,
    arch_state = \<lparr>
        arm_asid_table = (\<lambda> x. None),
        arm_hwasid_table = undefined,
        arm_next_asid = undefined,
        arm_asid_map = undefined,
        arm_global_pd = undefined,
        arm_global_pts = undefined,
        arm_kernel_vspace = undefined
        \<rparr>,
     exst = exst1
    \<rparr>"

subsubsection \<open>Defining the policy graph\<close>

datatype Sys1Labels =
    UT1 | T1 | EP1 | IRQ1

definition
  Sys1AgentMap :: "Sys1Labels agent_map"
where
  "Sys1AgentMap \<equiv>
   (\<lambda>_. undefined)
     (6 := UT1,
      7 := T1,
      9 := EP1,
      10 := IRQ1,
      3063 := UT1,
      3065 := T1,
      3072 := UT1,
      3077 := T1,
      3079 := UT1,
      3080 := T1 )"

lemma Sys1AgentMap_simps:
  "Sys1AgentMap 6 = UT1"
      "Sys1AgentMap 7 = T1"
      "Sys1AgentMap 9 = EP1"
      "Sys1AgentMap 10 = IRQ1"
      "Sys1AgentMap 3063 = UT1"
      "Sys1AgentMap 3065 = T1"
      "Sys1AgentMap 3072 = UT1"
      "Sys1AgentMap 3077 = T1"
      "Sys1AgentMap 3079 = UT1"
      "Sys1AgentMap 3080 = T1"
  unfolding Sys1AgentMap_def by simp_all

definition
  Sys1AuthGraph_aux :: "Sys1Labels auth_graph"
where
    "Sys1AuthGraph_aux \<equiv>
  { (UT1, auth.SyncSend,    EP1),
    (UT1, auth.Reset,   EP1),
    (T1,  auth.Receive, EP1),
    (T1,  auth.Reset,   EP1) }"

definition
  Sys1AuthGraph:: "Sys1Labels auth_graph"
where
    "Sys1AuthGraph \<equiv> complete_AuthGraph Sys1AuthGraph_aux {T1, UT1}"

definition
  Sys1ASIDMap :: "Sys1Labels agent_asid_map"
where
  "Sys1ASIDMap \<equiv>
    (\<lambda>x. if (asid_high_bits_of x = asid_high_bits_of asid1_3063)
          then UT1
         else if (asid_high_bits_of x = asid_high_bits_of asid1_3065)
          then T1 else undefined)"

definition Sys1PAS :: "Sys1Labels PAS" where
  "Sys1PAS \<equiv> \<lparr> pasObjectAbs = Sys1AgentMap, pasASIDAbs = Sys1ASIDMap, pasIRQAbs = (\<lambda>_. IRQ1),
              pasPolicy = Sys1AuthGraph, pasSubject = UT1, pasMayActivate = True, pasMayEditReadyQueues = True, pasMaySendIrqs = True, pasDomainAbs = undefined \<rparr>"

subsubsection \<open>Proof of pas_refined for Sys1\<close>

lemma caps1_7_well_formed: "well_formed_cnode_n 10 caps1_7"
 apply (clarsimp simp: caps1_7_def well_formed_cnode_n_def)
 apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
 apply (clarsimp simp: empty_cnode_def dom_def)
 apply (rule set_eqI, clarsimp)
 apply (rule iffI)
  apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
 apply clarsimp
done

lemma caps1_6_well_formed: "well_formed_cnode_n 10 caps1_6"
 apply (clarsimp simp: caps1_6_def well_formed_cnode_n_def)
 apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
 apply (clarsimp simp: empty_cnode_def dom_def)
 apply (rule set_eqI, clarsimp)
 apply (rule iffI)
  apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
 apply clarsimp
done

(* clagged from KernelInit_R *)
lemma empty_cnode_apply[simp]:
  "(empty_cnode n xs = Some cap) = (length xs = n \<and> cap = NullCap)"
  by (auto simp add: empty_cnode_def)

lemma s1_caps_of_state :
  "caps_of_state s1 p = Some cap \<Longrightarrow>
     cap = NullCap \<or>
     (p,cap) \<in>
       { ((6::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 3079),
         ((6::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 6 undefined undefined),
         ((6::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageDirectoryCap 3063 (Some asid1_3063))),
         ((6::obj_ref,(the_nat_to_bl_10 318)),EndpointCap  9 0 {AllowSend}),
         ((7::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 3080),
         ((7::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 7 undefined undefined),
         ((7::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageDirectoryCap 3065 (Some asid1_3065))),
         ((7::obj_ref,(the_nat_to_bl_10 318)),EndpointCap  9 0 {AllowRecv}) ,
         ((3079::obj_ref, (tcb_cnode_index 0)), CNodeCap 6 undefined undefined ),
         ((3079::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageDirectoryCap 3063 (Some asid1_3063))),
         ((3079::obj_ref, (tcb_cnode_index 2)), ReplyCap 3079 True {AllowGrant,AllowWrite}),
         ((3079::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((3079::obj_ref, (tcb_cnode_index 4)), NullCap),
         ((3080::obj_ref, (tcb_cnode_index 0)), CNodeCap 7 undefined undefined ),
         ((3080::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageDirectoryCap 3065 (Some asid1_3065))),
         ((3080::obj_ref, (tcb_cnode_index 2)), ReplyCap 3080 True {AllowGrant,AllowWrite}),
         ((3080::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((3080::obj_ref, (tcb_cnode_index 4)), NullCap)} "
  apply (insert caps1_7_well_formed)
  apply (insert caps1_6_well_formed)
  apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s1_def kh1_def kh1_obj_def)
  apply (case_tac p, clarsimp)
  apply (clarsimp split: if_splits)
     apply (clarsimp simp: cte_wp_at_cases tcb_cap_cases_def
                     split: if_split_asm)+
   apply (clarsimp simp: caps1_7_def split: if_splits)
  apply (clarsimp simp: caps1_6_def cte_wp_at_cases  split: if_splits)
done

lemma Sys1_wellformed: "pas_wellformed Sys1PAS"
 apply (clarsimp simp: Sys1PAS_def
                    policy_wellformed_def
                    Sys1AuthGraph_def
                    Sys1AuthGraph_aux_def
                    complete_AuthGraph_def)
 apply blast
 done

lemma tcb_states_of_state_1:
  "tcb_states_of_state s1 = [0xC08 \<mapsto> thread_state.BlockedOnReceive 9 \<lparr> receiver_can_grant = False \<rparr>,  0xC07 \<mapsto> thread_state.Running ]"
  unfolding s1_def tcb_states_of_state_def
  apply (rule ext)
  apply (simp add: get_tcb_def)
  apply (simp add: kh1_def kh1_obj_def )
  done

lemma thread_bound_ntfns_1:
  "thread_bound_ntfns s1 = Map.empty"
  unfolding s1_def thread_bound_ntfns_def
  apply (rule ext)
  apply (simp add: get_tcb_def)
  apply (simp add: kh1_def kh1_obj_def )
  done

declare AllowSend_def[simp] AllowRecv_def[simp]

lemma domains_of_state_s1[simp]:
  "domains_of_state s1 = {}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply clarsimp
   apply(erule domains_of_state_aux.induct)
   apply(simp add: s1_def exst1_def)
  apply simp
  done

lemma "pas_refined Sys1PAS s1"
  apply (clarsimp simp: pas_refined_def)
  apply (intro conjI)
       subgoal by (simp add: Sys1_wellformed)
      subgoal by (simp add: irq_map_wellformed_aux_def s1_def Sys1AgentMap_simps Sys1PAS_def)
     subgoal by (simp  add: tcb_domain_map_wellformed_aux_def)
    apply (clarsimp simp: auth_graph_map_def
                           Sys1PAS_def
                           state_objs_to_policy_def
                           )+
    apply (erule state_bits_to_policy.cases, simp_all, clarsimp)
          apply (drule s1_caps_of_state, clarsimp)
          apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def)
          apply (elim disjE conjE; solves\<open>clarsimp simp: Sys1AgentMap_simps cap_auth_conferred_def cap_rights_to_auth_def\<close>)
         apply (drule s1_caps_of_state, clarsimp)
         apply (elim disjE; solves \<open>simp add: thread_bound_ntfns_def\<close>)
        apply (clarsimp simp: state_refs_of_def thread_states_def tcb_states_of_state_1
               Sys1AuthGraph_def Sys1AgentMap_simps
               complete_AuthGraph_def
               Sys1AuthGraph_aux_def
               split: if_splits)
       apply (simp add:  thread_bound_ntfns_1)
      apply (simp add: s1_def) (* this is OK because cdt is empty..*)
     apply (simp add: s1_def) (* this is OK because cdt is empty..*)

    apply (fastforce simp: state_vrefs_def
                           vs_refs_no_global_pts_def
                           s1_def kh1_def  Sys1AgentMap_simps
                           kh1_obj_def comp_def pt1_3072_def pt1_3077_def pte_ref_def pde_ref2_def pd1_3065_def pd1_3063_def
                           Sys1AuthGraph_def ptr_range_def
                           complete_AuthGraph_def
                           Sys1AuthGraph_aux_def
                     dest!: graph_ofD
                     split: if_splits)

   apply (rule subsetI, clarsimp)
   apply (erule state_asids_to_policy_aux.cases)
     apply clarsimp
     apply (drule s1_caps_of_state, clarsimp)
     apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def Sys1PAS_def Sys1ASIDMap_def)
     apply (elim disjE conjE, simp_all add: Sys1AgentMap_simps cap_auth_conferred_def cap_rights_to_auth_def asid1_3065_def asid1_3063_def
       asid_low_bits_def asid_high_bits_of_def )[1]
    apply (clarsimp simp: state_vrefs_def
                           vs_refs_no_global_pts_def
                           s1_def kh1_def  Sys1AgentMap_simps
                           kh1_obj_def comp_def pt1_3072_def pt1_3077_def pte_ref_def pde_ref2_def pd1_3065_def pd1_3063_def
                           Sys1AuthGraph_def ptr_range_def
                           complete_AuthGraph_def
                           Sys1AuthGraph_aux_def
                     dest!: graph_ofD
                     split: if_splits)
   apply (clarsimp simp: s1_def)
  apply (rule subsetI, clarsimp)
  apply (erule state_irqs_to_policy_aux.cases)
  apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def Sys1PAS_def Sys1ASIDMap_def)
  apply (drule s1_caps_of_state)
  apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def Sys1PAS_def Sys1ASIDMap_def)
  apply (elim disjE conjE, simp_all add: Sys1AgentMap_simps cap_auth_conferred_def cap_rights_to_auth_def asid1_3065_def asid1_3063_def
    asid_low_bits_def asid_high_bits_of_def )[1]
   done

(*---------------------------------------------------------*)
subsection \<open>Example 2\<close>

text \<open>

This example systems Sys2 aims at checking that we can have 2
components, one untrusted UT2 and one truted T1, sharing a cnode obj2_5.

Both UT2 and T2 contains:

  . one TCB (obj2_3079 and obj2_3080 resp.)
  . one vspace made up of one page directory (obj2_6063 and obj2_3065 resp.)
  . each pd contains a single page table (obj2_3072 and obj2_3077 resp.)
  . one cspace made up of one cnode (obj2_6 and obj2_7 resp.)
  . each cspace contains 4 caps:
         one to the tcb
         one to the cnode itself
         one to the vspace
         one to obj2_5

Attempt to ASCII art:

          --------    ----                          ----     --------
          |       |   |  |                          |  |     |      |
          V       |   |  V     S             R      |  V     |      V
obj2_3079(tcb)-->obj2_6(cnode)--->obj2_5(cnode)<---obj2_7(cnode)<--obj2_3080(tcb)
  |               |                                   |            |
  V               |                                   |            V
obj2_3063(pd)<-----                                    -------> obj2_3065(pd)
  |                                                                |
  V                                                                V
obj2_3072(pt)                                                      obj2_3077(pt)

(the references are derived from the dump of the SAC system)

The aim is to be able to prove

  pas_refined Sys2PAS s2

where Sys2PAS is the label graph defining the AC policy for Sys2 and
s2 is the state of Sys2 described above.

This shows that the aag extracted from s2 (by state_objs_to_policy) is
included in the policy graph Sys2PAS.

\<close>

subsubsection \<open>Defining the State\<close>

text \<open>We need to define the asids of each pd and pt to ensure that
the object is included in the right ASID-label\<close>

text \<open>UT2's ASID\<close>

definition
  asid2_3063 :: machine_word
where
  "asid2_3063 \<equiv> 1<<asid_low_bits"

text \<open>T2's ASID\<close>

definition
  asid2_3065 :: machine_word
where
  "asid2_3065 \<equiv> 2<<asid_low_bits"

lemma "asid_high_bits_of asid2_3065 \<noteq> asid_high_bits_of asid2_3063"
by (simp add: asid2_3063_def asid_high_bits_of_def asid2_3065_def asid_low_bits_def)

text \<open>the intermediaite CSpace\<close>

definition
  caps2_5 :: cnode_contents
where
  "caps2_5 \<equiv>
   (empty_cnode 10)"

definition
  obj2_5 :: kernel_object
where
  "obj2_5 \<equiv> CNode 10 caps2_5"

text \<open>UT2's CSpace\<close>

definition
  caps2_6 :: cnode_contents
where
  "caps2_6 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 3079,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 6 undefined undefined,
        (the_nat_to_bl_10 3)
            \<mapsto> ArchObjectCap (PageDirectoryCap 3063
                                             (Some asid2_3063)),
        (the_nat_to_bl_10 4)
            \<mapsto> CNodeCap 5 undefined undefined )"

definition
  obj2_6 :: kernel_object
where
  "obj2_6 \<equiv> CNode 10 caps2_6"

text \<open>T2's Cspace\<close>

definition
  caps2_7 :: cnode_contents
where
  "caps2_7 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 3080,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 7 undefined undefined,
        (the_nat_to_bl_10 3)
           \<mapsto> ArchObjectCap (PageDirectoryCap 3065
                                            (Some asid2_3065)),
        (the_nat_to_bl_10 4)
            \<mapsto> CNodeCap 5 undefined undefined) "

definition
  obj2_7 :: kernel_object
where
  "obj2_7 \<equiv> CNode 10 caps2_7"

text \<open>endpoint between UT2 and T2\<close>

definition
  obj2_9 :: kernel_object
where
  "obj2_9 \<equiv> Endpoint IdleEP"

text \<open>UT2's VSpace (PageDirectory)\<close>

definition
  pt2_3072 :: "word8 \<Rightarrow> pte "
where
  "pt2_3072 \<equiv> (\<lambda>_. InvalidPTE)"

definition
  obj2_3072 :: kernel_object
where
  "obj2_3072 \<equiv> ArchObj (PageTable pt2_3072)"

definition
  pd2_3063 :: "12 word \<Rightarrow> pde "
where
  "pd2_3063 \<equiv>
    (\<lambda>_. InvalidPDE)
     (0 := PageTablePDE
              (addrFromPPtr 3072)
              undefined
              undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj2_3063 :: kernel_object
where
  "obj2_3063 \<equiv> ArchObj (PageDirectory pd2_3063)"

text \<open>T1's VSpace (PageDirectory)\<close>

definition
  pt2_3077 :: "word8 \<Rightarrow> pte "
where
  "pt2_3077 \<equiv>
    (\<lambda>_. InvalidPTE)"

definition
  obj2_3077 :: kernel_object
where
  "obj2_3077 \<equiv> ArchObj (PageTable pt2_3077)"

definition
  pd2_3065 :: "12 word \<Rightarrow> pde "
where
  "pd2_3065 \<equiv>
    (\<lambda>_. InvalidPDE)
     (0 := PageTablePDE
             (addrFromPPtr 3077)
             undefined
             undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj2_3065 :: kernel_object
where
  "obj2_3065 \<equiv> ArchObj (PageDirectory pd2_3065)"

text \<open>UT1's tcb\<close>

definition
  obj2_3079 :: kernel_object
where
  "obj2_3079 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 6 undefined undefined ,
     tcb_vtable             = ArchObjectCap (PageDirectoryCap 3063 (Some asid2_3063)),
     tcb_reply              = ReplyCap 3079 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = Running,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch          = \<lparr>tcb_context = undefined\<rparr>\<rparr>"

text \<open>T1's tcb\<close>

definition
  obj2_3080 :: kernel_object
where
  "obj2_3080 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 7 undefined undefined ,
     tcb_vtable             = ArchObjectCap (PageDirectoryCap 3065 (Some asid2_3065)),
     tcb_reply              = ReplyCap 3080 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = BlockedOnReceive 9 \<lparr> receiver_can_grant = False \<rparr>,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch               = \<lparr>tcb_context = undefined\<rparr>\<rparr>"

(* the boolean in BlockedOnReceive is True if the object can receive but not send.
but Tom says it only matters if the sender can grant - which is not the case of the UT1 - I think *)

definition
  kh2 :: kheap
where
  "kh2 \<equiv> [ 6 \<mapsto> obj2_6,
          7 \<mapsto> obj2_7,
          9 \<mapsto> obj2_9,
          3063 \<mapsto> obj2_3063,
          3065 \<mapsto> obj2_3065,
          3072 \<mapsto> obj2_3072,
          3077 \<mapsto> obj2_3077,
          3079 \<mapsto> obj2_3079,
          3080 \<mapsto> obj2_3080 ]"

lemmas kh2_obj_def =
  obj2_6_def obj2_7_def obj2_9_def obj2_3063_def obj2_3065_def
  obj2_3072_def obj2_3077_def obj2_3079_def obj2_3080_def

definition
  s2 :: "det_ext state"
where
  "s2 \<equiv>  \<lparr>
    kheap = kh2,
    cdt = Map.empty,
    is_original_cap = undefined,
    cur_thread = undefined,
    idle_thread = undefined,
    machine_state = undefined,
    interrupt_irq_node = (\<lambda>_. 9001),
    interrupt_states = undefined,
    arch_state = \<lparr>
        arm_asid_table = (\<lambda> x. None),
        arm_hwasid_table = undefined,
        arm_next_asid = undefined,
        arm_asid_map = undefined,
        arm_global_pd = undefined,
        arm_global_pts = undefined,
        arm_kernel_vspace = undefined
        \<rparr>,
    exst = exst1
    \<rparr>"

subsubsection \<open>Defining the policy graph\<close>

datatype Sys2Labels =
    UT2 | T2 | IRQ2

definition
  Sys2AgentMap :: "Sys2Labels agent_map"
where
  "Sys2AgentMap \<equiv>
   (\<lambda>_. undefined)
     (5 := UT2,
      6 := UT2,
      7 := T2,
      9 := T2,
      3063 := UT2,
      3065 := T2,
      3072 := UT2,
      3077 := T2,
      3079 := UT2,
      3080 := T2,
      9001 := IRQ2 )"

definition
  Sys2AuthGraph_aux :: "Sys2Labels auth_graph"
where
    "Sys2AuthGraph_aux \<equiv>
       { (T2, Control, UT2) }"

definition
  Sys2AuthGraph:: "Sys2Labels auth_graph"
where
    "Sys2AuthGraph \<equiv> complete_AuthGraph Sys2AuthGraph_aux {T2, UT2}"

definition
  Sys2ASIDMap :: "Sys2Labels agent_asid_map"
where
  "Sys2ASIDMap \<equiv>
    (\<lambda>_. undefined)
     (asid2_3063 := UT2,
      asid2_3065 := T2 )"

definition Sys2PAS :: "Sys2Labels PAS" where
  "Sys2PAS \<equiv> \<lparr> pasObjectAbs = Sys2AgentMap, pasASIDAbs = Sys2ASIDMap,
              pasIRQAbs = (\<lambda>_. IRQ2),
              pasPolicy = Sys2AuthGraph, pasSubject = UT2, pasMayActivate = True, pasMayEditReadyQueues = True, pasMaySendIrqs = True, pasDomainAbs = undefined \<rparr>"

subsubsection \<open>Proof of pas_refined for Sys2\<close>

lemma caps2_7_well_formed: "well_formed_cnode_n 10 caps2_7"
 apply (clarsimp simp: caps2_7_def well_formed_cnode_n_def)
 apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
 apply (clarsimp simp: empty_cnode_def dom_def)
 apply (rule set_eqI, clarsimp)
 apply (rule iffI)
  apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
 apply clarsimp
done

lemma caps2_6_well_formed: "well_formed_cnode_n 10 caps2_6"
 apply (clarsimp simp: caps2_6_def well_formed_cnode_n_def)
 apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
 apply (clarsimp simp: empty_cnode_def dom_def)
 apply (rule set_eqI, clarsimp)
 apply (rule iffI)
  apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
 apply clarsimp
done

lemma s2_caps_of_state :
  "caps_of_state s2 p = Some cap \<Longrightarrow>
     cap = NullCap \<or>
     (p,cap) \<in>
       { ((6::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 3079),
         ((6::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 6 undefined undefined),
         ((6::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageDirectoryCap 3063 (Some asid2_3063))),
         ((6::obj_ref,(the_nat_to_bl_10 4)),  CNodeCap 5 undefined undefined),
         ((7::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 3080),
         ((7::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 7 undefined undefined),
         ((7::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageDirectoryCap 3065 (Some asid2_3065))),
         ((7::obj_ref,(the_nat_to_bl_10 4)),  CNodeCap 5 undefined undefined),
         ((3079::obj_ref, (tcb_cnode_index 0)), CNodeCap 6 undefined undefined ),
         ((3079::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageDirectoryCap 3063 (Some asid2_3063))),
         ((3079::obj_ref, (tcb_cnode_index 2)), ReplyCap 3079 True {AllowGrant,AllowWrite}),
         ((3079::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((3079::obj_ref, (tcb_cnode_index 4)), NullCap),
         ((3080::obj_ref, (tcb_cnode_index 0)), CNodeCap 7 undefined undefined ),
         ((3080::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageDirectoryCap 3065 (Some asid2_3065))),
         ((3080::obj_ref, (tcb_cnode_index 2)), ReplyCap 3080 True {AllowGrant,AllowWrite}),
         ((3080::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((3080::obj_ref, (tcb_cnode_index 4)), NullCap)} "
  apply (insert caps2_7_well_formed)
  apply (insert caps2_6_well_formed)
  apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s2_def kh2_def kh2_obj_def)
  apply (case_tac p, clarsimp)
  apply (clarsimp simp: cte_wp_at_cases split: if_splits)
     apply (clarsimp simp: tcb_cap_cases_def split: if_splits)+
   apply (clarsimp simp: caps2_7_def split: if_splits)
  apply (clarsimp simp: caps2_6_def cte_wp_at_cases  split: if_splits)
done

lemma Sys2_wellformed: "pas_wellformed Sys2PAS"
  apply (clarsimp simp: Sys2PAS_def policy_wellformed_def)
  apply (intro conjI)
  apply (simp_all add: Sys2AuthGraph_def complete_AuthGraph_def
                       Sys2AuthGraph_aux_def)
  done

lemma Sys2AgentMap_simps:
  "Sys2AgentMap 5 = UT2"
  "Sys2AgentMap 6 = UT2"
  "Sys2AgentMap 7 = T2"
  "Sys2AgentMap 9 = T2"
  "Sys2AgentMap 3063 = UT2"
  "Sys2AgentMap 3065 = T2"
  "Sys2AgentMap 3072 = UT2"
  "Sys2AgentMap 3077 = T2"
  "Sys2AgentMap 3079 = UT2"
  "Sys2AgentMap 3080 = T2"
  "Sys2AgentMap 9001 = IRQ2"
  by (simp_all add: Sys2AgentMap_def)

lemma domains_of_state_s2[simp]:
  "domains_of_state s2 = {}"
  apply(rule equalityI)
   apply(rule subsetI)
   apply clarsimp
   apply(erule domains_of_state_aux.induct)
   apply(simp add: s2_def exst1_def)
  apply simp
  done

lemma thread_bound_ntfns_2[simp]:
  "thread_bound_ntfns s2 = Map.empty"
  unfolding s2_def thread_bound_ntfns_def
  apply (rule ext)
  apply (simp add: get_tcb_def)
  apply (simp add: kh2_def kh2_obj_def)
  done

lemma "pas_refined Sys2PAS s2"
  apply (clarsimp simp: pas_refined_def)
  apply (intro conjI)
      apply (simp add: Sys2_wellformed)
     apply (simp add: Sys2PAS_def s2_def Sys2AgentMap_def
                      irq_map_wellformed_aux_def)
    apply (clarsimp simp: auth_graph_map_def
                          Sys2PAS_def
                          state_objs_to_policy_def
                          state_bits_to_policy_def tcb_domain_map_wellformed_aux_def)+
    apply (erule state_bits_to_policyp.cases, simp_all)
         apply (drule s2_caps_of_state, clarsimp)
         apply (elim disjE, simp_all add: cap_auth_conferred_def
                                          Sys2AgentMap_simps
                                          Sys2AuthGraph_def Sys2AuthGraph_aux_def
                                          complete_AuthGraph_def
                              split: if_split_asm)[1]
        apply (drule s2_caps_of_state, clarsimp)
        apply (elim disjE, simp_all)[1]
       apply (clarsimp simp: state_refs_of_def s2_def kh2_def kh2_obj_def
                       split: if_splits)
       apply (clarsimp split:if_splits option.splits
                       simp: thread_states_def tcb_states_of_state_def
                             Sys2AgentMap_simps Sys2AuthGraph_def
                             complete_AuthGraph_def Sys2AuthGraph_aux_def
                      dest!: get_tcb_SomeD)
      apply (simp add: s2_def) (* this is OK because cdt is empty..*)
     apply (simp add: s2_def) (* this is OK because cdt is empty..*)

    apply ((clarsimp simp: state_vrefs_def
                           vs_refs_no_global_pts_def
                           s2_def kh2_def
                           kh2_obj_def
                     split: if_splits,
           ((clarsimp split: if_splits
                     simp: pd2_3065_def pd2_3063_def graph_of_def pde_ref_def
                           Sys2AgentMap_simps Sys2AuthGraph_def
                           complete_AuthGraph_def pt2_3077_def pte_ref_def
                           pt2_3072_def pde_ref2_def
                           Sys2AuthGraph_aux_def ptr_range_def)+))+)[1]
   apply clarsimp
   apply (erule state_asids_to_policy_aux.cases)
    apply clarsimp
    apply (auto simp: Sys2PAS_def Sys2AuthGraph_def Sys2AuthGraph_aux_def
                      complete_AuthGraph_def Sys2AgentMap_simps
                      Sys2ASIDMap_def asid2_3063_def asid2_3065_def
                      asid_low_bits_def
               dest!: s2_caps_of_state)[1]
   apply (clarsimp simp: state_vrefs_def
                         vs_refs_no_global_pts_def
                         s2_def kh2_def
                         kh2_obj_def
                  split: if_splits)
   apply (clarsimp simp: s2_def)
  apply (clarsimp)
  apply (erule state_irqs_to_policy_aux.cases)
  apply (auto simp: Sys2PAS_def Sys2AuthGraph_def Sys2AuthGraph_aux_def
                    complete_AuthGraph_def Sys2AgentMap_simps
                    Sys2ASIDMap_def asid2_3063_def asid2_3065_def
             dest!: s2_caps_of_state)[1]
  done

end

end


(*  Title:      HOL/MicroJava/JVM/JVMExceptions.thy
    Author:     Gerwin Klein, Martin Strecker
    Copyright   2001 Technische Universitaet Muenchen
*)

section {* Exception handling in the JVM *}

theory JVMExceptions imports JVMInstructions begin

definition match_exception_entry :: "jvm_prog \<Rightarrow> cname \<Rightarrow> p_count \<Rightarrow> exception_entry \<Rightarrow> bool" where
  "match_exception_entry G cn pc ee ==
                 let (start_pc, end_pc, handler_pc, catch_type) = ee in
                 start_pc <= pc \<and> pc < end_pc \<and> G\<turnstile> cn \<preceq>C catch_type"

primrec match_exception_table :: "jvm_prog \<Rightarrow> cname \<Rightarrow> p_count \<Rightarrow> exception_table
    \<Rightarrow> p_count option"
where
  "match_exception_table G cn pc []     = None"
| "match_exception_table G cn pc (e#es) = (if match_exception_entry G cn pc e
                                           then Some (fst (snd (snd e)))
                                           else match_exception_table G cn pc es)"

abbreviation
  ex_table_of :: "jvm_method \<Rightarrow> exception_table"
  where "ex_table_of m == snd (snd (snd m))"

primrec find_handler :: "jvm_prog \<Rightarrow> val option \<Rightarrow> aheap \<Rightarrow> frame list
    \<Rightarrow> jvm_state"
where
  "find_handler G xcpt hp [] = (xcpt, hp, [])"
| "find_handler G xcpt hp (fr#frs) =
      (case xcpt of
         None \<Rightarrow> (None, hp, fr#frs)
       | Some xc \<Rightarrow>
       let (stk,loc,C,sig,pc) = fr in
       (case match_exception_table G (cname_of hp xc) pc
              (ex_table_of (snd(snd(the(method (G,C) sig))))) of
          None \<Rightarrow> find_handler G (Some xc) hp frs
        | Some handler_pc \<Rightarrow> (None, hp, ([xc], loc, C, sig, handler_pc)#frs)))"

text {*
  System exceptions are allocated in all heaps:
*}

text {*
  Only program counters that are mentioned in the exception table
  can be returned by @{term match_exception_table}:
*}
lemma match_exception_table_in_et:
  "match_exception_table G C pc et = Some pc' \<Longrightarrow> \<exists>e \<in> set et. pc' = fst (snd (snd e))"
  by (induct et) (auto split: split_if_asm)

end