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

theory SubMonad_AI
imports KHeap_AI
begin

(* SubMonadLib *)
lemma submonad_do_machine_op:
  "submonad machine_state (machine_state_update \<circ> K) \<top> do_machine_op"
  apply unfold_locales
       apply (clarsimp simp: ext stateAssert_def do_machine_op_def o_def gets_def
                             get_def bind_def return_def submonad_fn_def)+
  done

interpretation submonad_do_machine_op:
  submonad machine_state "(machine_state_update \<circ> K)" \<top> do_machine_op
  by (rule submonad_do_machine_op)

lemma submonad_args_pspace:
  "submonad_args kheap (kheap_update o (\<lambda>x _. x)) \<top>"
  by (simp add: submonad_args_def)

schematic_goal assert_get_tcb_pspace:
  "gets_the (get_tcb t) = submonad_fn kheap (kheap_update o (\<lambda>x _. x)) \<top> ?f"
  apply (unfold gets_the_def)
  apply (rule submonad_bind_alt [OF submonad_args_pspace])
     apply (rule gets_submonad [OF submonad_args_pspace _ refl])
     apply (simp add: get_tcb_def)
    apply (rule assert_opt_submonad [OF submonad_args_pspace])
   apply simp
  apply (rule empty_fail_assert_opt)
  done

lemma assert_get_thread_do_machine_op_comm:
  "empty_fail m' \<Longrightarrow>
   do x \<leftarrow> gets_the (get_tcb t); y \<leftarrow> do_machine_op m'; n x y od =
   do y \<leftarrow> do_machine_op m'; x \<leftarrow> gets_the (get_tcb t); n x y od"
  apply (rule submonad_comm2 [OF _ _ submonad_do_machine_op])
        apply (rule submonad_args_pspace)
       apply (rule assert_get_tcb_pspace)
      apply simp+
  done

end


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

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

theory n_german_lemma_on_inv__18 imports n_german_base
begin
section{*All lemmas on causal relation between inv__18 and some rule r*}
lemma n_StoreVsinv__18:
assumes a1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__18  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i d where a1:"i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__18  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)\<or>(i~=p__Inv2)\<or>(i=p__Inv2)\<or>(i~=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Inv)) (eqn (IVar (Field (Para (Ident ''Cache'') i) ''State'')) (Const E))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Inv)) (eqn (IVar (Field (Para (Ident ''Cache'') i) ''State'')) (Const E))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Inv)) (eqn (IVar (Field (Para (Ident ''Cache'') i) ''State'')) (Const E))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Inv)) (eqn (IVar (Field (Para (Ident ''Cache'') i) ''State'')) (Const E))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__0Vsinv__18:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__18  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__18  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (andForm (eqn (IVar (Para (Ident ''InvSet'') p__Inv2)) (Const true)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Empty))) (neg (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv2) ''Data'')) (IVar (Ident ''AuxData''))))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__18:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__18  p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv2 where a2:"p__Inv2\<le>N\<and>f=inv__18  p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i~=p__Inv2)\<or>(i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (andForm (eqn (IVar (Para (Ident ''InvSet'') p__Inv2)) (Const true)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Empty))) (neg (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv2) ''Data'')) (IVar (Ident ''AuxData''))))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

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

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

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

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

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

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

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

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

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

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

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

end


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

theory DetSchedInvs_AI
imports "$L4V_ARCH/ArchDeterministic_AI"
begin

lemma get_etcb_rev:
  "ekheap s p = Some etcb \<Longrightarrow> get_etcb p s = Some etcb"
   by (clarsimp simp: get_etcb_def)

lemma get_etcb_SomeD: "get_etcb ptr s = Some v \<Longrightarrow> ekheap s ptr = Some v"
  apply (case_tac "ekheap s ptr", simp_all add: get_etcb_def)
  done

definition obj_at_kh where
"obj_at_kh P ref kh \<equiv> obj_at P ref ((undefined :: det_ext state)\<lparr>kheap := kh\<rparr>)"

lemma obj_at_kh_simp[simp]: "obj_at_kh P ref (kheap st) = obj_at P ref st"
  apply (simp add: obj_at_def obj_at_kh_def)
  done

definition st_tcb_at_kh where
"st_tcb_at_kh test \<equiv> obj_at_kh (\<lambda>ko. \<exists>tcb. ko = TCB tcb \<and> test (tcb_state tcb))"

lemma st_tcb_at_kh_simp[simp]: "st_tcb_at_kh test t (kheap st) = st_tcb_at test t st"
  apply (simp add: pred_tcb_at_def st_tcb_at_kh_def)
  done

definition is_etcb_at' where
"is_etcb_at' ref ekh \<equiv> ekh ref \<noteq> None"

abbreviation is_etcb_at:: "obj_ref \<Rightarrow> det_ext state \<Rightarrow> bool" where
"is_etcb_at ref s \<equiv> is_etcb_at' ref (ekheap s)"

lemmas is_etcb_at_def = is_etcb_at'_def

definition etcb_at' :: "(etcb \<Rightarrow> bool) \<Rightarrow> obj_ref \<Rightarrow> (obj_ref \<Rightarrow> etcb option) \<Rightarrow> bool" where
"etcb_at' P ref ekh \<equiv> case ekh ref of Some x \<Rightarrow> P x | _ \<Rightarrow> True"

abbreviation etcb_at :: "(etcb \<Rightarrow> bool) \<Rightarrow> obj_ref \<Rightarrow> det_ext state \<Rightarrow> bool" where
"etcb_at P ref s \<equiv> etcb_at' P ref (ekheap s)"

lemmas etcb_at_def = etcb_at'_def

lemma etcb_at_taut[simp]: "etcb_at' \<top> ref ekh"
  apply (simp add: etcb_at'_def split: option.split)
  done

lemma etcb_at_conj_is_etcb_at:
  "(is_etcb_at' t ekh \<and> etcb_at' P t ekh)
     = (case ekh t of None \<Rightarrow> False | Some x \<Rightarrow> P x)"
  by (simp add: is_etcb_at_def etcb_at_def split: option.splits)

definition valid_etcbs_2 :: "(obj_ref \<Rightarrow> etcb option) \<Rightarrow> (obj_ref \<Rightarrow> kernel_object option) \<Rightarrow> bool"where
"valid_etcbs_2 ekh kh \<equiv> \<forall>ptr. (st_tcb_at_kh \<top> ptr kh) = (is_etcb_at' ptr ekh)"

abbreviation valid_etcbs :: "det_ext state \<Rightarrow> bool" where
"valid_etcbs s \<equiv> valid_etcbs_2 (ekheap s) (kheap s)"

lemmas valid_etcbs_def = valid_etcbs_2_def

definition
  valid_idle_etcb_2 :: "(obj_ref \<Rightarrow> etcb option) \<Rightarrow> bool"
where
  "valid_idle_etcb_2 ekh \<equiv> etcb_at' (\<lambda>etcb. tcb_domain etcb = default_domain) idle_thread_ptr ekh"

abbreviation valid_idle_etcb :: "det_ext state \<Rightarrow> bool" where
  "valid_idle_etcb s \<equiv> valid_idle_etcb_2 (ekheap s)"

lemmas valid_idle_etcb_def = valid_idle_etcb_2_def

definition not_queued_2 where
  "not_queued_2 qs t \<equiv> \<forall>d p. t \<notin> set (qs d p)"

abbreviation not_queued :: "obj_ref \<Rightarrow> det_ext state \<Rightarrow> bool" where
  "not_queued t s \<equiv> not_queued_2 (ready_queues s) t"

definition valid_queues_2 where
  "valid_queues_2 queues ekh kh \<equiv> (\<forall>d p.
     (\<forall>t \<in> set (queues d p). is_etcb_at' t ekh
                           \<and> etcb_at' (\<lambda>t. tcb_priority t = p \<and> tcb_domain t = d) t ekh
                           \<and> st_tcb_at_kh runnable t kh)
   \<and> distinct (queues d p))"

abbreviation valid_queues :: "det_ext state \<Rightarrow> bool" where
"valid_queues s \<equiv> valid_queues_2 (ready_queues s) (ekheap s) (kheap s)"

lemmas valid_queues_def = valid_queues_2_def

lemma valid_queues_def2:
  "valid_queues_2 queues ekh kh =
     (\<forall>d p. (\<forall>t \<in> set (queues d p).
              is_etcb_at' t ekh \<and>
              (case ekh t of None \<Rightarrow> False | Some x \<Rightarrow> tcb_priority x = p \<and> tcb_domain x = d) \<and>
              st_tcb_at_kh runnable t kh) \<and>
              distinct (queues d p))"
  by (clarsimp simp: valid_queues_def
                     conj_assoc[where P="is_etcb_at' t ekh \<and> (case ekh t of
                                           None \<Rightarrow> False |
                                           Some x \<Rightarrow> tcb_priority x = p \<and> tcb_domain x = d)"]
                     etcb_at_conj_is_etcb_at[symmetric])

definition valid_blocked_2 where
   "valid_blocked_2 queues kh sa ct \<equiv>
    (\<forall>t st. not_queued_2 queues t \<longrightarrow> st_tcb_at_kh (op = st) t kh \<longrightarrow>
            t \<noteq> ct \<longrightarrow> sa \<noteq> switch_thread t \<longrightarrow> (\<not> active st))"

abbreviation valid_blocked :: "det_ext state \<Rightarrow> bool" where
 "valid_blocked s \<equiv> valid_blocked_2 (ready_queues s) (kheap s) (scheduler_action s) (cur_thread s)"

lemmas valid_blocked_def = valid_blocked_2_def

definition valid_blocked_except_2 where
   "valid_blocked_except_2 thread queues kh sa ct \<equiv>
    (\<forall>t st. t \<noteq> thread \<longrightarrow> not_queued_2 queues t \<longrightarrow> st_tcb_at_kh (op = st) t kh \<longrightarrow>
            t \<noteq> ct \<longrightarrow> sa \<noteq> switch_thread t \<longrightarrow> (\<not> active st))"

abbreviation valid_blocked_except :: "obj_ref \<Rightarrow> det_ext state \<Rightarrow> bool" where
 "valid_blocked_except t s \<equiv> valid_blocked_except_2 t (ready_queues s) (kheap s) (scheduler_action s) (cur_thread s)"

lemmas valid_blocked_except_def = valid_blocked_except_2_def

definition in_cur_domain_2 where
  "in_cur_domain_2 thread cdom ekh \<equiv> etcb_at' (\<lambda>t. tcb_domain t = cdom) thread ekh"

abbreviation in_cur_domain :: "obj_ref \<Rightarrow> det_ext state \<Rightarrow> bool" where
  "in_cur_domain thread s \<equiv> in_cur_domain_2 thread (cur_domain s) (ekheap s)"

lemmas in_cur_domain_def = in_cur_domain_2_def

definition ct_in_cur_domain_2 where
  "ct_in_cur_domain_2 thread thread' sa cdom ekh \<equiv>
     sa = resume_cur_thread \<longrightarrow> thread = thread' \<or> in_cur_domain_2 thread cdom ekh"

abbreviation ct_in_cur_domain where
  "ct_in_cur_domain s \<equiv> ct_in_cur_domain_2 (cur_thread s) (idle_thread s) (scheduler_action s) (cur_domain s) (ekheap s)"

lemmas ct_in_cur_domain_def = ct_in_cur_domain_2_def

definition is_activatable_2 where
"is_activatable_2 thread sa kh \<equiv> sa = resume_cur_thread \<longrightarrow> st_tcb_at_kh activatable thread kh"

abbreviation is_activatable :: "obj_ref \<Rightarrow> det_ext state \<Rightarrow> bool"  where
"is_activatable thread s \<equiv> is_activatable_2 thread (scheduler_action s) (kheap s)"

lemmas is_activatable_def = is_activatable_2_def

definition weak_valid_sched_action_2 where
  "weak_valid_sched_action_2 sa ekh kh \<equiv>
    \<forall>t. sa = switch_thread t \<longrightarrow> st_tcb_at_kh runnable t kh"

abbreviation weak_valid_sched_action:: "det_ext state \<Rightarrow> bool" where
  "weak_valid_sched_action s \<equiv> weak_valid_sched_action_2 (scheduler_action s) (ekheap s) (kheap s)"

lemmas weak_valid_sched_action_def = weak_valid_sched_action_2_def

definition switch_in_cur_domain_2 where
  "switch_in_cur_domain_2 sa ekh cdom \<equiv>
    \<forall>t. sa = switch_thread t \<longrightarrow> in_cur_domain_2 t cdom ekh"

abbreviation switch_in_cur_domain:: "det_ext state \<Rightarrow> bool" where
  "switch_in_cur_domain s \<equiv> switch_in_cur_domain_2 (scheduler_action s) (ekheap s) (cur_domain s)"

lemmas switch_in_cur_domain_def = switch_in_cur_domain_2_def

definition valid_sched_action_2 where
  "valid_sched_action_2 sa ekh kh ct cdom \<equiv>
     is_activatable_2 ct sa kh \<and> weak_valid_sched_action_2 sa ekh kh \<and> switch_in_cur_domain_2 sa ekh cdom"

abbreviation valid_sched_action :: "det_ext state \<Rightarrow> bool" where
  "valid_sched_action s \<equiv> valid_sched_action_2 (scheduler_action s) (ekheap s) (kheap s) (cur_thread s) (cur_domain s)"

lemmas valid_sched_action_def = valid_sched_action_2_def

abbreviation ct_not_queued where
  "ct_not_queued s \<equiv> not_queued (cur_thread s) s"

definition
  "ct_not_in_q_2 queues sa ct \<equiv> sa = resume_cur_thread \<longrightarrow> not_queued_2 queues ct"

abbreviation ct_not_in_q :: "det_ext state \<Rightarrow> bool" where
  "ct_not_in_q s \<equiv> ct_not_in_q_2 (ready_queues s) (scheduler_action s) (cur_thread s)"

lemmas ct_not_in_q_def = ct_not_in_q_2_def

definition valid_sched_2 where
  "valid_sched_2 queues ekh sa cdom kh ct it \<equiv>
      valid_etcbs_2 ekh kh \<and> valid_queues_2 queues ekh kh \<and> ct_not_in_q_2 queues sa ct \<and> valid_sched_action_2 sa ekh kh ct cdom \<and> ct_in_cur_domain_2 ct it sa cdom ekh \<and> valid_blocked_2 queues kh sa ct \<and> valid_idle_etcb_2 ekh"

abbreviation valid_sched :: "det_ext state \<Rightarrow> bool" where
  "valid_sched s \<equiv> valid_sched_2 (ready_queues s) (ekheap s) (scheduler_action s) (cur_domain s) (kheap s) (cur_thread s) (idle_thread s)"

lemmas valid_sched_def = valid_sched_2_def

definition not_cur_thread_2 :: "obj_ref \<Rightarrow> scheduler_action \<Rightarrow> obj_ref \<Rightarrow> bool" where
  "not_cur_thread_2 thread sa ct \<equiv> sa = resume_cur_thread \<longrightarrow> thread \<noteq> ct"

abbreviation not_cur_thread :: "obj_ref \<Rightarrow> det_ext state \<Rightarrow> bool" where
  "not_cur_thread thread s \<equiv> not_cur_thread_2 thread (scheduler_action s) (cur_thread s)"

lemmas not_cur_thread_def = not_cur_thread_2_def

definition simple_sched_action_2 :: "scheduler_action \<Rightarrow> bool" where
  "simple_sched_action_2 action \<equiv> (case action of switch_thread t \<Rightarrow> False | _ \<Rightarrow> True)"

abbreviation simple_sched_action :: "det_state \<Rightarrow> bool" where
  "simple_sched_action s \<equiv> simple_sched_action_2 (scheduler_action s)"

lemmas simple_sched_action_def = simple_sched_action_2_def

definition schact_is_rct :: "det_ext state \<Rightarrow> bool" where
  "schact_is_rct s \<equiv> scheduler_action s = resume_cur_thread"

lemma schact_is_rct[elim!]: "schact_is_rct s \<Longrightarrow> scheduler_action s = resume_cur_thread"
  apply (simp add: schact_is_rct_def)
  done

lemma schact_is_rct_simple[elim]: "schact_is_rct s \<Longrightarrow> simple_sched_action s"
  apply (simp add: simple_sched_action_def schact_is_rct_def)
  done

definition scheduler_act_not_2 where
"scheduler_act_not_2 sa t \<equiv> sa \<noteq> switch_thread t"

abbreviation scheduler_act_not :: "obj_ref \<Rightarrow> det_ext state  \<Rightarrow> bool" where
"scheduler_act_not t s \<equiv> scheduler_act_not_2 (scheduler_action s) t"

abbreviation scheduler_act_sane :: "det_ext state \<Rightarrow> bool" where
"scheduler_act_sane s \<equiv> scheduler_act_not_2 (scheduler_action s) (cur_thread s)"

lemmas scheduler_act_sane_def = scheduler_act_not_2_def
lemmas scheduler_act_not_def = scheduler_act_not_2_def

lemmas ct_not_queued_lift = hoare_lift_Pf2[where f="cur_thread" and P="not_queued"]

lemmas sch_act_sane_lift = hoare_lift_Pf2[where f="cur_thread" and P="scheduler_act_not"]

lemmas not_queued_def = not_queued_2_def

lemma valid_etcbs_lift:
  assumes a: "\<And>P T t. \<lbrace>\<lambda>s. P (typ_at T t s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T t s)\<rbrace>"
      and b: "\<And>P. \<lbrace>\<lambda>s. P (ekheap s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ekheap s)\<rbrace>"
    shows "\<lbrace>valid_etcbs\<rbrace> f \<lbrace>\<lambda>rv. valid_etcbs\<rbrace>"
  apply (rule hoare_lift_Pf[where f="\<lambda>s. ekheap s", OF _ b])
  apply (simp add: valid_etcbs_def)
  apply (simp add: tcb_at_st_tcb_at[symmetric] tcb_at_typ)
  apply (wp hoare_vcg_all_lift a)
  done

lemma valid_queues_lift:
  assumes a: "\<And>Q t. \<lbrace>\<lambda>s. st_tcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. st_tcb_at Q t s\<rbrace>"
      and c: "\<And>P. \<lbrace>\<lambda>s. P (ekheap s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ekheap s)\<rbrace>"
      and d: "\<And>P. \<lbrace>\<lambda>s. P (ready_queues s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ready_queues s)\<rbrace>"
    shows "\<lbrace>valid_queues\<rbrace> f \<lbrace>\<lambda>rv. valid_queues\<rbrace>"
  apply (rule hoare_lift_Pf[where f="\<lambda>s. ekheap s", OF _ c])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. ready_queues s", OF _ d])
  apply (simp add: valid_queues_def)
  apply (wp hoare_vcg_ball_lift hoare_vcg_all_lift hoare_vcg_conj_lift a)
  done

lemma typ_at_st_tcb_at_lift:
  assumes typ_lift: "\<And>P T p. \<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> f \<lbrace>\<lambda>r s. P (typ_at T p s)\<rbrace>"
  assumes st_lift: "\<And>P. \<lbrace>st_tcb_at P t\<rbrace> f \<lbrace>\<lambda>_. st_tcb_at P t\<rbrace>"
  shows "\<lbrace>\<lambda>s. \<not> st_tcb_at P t s\<rbrace> f \<lbrace>\<lambda>r s. \<not> st_tcb_at P t s\<rbrace>"

  apply (simp add: valid_def obj_at_def st_tcb_at_def)
  apply clarsimp
  apply (case_tac "kheap s t")
   apply (cut_tac P="\<lambda>x. \<not> x" and p=t and T="ATCB" in typ_lift)
   apply (simp add: valid_def obj_at_def)
   apply force
  apply (cut_tac P="\<lambda>x. x" and p=t and T="a_type aa" in typ_lift)
  apply (cut_tac P="\<lambda>t. \<not> P t" in st_lift)
  apply (simp add: valid_def obj_at_def st_tcb_at_def)
  apply (drule_tac x=s in spec)
  apply simp
  apply (drule_tac x="(a,b)" in bspec)
   apply simp
  apply simp
  apply (subgoal_tac "a_type aa = ATCB")
   apply (erule a_type_ATCBE)
   apply simp
   apply force
  apply simp
  done

lemma valid_blocked_lift:
  assumes a: "\<And>Q t. \<lbrace>\<lambda>s. st_tcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. st_tcb_at Q t s\<rbrace>"
  assumes t: "\<And>P T t. \<lbrace>\<lambda>s. P (typ_at T t s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T t s)\<rbrace>"
      and c: "\<And>P. \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
      and e: "\<And>P. \<lbrace>\<lambda>s. P (cur_thread s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_thread s)\<rbrace>"
      and d: "\<And>P. \<lbrace>\<lambda>s. P (ready_queues s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ready_queues s)\<rbrace>"
    shows "\<lbrace>valid_blocked\<rbrace> f \<lbrace>\<lambda>rv. valid_blocked\<rbrace>"
  apply (rule hoare_pre)
   apply (wps c e d)
   apply (simp add: valid_blocked_def)
   apply (wp_trace hoare_vcg_ball_lift hoare_vcg_all_lift hoare_vcg_conj_lift static_imp_wp a)
   apply (rule hoare_convert_imp)
    apply (rule typ_at_st_tcb_at_lift)
     apply (wp a t)+
  apply (simp add: valid_blocked_def)
  done

lemma ct_not_in_q_lift:
  assumes a: "\<And>P. \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
      and b: "\<And>P. \<lbrace>\<lambda>s. P (ready_queues s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ready_queues s)\<rbrace>"
      and c: "\<And>P. \<lbrace>\<lambda>s. P (cur_thread s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_thread s)\<rbrace>"
    shows "\<lbrace>ct_not_in_q\<rbrace> f \<lbrace>\<lambda>rv. ct_not_in_q\<rbrace>"
  apply (rule hoare_lift_Pf[where f="\<lambda>s. scheduler_action s", OF _ a])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. ready_queues s", OF _ b])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. cur_thread s", OF _ c])
  apply wp
  done

lemma ct_in_cur_domain_lift:
  assumes a: "\<And>P. \<lbrace>\<lambda>s. P (ekheap s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ekheap s)\<rbrace>"
      and b: "\<And>P. \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
      and c: "\<And>P. \<lbrace>\<lambda>s. P (cur_domain s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_domain s)\<rbrace>"
      and d: "\<And>P. \<lbrace>\<lambda>s. P (cur_thread s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_thread s)\<rbrace>"
      and e: "\<And>P. \<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> f \<lbrace>\<lambda>rv s. P (idle_thread s)\<rbrace>"
    shows "\<lbrace>ct_in_cur_domain\<rbrace> f \<lbrace>\<lambda>rv. ct_in_cur_domain\<rbrace>"
  apply (rule hoare_lift_Pf[where f="\<lambda>s. ekheap s", OF _ a])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. scheduler_action s", OF _ b])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. cur_domain s", OF _ c])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. cur_thread s", OF _ d])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. idle_thread s", OF _ e])
  apply wp
  done

lemma weak_valid_sched_action_lift:
  assumes a: "\<And>Q t. \<lbrace>\<lambda>s. st_tcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. st_tcb_at Q t s\<rbrace>"
  assumes c: "\<And>P. \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
    shows "\<lbrace>weak_valid_sched_action\<rbrace> f \<lbrace>\<lambda>rv. weak_valid_sched_action\<rbrace>"
  apply (rule hoare_lift_Pf[where f="\<lambda>s. scheduler_action s", OF _ c])
  apply (simp add: weak_valid_sched_action_def)
  apply (wp hoare_vcg_all_lift static_imp_wp a)
  done

lemma switch_in_cur_domain_lift:
  assumes a: "\<And>Q t. \<lbrace>\<lambda>s. etcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. etcb_at Q t s\<rbrace>"
  assumes b: "\<And>P. \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
  assumes c: "\<And>P. \<lbrace>\<lambda>s. P (cur_domain s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_domain s)\<rbrace>"
    shows "\<lbrace>switch_in_cur_domain\<rbrace> f \<lbrace>\<lambda>rv. switch_in_cur_domain\<rbrace>"
  apply (rule hoare_lift_Pf[where f="\<lambda>s. scheduler_action s", OF _ b])
  apply (rule hoare_lift_Pf[where f="\<lambda>s. cur_domain s", OF _ c])
  apply (simp add: switch_in_cur_domain_def in_cur_domain_def)
  apply (wp hoare_vcg_all_lift static_imp_wp a c)
  done

lemma valid_sched_action_lift:
  assumes a: "\<And>Q t. \<lbrace>\<lambda>s. st_tcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. st_tcb_at Q t s\<rbrace>"
  assumes b: "\<And>Q t. \<lbrace>\<lambda>s. etcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. etcb_at Q t s\<rbrace>"
  assumes c: "\<And>P. \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
  assumes d: "\<And>P. \<lbrace>\<lambda>s. P (cur_thread s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_thread s)\<rbrace>"
  assumes e: "\<And>Q t. \<lbrace>\<lambda>s. Q (cur_domain s)\<rbrace> f \<lbrace>\<lambda>rv s. Q (cur_domain s)\<rbrace>"
    shows "\<lbrace>valid_sched_action\<rbrace> f \<lbrace>\<lambda>rv. valid_sched_action\<rbrace>"
  apply (rule hoare_lift_Pf[where f="\<lambda>s. cur_thread s", OF _ d])
  apply (simp add: valid_sched_action_def)
  apply (rule hoare_vcg_conj_lift)
   apply (rule hoare_lift_Pf[where f="\<lambda>s. scheduler_action s", OF _ c])
   apply (simp add: is_activatable_def)
   apply (wp weak_valid_sched_action_lift switch_in_cur_domain_lift static_imp_wp a b c d e)+
  done

lemma valid_sched_lift:
  assumes a: "\<And>Q t. \<lbrace>\<lambda>s. st_tcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. st_tcb_at Q t s\<rbrace>"
  assumes b: "\<And>Q t. \<lbrace>\<lambda>s. etcb_at Q t s\<rbrace> f \<lbrace>\<lambda>rv s. etcb_at Q t s\<rbrace>"
  assumes c: "\<And>P T t. \<lbrace>\<lambda>s. P (typ_at T t s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T t s)\<rbrace>"
  assumes d: "\<And>P. \<lbrace>\<lambda>s. P (ekheap s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ekheap s)\<rbrace>"
  assumes e: "\<And>P. \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
  assumes f: "\<And>P. \<lbrace>\<lambda>s. P (ready_queues s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ready_queues s)\<rbrace>"
  assumes g: "\<And>P. \<lbrace>\<lambda>s. P (cur_domain s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_domain s)\<rbrace>"
  assumes h: "\<And>P. \<lbrace>\<lambda>s. P (cur_thread s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_thread s)\<rbrace>"
  assumes i: "\<And>P. \<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> f \<lbrace>\<lambda>rv s. P (idle_thread s)\<rbrace>"
    shows "\<lbrace>valid_sched\<rbrace> f \<lbrace>\<lambda>rv. valid_sched\<rbrace>"
  apply (simp add: valid_sched_def)
  apply (wp valid_etcbs_lift valid_queues_lift ct_not_in_q_lift ct_in_cur_domain_lift
            valid_sched_action_lift valid_blocked_lift a b c d e f g h i hoare_vcg_conj_lift)
  done

lemma valid_etcbs_tcb_etcb:
  "\<lbrakk> valid_etcbs s; kheap s ptr = Some (TCB tcb) \<rbrakk> \<Longrightarrow> \<exists>etcb. ekheap s ptr = Some etcb"
  by (force simp: valid_etcbs_def is_etcb_at_def st_tcb_at_def obj_at_def)

lemma valid_etcbs_get_tcb_get_etcb:
  "\<lbrakk> valid_etcbs s; get_tcb ptr s = Some tcb \<rbrakk> \<Longrightarrow> \<exists>etcb. get_etcb ptr s = Some etcb"
  apply (clarsimp simp:  valid_etcbs_def valid_etcbs_def st_tcb_at_def obj_at_def is_etcb_at_def get_etcb_def get_tcb_def split: option.splits if_split)
  apply (erule_tac x=ptr in allE)
  apply (clarsimp simp: get_etcb_def split: option.splits kernel_object.splits)+
  done

lemma valid_etcbs_ko_etcb:
  "\<lbrakk> valid_etcbs s; kheap s ptr = Some ko \<rbrakk> \<Longrightarrow> \<exists>tcb. (ko = TCB tcb = (\<exists>etcb. ekheap s ptr = Some etcb))"
  apply (clarsimp simp: valid_etcbs_def st_tcb_at_def obj_at_def is_etcb_at_def)
  apply (erule_tac x="ptr" in allE)
  apply auto
  done

lemma ekheap_tcb_at:
  "\<lbrakk>ekheap s x = Some y; valid_etcbs s\<rbrakk> \<Longrightarrow> tcb_at x s"
  by (fastforce simp: valid_etcbs_def is_etcb_at_def st_tcb_at_def obj_at_def is_tcb_def)

lemma tcb_at_is_etcb_at:
  "\<lbrakk>tcb_at t s; valid_etcbs s\<rbrakk> \<Longrightarrow> is_etcb_at t s"
  by (simp add: valid_etcbs_def tcb_at_st_tcb_at)

lemma tcb_at_ekheap_dom:
  "\<lbrakk>tcb_at x s; valid_etcbs s\<rbrakk> \<Longrightarrow> (\<exists>etcb. ekheap s x = Some etcb)"
  by (auto simp: is_etcb_at_def dest: tcb_at_is_etcb_at)

lemma ekheap_kheap_dom:
  "\<lbrakk>ekheap s x = Some etcb; valid_etcbs s\<rbrakk>
    \<Longrightarrow> \<exists>tcb. kheap s x = Some (TCB tcb)"
  by (fastforce simp: valid_etcbs_def st_tcb_at_def obj_at_def is_etcb_at_def)

end


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

header{*The n_germanSymIndex Protocol Case Study*}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


(*  Title:      JinjaThreads/MM/JMM_Heap.thy
    Author:     Andreas Lochbihler
*)

header {* \isaheader{Locales for heap operations with set of allocated addresses} *}

theory JMM_Heap
imports
  "../Common/WellForm"
  "SC_Completion"
  "HB_Completion"
begin

definition w_addrs :: "('addr \<times> addr_loc \<Rightarrow> 'addr val set) \<Rightarrow> 'addr set"
where "w_addrs vs = {a. \<exists>adal. Addr a \<in> vs adal}"

lemma w_addrs_empty [simp]: "w_addrs (\<lambda>_. {}) = {}"
by(simp add: w_addrs_def)

locale allocated_heap_base = heap_base +
  constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  fixes allocated :: "'heap \<Rightarrow> 'addr set"

locale allocated_heap =
  allocated_heap_base +
  heap +
  constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  and allocated :: "'heap \<Rightarrow> 'addr set"
  and P :: "'m prog"

  assumes allocated_empty: "allocated empty_heap = {}"
  and allocate_allocatedD:
  "(h', a) \<in> allocate h hT \<Longrightarrow> allocated h' = insert a (allocated h) \<and> a \<notin> allocated h"
  and heap_write_allocated_same:
  "heap_write h a al v h' \<Longrightarrow> allocated h' = allocated h"
begin

lemma allocate_allocated_mono: "(h', a) \<in> allocate h C \<Longrightarrow> allocated h \<subseteq> allocated h'"
by(simp_all add: allocate_allocatedD)

lemma
  shows start_addrs_allocated: "allocated start_heap = set start_addrs"
  and distinct_start_addrs': "distinct start_addrs"
proof -
  { fix h ads b and xs :: "cname list"
    let "?start_addrs h ads b xs" = "fst (snd (foldl create_initial_object (h, ads, b) xs))"
    let "?start_heap h ads b xs" = "fst (foldl create_initial_object (h, ads, b) xs)"
    assume "allocated h = set ads"
    hence "allocated (?start_heap h ads b xs) = set (?start_addrs h ads b xs) \<and>
           (distinct ads \<longrightarrow> distinct (?start_addrs h ads b xs))"
      (is "?concl xs h ads b")
    proof(induct xs arbitrary: h ads b)
      case Nil thus ?case by auto
    next
      case (Cons x xs)
      note ads = `allocated h = set ads`
      show ?case
      proof(cases "b \<and> allocate h (Class_type x) \<noteq> {}")
        case False thus ?thesis using ads
          by(simp add: create_initial_object_simps zip_append1)
      next
        case True[simp]
        then obtain h' a'
          where h'a': "(SOME ha. ha \<in> allocate h (Class_type x)) = (h', a')"
          and new_obj: "(h', a') \<in> allocate h (Class_type x)"
          by(cases "(SOME ha. ha \<in> allocate h (Class_type x))")(auto simp del: True dest: allocate_Eps)

        from new_obj have "allocated h' = insert a' (allocated h)" "a' \<notin> allocated h"
          by(auto dest: allocate_allocatedD)
        with ads have "allocated h' = set (ads @ [a'])" by auto
        hence "?concl xs h' (ads @ [a']) True" by(rule Cons)
        moreover have "a' \<notin> set ads" using `a' \<notin> allocated h` ads by blast
        ultimately show ?thesis by(simp add: create_initial_object_simps new_obj h'a')
      qed
    qed }
  from this[of empty_heap "[]" True initialization_list]
  show "allocated start_heap = set start_addrs"
    and distinct_start_addrs: "distinct start_addrs"
    unfolding start_heap_def start_addrs_def start_heap_data_def
    by(auto simp add: allocated_empty)
qed

lemma w_addrs_start_heap_obs: "w_addrs (w_values P vs (map NormalAction start_heap_obs)) \<subseteq> w_addrs vs"
proof -
  { fix xs
    let ?NewObj = "\<lambda>a C. NewHeapElem a (Class_type C) :: ('addr, 'thread_id) obs_event"
    let "?start_heap_obs xs" = "map (\<lambda>(C, a). ?NewObj a C) xs"
    have "w_addrs (w_values P vs (map NormalAction (?start_heap_obs xs))) \<subseteq> w_addrs vs"
      (is "?concl xs")
    proof(induct xs arbitrary: vs)
      case Nil thus ?case by simp
    next
      case (Cons x xs)
      have "w_addrs (w_values P vs (map NormalAction (map (\<lambda>(C, a). ?NewObj a C) (x # xs))))
        = w_addrs (w_values P (w_value P vs (NormalAction (?NewObj (snd x) (fst x)))) (map NormalAction (map (\<lambda>(C, a). ?NewObj a C) xs)))"
        by(simp add: split_beta)
      also have "\<dots> \<subseteq> w_addrs (w_value P vs (NormalAction (?NewObj (snd x) (fst x))))" by(rule Cons)
      also have "\<dots> \<subseteq> w_addrs vs"
        by(auto simp add: w_addrs_def default_val_not_Addr Addr_not_default_val)
      finally show ?case .
    qed }
  thus ?thesis by(simp add: start_heap_obs_def)
qed

end

context heap_base begin

lemma addr_loc_default_conf:
  "P \<turnstile> class_type_of CTn has F:T (fm) in C
  \<Longrightarrow> P,h \<turnstile> addr_loc_default P CTn (CField C F) :\<le> T"
apply(cases CTn)
 apply simp
apply(frule has_field_decl_above)
apply simp
done

definition vs_conf :: "'m prog \<Rightarrow> 'heap \<Rightarrow> ('addr \<times> addr_loc \<Rightarrow> 'addr val set) \<Rightarrow> bool"
where "vs_conf P h vs \<longleftrightarrow> (\<forall>ad al v. v \<in> vs (ad, al) \<longrightarrow> (\<exists>T. P,h \<turnstile> ad@al : T \<and> P,h \<turnstile> v :\<le> T))"

lemma vs_confD:
  "\<lbrakk> vs_conf P h vs; v \<in> vs (ad, al) \<rbrakk> \<Longrightarrow> \<exists>T. P,h \<turnstile> ad@al : T \<and> P,h \<turnstile> v :\<le> T"
unfolding vs_conf_def by blast

lemma vs_conf_insert_iff:
  "vs_conf P h (vs((ad, al) := insert v (vs (ad, al))))
  \<longleftrightarrow> vs_conf P h vs \<and> (\<exists>T. P,h \<turnstile> ad@al : T \<and> P,h \<turnstile> v :\<le> T)"
by(auto 4 3 elim: vs_confD intro: vs_confI split: split_if_asm)

end

context heap begin

lemma vs_conf_hext: "\<lbrakk> vs_conf P h vs; h \<unlhd> h' \<rbrakk> \<Longrightarrow> vs_conf P h' vs"
by(blast intro!: vs_confI intro: conf_hext addr_loc_type_hext_mono dest: vs_confD)

lemma vs_conf_allocate:
  "\<lbrakk> vs_conf P h vs; (h', a) \<in> allocate h hT; is_htype P hT \<rbrakk>
  \<Longrightarrow> vs_conf P h' (w_value P vs (NormalAction (NewHeapElem a hT)))"
apply(drule vs_conf_hext)
 apply(erule hext_allocate)
apply(auto intro!: vs_confI simp add: addr_locs_def split: split_if_asm htype.split_asm)
apply(auto 3 3 intro: addr_loc_type.intros defval_conf dest: allocate_SomeD elim: has_field_is_class vs_confD)
apply(rule exI conjI addr_loc_type.intros|drule allocate_SomeD|erule has_field_is_class|simp)+
done

end

text {*
  @{text heap_read_typeable} must not be defined in @{term heap_conf_base} (where it should be) because
  this would lead to duplicate definitions of @{text heap_read_typeable} in contexts where @{term heap_conf_base}
  is imported twice with different parameters, e.g., @{term P} and @{term "J2JVM P"} in @{term "J_JVM_heap_conf_read"}.
*}

context heap_base begin

definition heap_read_typeable :: "('heap \<Rightarrow> bool) \<Rightarrow> 'm prog \<Rightarrow> bool"
where "heap_read_typeable hconf P \<longleftrightarrow> (\<forall>h ad al v T. hconf h \<longrightarrow> P,h \<turnstile> ad@al : T \<longrightarrow> P,h \<turnstile> v :\<le> T \<longrightarrow> heap_read h ad al v)"

lemma heap_read_typeableI:
  "(\<And>h ad al v T. \<lbrakk> P,h \<turnstile> ad@al : T; P,h \<turnstile> v :\<le> T; hconf h \<rbrakk> \<Longrightarrow> heap_read h ad al v) \<Longrightarrow> heap_read_typeable hconf P"
unfolding heap_read_typeable_def by blast

lemma heap_read_typeableD:
  "\<lbrakk> heap_read_typeable hconf P; P,h \<turnstile> ad@al : T; P,h \<turnstile> v :\<le> T; hconf h \<rbrakk> \<Longrightarrow> heap_read h ad al v"
unfolding heap_read_typeable_def by blast

end

context heap_base begin

definition heap_read_typed :: "'m prog \<Rightarrow> 'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
where "heap_read_typed P h ad al v \<longleftrightarrow> heap_read h ad al v \<and> (\<forall>T. P,h \<turnstile> ad@al : T \<longrightarrow> P,h \<turnstile> v :\<le> T)"

lemma heap_read_typedI:
  "\<lbrakk> heap_read h ad al v; \<And>T. P,h \<turnstile> ad@al : T \<Longrightarrow> P,h \<turnstile> v :\<le> T \<rbrakk> \<Longrightarrow> heap_read_typed P h ad al v"
unfolding heap_read_typed_def by blast

lemma heap_read_typed_into_heap_read:
  "heap_read_typed P h ad al v \<Longrightarrow> heap_read h ad al v"
unfolding heap_read_typed_def by blast

lemma heap_read_typed_typed:
  "\<lbrakk> heap_read_typed P h ad al v; P,h \<turnstile> ad@al : T \<rbrakk> \<Longrightarrow> P,h \<turnstile> v :\<le> T"
unfolding heap_read_typed_def by blast

end

context heap_conf begin

lemma heap_conf_read_heap_read_typed:
  "heap_conf_read addr2thread_id thread_id2addr empty_heap allocate typeof_addr (heap_read_typed P) heap_write hconf P"
proof
  fix h a al v T
  assume "heap_read_typed P h a al v" "P,h \<turnstile> a@al : T"
  thus "P,h \<turnstile> v :\<le> T" by(rule heap_read_typed_typed)
qed

end

context heap begin

lemma start_addrs_dom_w_values:
  assumes wf: "wf_syscls P"
  and a: "a \<in> set start_addrs"
  and adal: "P,start_heap \<turnstile> a@al : T"
  shows "w_values P (\<lambda>_. {}) (map NormalAction start_heap_obs) (a, al) \<noteq> {}"
proof -
  from a obtain CTn where CTn: "NewHeapElem a CTn \<in> set start_heap_obs"
    unfolding in_set_start_addrs_conv_NewHeapElem ..
  then obtain obs obs' where obs: "start_heap_obs = obs @ NewHeapElem a CTn # obs'" by(auto dest: split_list)
  have "w_value P (w_values P (\<lambda>_. {}) (map NormalAction obs)) (NormalAction (NewHeapElem a CTn)) (a, al) \<noteq> {}"
  proof(cases CTn)
    case (Class_type C)[simp]
    with wf CTn have "typeof_addr start_heap a = \<lfloor>Class_type C\<rfloor>"
      by(auto intro: NewHeapElem_start_heap_obsD)
    with adal show ?thesis by cases auto
  next
    case (Array_type T n)[simp]
    with wf CTn have "typeof_addr start_heap a = \<lfloor>Array_type T n\<rfloor>"
      by(auto dest: NewHeapElem_start_heap_obsD)
    with adal show ?thesis by cases(auto dest: has_field_decl_above)
  qed
  moreover have "w_value P (w_values P (\<lambda>_. {}) (map NormalAction obs)) (NormalAction (NewHeapElem a CTn :: ('addr, 'thread_id) obs_event))
    (a, al) \<subseteq> w_values P (\<lambda>_. {}) (map NormalAction start_heap_obs) (a, al)"
    by(simp add: obs del: w_value.simps)(rule w_values_mono)
  ultimately show ?thesis by blast
qed

end

end


(*
 * Copyright 2023, Proofcraft Pty Ltd
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory CLib
  imports Word_Lib.Many_More
begin

lemma nat_diff_less:
  "\<lbrakk> x < y + z; z \<le> x\<rbrakk> \<Longrightarrow> x - z < y" for x :: nat
  using less_diff_conv2 by blast

lemma foldl_conv_concat:
  "foldl (@) xs xss = xs @ concat xss"
proof (induct xss arbitrary: xs)
  case Nil show ?case by simp
next
  case Cons then show ?case by simp
qed

lemma foldl_concat_concat:
  "foldl (@) [] (xs @ ys) = foldl (@) [] xs @ foldl (@) [] ys"
  by (simp add: foldl_conv_concat)

lemma take_drop_foldl_concat:
  "\<lbrakk> \<And>y. y < m \<Longrightarrow> length (f y) = n; x < m \<rbrakk> \<Longrightarrow>
   take n (drop (x * n) (foldl (@) [] (map f [0 ..< m]))) = f x"
  apply (subst split_upt_on_n, assumption)
  apply (simp only: foldl_concat_concat map_append)
  apply (subst drop_append_miracle)
   apply (induct x; simp)
  apply simp
  done

lemma foldl_does_nothing:
  "\<lbrakk> \<And>x. x \<in> set xs \<Longrightarrow> f s x = s \<rbrakk> \<Longrightarrow> foldl f s xs = s"
  by (induct xs) auto

end


(*  Title:       variants/d_fwdrreqs/OAodv.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "The `open' AODV model"

theory D_OAodv
imports D_Aodv AWN.OAWN_SOS_Labels AWN.OAWN_Convert
begin

text \<open>Definitions for stating and proving global network properties over individual processes.\<close>

definition \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' :: "((ip \<Rightarrow> state) \<times> ((state, msg, pseqp, pseqp label) seqp)) set"
where "\<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<equiv> {(\<lambda>i. aodv_init i, \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V PAodv)}"

abbreviation opaodv
  :: "ip \<Rightarrow> ((ip \<Rightarrow> state) \<times> (state, msg, pseqp, pseqp label) seqp, msg seq_action) automaton"
where
  "opaodv i \<equiv> \<lparr> init = \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V', trans = oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i \<rparr>"

lemma initiali_aodv [intro!, simp]: "initiali i (init (opaodv i)) (init (paodv i))"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def by rule simp_all

lemma oaodv_control_within [simp]: "control_within \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (init (opaodv i))"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def by (rule control_withinI) (auto simp del: \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_simps)

lemma \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_labels [simp]: "(\<sigma>, p) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<Longrightarrow>  labels \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V p = {PAodv-:0}"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def by simp

lemma oaodv_init_kD_empty [simp]:
  "(\<sigma>, p) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<Longrightarrow> kD (rt (\<sigma> i)) = {}"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def kD_def by simp

lemma oaodv_init_vD_empty [simp]:
  "(\<sigma>, p) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V' \<Longrightarrow> vD (rt (\<sigma> i)) = {}"
  unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def vD_def by simp

lemma oaodv_trans: "trans (opaodv i) = oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i"
  by simp

declare
  oseq_invariant_ctermsI [OF aodv_wf oaodv_control_within aodv_simple_labels oaodv_trans, cterms_intros]
  oseq_step_invariant_ctermsI [OF aodv_wf oaodv_control_within aodv_simple_labels oaodv_trans, cterms_intros]

end


(*  Title:      JinjaThreads/MM/SC_Collections.thy
    Author:     Andreas Lochbihler
*)

header {* \isaheader{Sequential consistency with efficient data structures} *}

theory SC_Collections
imports
  "../Common/Conform"
  (*"../../Collections/impl/RBTMapImpl"
  "../../Collections/impl/TrieMapImpl"
  "../../Collections/impl/ListMapImpl"*)
  "../Basic/JT_ICF"
  MM
begin

hide_const (open) new_Addr
hide_fact (open) new_Addr_SomeD new_Addr_SomeI

subsection{* Objects and Arrays *}

type_synonym fields = "(char, (cname, addr val) lm) tm"
type_synonym array_cells = "(nat, addr val) rbt"
type_synonym array_fields = "(vname, addr val) lm"

datatype heapobj
  = Obj cname fields                    -- "class instance with class name and fields"
  | Arr ty nat array_fields array_cells                 -- "element type, size, fields and cell contents"

lemma rec_heapobj [simp]: "rec_heapobj = case_heapobj"
by(auto intro!: ext split: heapobj.split)

primrec obj_ty  :: "heapobj \<Rightarrow> htype"
where
  "obj_ty (Obj c f)   = Class_type c"
| "obj_ty (Arr t si f e) = Array_type t si"

fun is_Arr :: "heapobj \<Rightarrow> bool" where
  "is_Arr (Obj C fs)      = False"
| "is_Arr (Arr T f si el) = True"

lemma is_Arr_conv:
  "is_Arr arrobj = (\<exists>T si f el. arrobj = Arr T si f el)"
by(cases arrobj, auto)

lemma is_ArrE:
  "\<lbrakk> is_Arr arrobj; \<And>T si f el. arrobj = Arr T si f el \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
  "\<lbrakk> \<not> is_Arr arrobj; \<And>C fs. arrobj = Obj C fs \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
by(cases arrobj, auto)+

definition init_fields :: "((vname \<times> cname) \<times> ty) list \<Rightarrow> fields"
where
  "init_fields FDTs \<equiv>
  foldr (\<lambda>((F, D), T) fields.
           let F' = String.explode F
           in tm_update F' (lm_update D (default_val T)
                                      (case tm_lookup F' fields of None \<Rightarrow> lm_empty () | Some lm \<Rightarrow> lm)) fields)
        FDTs (tm_empty ())"

definition init_fields_array :: "(vname \<times> ty) list \<Rightarrow> array_fields"
where
  "init_fields_array \<equiv> lm.to_map \<circ> map (\<lambda>(F, T). (F, default_val T))"

definition init_cells :: "ty \<Rightarrow> nat \<Rightarrow> array_cells"
where "init_cells T n = foldl (\<lambda>cells i. rm_update i (default_val T) cells) (rm_empty ()) [0..<n]"

primrec -- "a new, blank object with default values in all fields:"
  blank :: "'m prog \<Rightarrow> htype \<Rightarrow> heapobj"
where
  "blank P (Class_type C) = Obj C (init_fields (map (\<lambda>(FD, (T, fm)). (FD, T)) (TypeRel.fields P C)))"
| "blank P (Array_type T n) =
   Arr T n (init_fields_array (map (\<lambda>((F, D), (T, fm)). (F, T)) (TypeRel.fields P Object))) (init_cells T n)"

lemma obj_ty_blank [iff]: "obj_ty (blank P hT) = hT"
by(cases hT) simp_all

subsection{* Heap *}

type_synonym heap = "(addr, heapobj) rbt"

translations
  (type) "heap" <= (type) "(nat, heapobj) rbt"

abbreviation sc_empty :: heap
where "sc_empty \<equiv> rm_empty ()"

fun the_obj :: "heapobj \<Rightarrow> cname \<times> fields" where
  "the_obj (Obj C fs) = (C, fs)"

fun the_arr :: "heapobj \<Rightarrow> ty \<times> nat \<times> array_fields \<times> array_cells" where
  "the_arr (Arr T si f el) = (T, si, f, el)"

abbreviation
  cname_of :: "heap \<Rightarrow> addr \<Rightarrow> cname" where
  "cname_of hp a == fst (the_obj (the (rm_lookup a hp)))"

definition new_Addr :: "heap \<Rightarrow> addr option"
where "new_Addr h = Some (case rm_max h (\<lambda>_. True) of None \<Rightarrow> 0 | Some (a, _) \<Rightarrow> a + 1)"

definition sc_allocate :: "'m prog \<Rightarrow> heap \<Rightarrow> htype \<Rightarrow> (heap \<times> addr) set"
where
  "sc_allocate P h hT =
   (case new_Addr h of None \<Rightarrow> {}
                   | Some a \<Rightarrow> {(rm_update a (blank P hT) h, a)})"

definition sc_typeof_addr :: "heap \<Rightarrow> addr \<Rightarrow> htype option"
where "sc_typeof_addr h a = map_option obj_ty (rm_lookup a h)"

inductive sc_heap_read :: "heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> bool"
for h :: heap and a :: addr
where
  Obj: "\<lbrakk> rm_lookup a h = \<lfloor>Obj C fs\<rfloor>; tm_lookup (String.explode F) fs = \<lfloor>fs'\<rfloor>; lm_lookup D fs' = \<lfloor>v\<rfloor> \<rbrakk> \<Longrightarrow> sc_heap_read h a (CField D F) v"
| Arr: "\<lbrakk> rm_lookup a h = \<lfloor>Arr T si f el\<rfloor>; n < si \<rbrakk> \<Longrightarrow> sc_heap_read h a (ACell n) (the (rm_lookup n el))"
| ArrObj: "\<lbrakk> rm_lookup a h = \<lfloor>Arr T si f el\<rfloor>; lm_lookup F f = \<lfloor>v\<rfloor> \<rbrakk> \<Longrightarrow> sc_heap_read h a (CField Object F) v"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_read_cases [elim!]:
  "sc_heap_read h a (CField C F) v"
  "sc_heap_read h a (ACell n) v"

inductive sc_heap_write :: "heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> heap \<Rightarrow> bool"
for h :: heap and a :: addr
where
  Obj:
  "\<lbrakk> rm_lookup a h = \<lfloor>Obj C fs\<rfloor>; F' = String.explode F;
     h' = rm_update a (Obj C (tm_update F' (lm_update D v (case tm_lookup (String.explode F) fs of None \<Rightarrow> lm_empty () | Some fs' \<Rightarrow> fs')) fs)) h \<rbrakk>
  \<Longrightarrow> sc_heap_write h a (CField D F) v h'"

| Arr:
  "\<lbrakk> rm_lookup a h = \<lfloor>Arr T si f el\<rfloor>; h' = rm_update a (Arr T si f (rm_update n v el)) h \<rbrakk>
  \<Longrightarrow> sc_heap_write h a (ACell n) v h'"

| ArrObj:
  "\<lbrakk> rm_lookup a h = \<lfloor>Arr T si f el\<rfloor>; h' = rm_update a (Arr T si (lm_update F v f) el) h \<rbrakk>
  \<Longrightarrow> sc_heap_write h a (CField Object F) v h'"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_write_cases [elim!]:
  "sc_heap_write h a (CField C F) v h'"
  "sc_heap_write h a (ACell n) v h'"

consts sc_spurious_wakeups :: bool

lemma new_Addr_SomeD: "new_Addr h = \<lfloor>a\<rfloor> \<Longrightarrow> rm_lookup a h = None"
apply(simp add: new_Addr_def)
apply(drule rm.max_None[OF rm.invar])
apply(simp add: rm.lookup_correct rel_of_def)
apply(clarsimp simp add: rm.lookup_correct)
apply(frule rm.max_Some[OF rm.invar])
apply(clarsimp simp add: rel_of_def)
apply(hypsubst_thin)
apply(rule ccontr)
apply(clarsimp)
apply(drule_tac k'="Suc a" in rm.max_Some(2)[OF rm.invar])
apply(auto simp add: rel_of_def)
done

interpretation sc!:
  heap_base
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P .

text {* Translate notation from @{text heap_base} *}

abbreviation sc_preallocated :: "'m prog \<Rightarrow> heap \<Rightarrow> bool"
where "sc_preallocated == sc.preallocated TYPE('m)"

abbreviation sc_start_tid :: "'md prog \<Rightarrow> thread_id"
where "sc_start_tid \<equiv> sc.start_tid TYPE('md)"

abbreviation sc_start_heap_ok :: "'m prog \<Rightarrow> bool"
where "sc_start_heap_ok \<equiv> sc.start_heap_ok TYPE('m)"

abbreviation sc_start_heap :: "'m prog \<Rightarrow> heap"
where "sc_start_heap \<equiv> sc.start_heap TYPE('m)"

abbreviation sc_start_state ::
  "(cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm \<Rightarrow> addr val list \<Rightarrow> 'x)
  \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> (addr, thread_id, 'x, heap, addr) state"
where
  "sc_start_state f P \<equiv> sc.start_state TYPE('m) P f P"

abbreviation sc_wf_start_state :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> bool"
where "sc_wf_start_state P \<equiv> sc.wf_start_state TYPE('m) P P"

notation sc.conf ("_,_ \<turnstile>sc _ :\<le> _"  [51,51,51,51] 50)
notation sc.confs ("_,_ \<turnstile>sc _ [:\<le>] _" [51,51,51,51] 50)
notation sc.hext ("_ \<unlhd>sc _" [51,51] 50)

lemma new_Addr_SomeI: "\<exists>a. new_Addr h = Some a"
by(simp add: new_Addr_def)

lemma sc_start_heap_ok: "sc_start_heap_ok P"
by(simp add: sc.start_heap_ok_def sc.start_heap_data_def initialization_list_def sc.create_initial_object_simps sc_allocate_def case_option_conv_if new_Addr_SomeI sys_xcpts_list_def del: blank.simps split del: option.split split_if)

lemma sc_wf_start_state_iff:
  "sc_wf_start_state P C M vs \<longleftrightarrow> (\<exists>Ts T meth D. P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D \<and> P,sc_start_heap P \<turnstile>sc vs [:\<le>] Ts)"
by(simp add: sc.wf_start_state.simps sc_start_heap_ok)

lemma sc_heap:
  "heap addr2thread_id thread_id2addr (sc_allocate P) sc_typeof_addr sc_heap_write P"
proof
  fix h' a h hT
  assume "(h', a) \<in> sc_allocate P h hT"
  thus "sc_typeof_addr h' a = \<lfloor>hT\<rfloor>"
    by(auto simp add: sc_allocate_def sc_typeof_addr_def rm.lookup_correct rm.update_correct dest: new_Addr_SomeD split: split_if_asm)
next
  fix h h' hT a
  assume "(h', a) \<in> sc_allocate P h hT"
  from this[symmetric] show "h \<unlhd>sc h'"
    by(fastforce simp add: sc_allocate_def sc_typeof_addr_def sc.hext_def rm.lookup_correct rm.update_correct intro!: map_leI dest: new_Addr_SomeD)
next
  fix h a al v h'
  assume "sc_heap_write h a al v h'"
  thus "h \<unlhd>sc h'"
    by(cases al)(auto intro!: sc.hextI simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct)
qed simp

interpretation sc!:
  heap
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    P
  for P by(rule sc_heap)

declare sc.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemma sc_hext_new:
  "rm_lookup a h = None \<Longrightarrow> h \<unlhd>sc rm_update a arrobj h"
by(rule sc.hextI)(auto simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct dest!: new_Addr_SomeD)

lemma sc_hext_upd_obj: "rm_lookup a h = Some (Obj C fs) \<Longrightarrow> h \<unlhd>sc rm_update a (Obj C fs') h"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def rm.lookup_correct rm.update_correct)

lemma sc_hext_upd_arr: "\<lbrakk> rm_lookup a h = Some (Arr T si f e) \<rbrakk> \<Longrightarrow> h \<unlhd>sc rm_update a (Arr T si f' e') h"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def rm.lookup_correct rm.update_correct)

subsection {* Conformance *}

definition sc_oconf :: "'m prog \<Rightarrow> heap \<Rightarrow> heapobj \<Rightarrow> bool"   ("_,_ \<turnstile>sc _ \<surd>" [51,51,51] 50)
where
  "P,h \<turnstile>sc obj \<surd>  \<equiv>
   (case obj of
     Obj C fs \<Rightarrow>
        is_class P C \<and>
        (\<forall>F D T fm. P \<turnstile> C has F:T (fm) in D \<longrightarrow>
           (\<exists>fs' v. tm_\<alpha> fs (String.explode F) = Some fs' \<and> lm_\<alpha> fs' D = Some v \<and> P,h \<turnstile>sc v :\<le> T))
   | Arr T si f el \<Rightarrow>
      is_type P (T\<lfloor>\<rceil>) \<and> (\<forall>n. n < si \<longrightarrow> (\<exists>v. rm_\<alpha> el n = Some v \<and> P,h \<turnstile>sc v :\<le> T)) \<and>
      (\<forall>F T fm. P \<turnstile> Object has F:T (fm) in Object \<longrightarrow> (\<exists>v. lm_lookup F f = Some v \<and> P,h \<turnstile>sc v :\<le> T)))"

definition sc_hconf :: "'m prog \<Rightarrow> heap \<Rightarrow> bool"  ("_ \<turnstile>sc _ \<surd>" [51,51] 50)
where "P \<turnstile>sc h \<surd> \<longleftrightarrow> (\<forall>a obj. rm_\<alpha> h a = Some obj \<longrightarrow> P,h \<turnstile>sc obj \<surd>)"

interpretation sc!:
  heap_conf_base
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P
.

lemma sc_conf_upd_obj: "rm_lookup a h = Some(Obj C fs) \<Longrightarrow> (P,rm_update a (Obj C fs') h \<turnstile>sc x :\<le> T) = (P,h \<turnstile>sc x :\<le> T)"
apply (unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply (auto simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct split: split_if_asm)
done

lemma sc_conf_upd_arr:
  "rm_lookup a h = Some(Arr T si f el) \<Longrightarrow> (P,rm_update a (Arr T si f' el') h \<turnstile>sc x :\<le> T') = (P,h \<turnstile>sc x :\<le> T')"
apply(unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply(auto simp add: sc_typeof_addr_def rm.lookup_correct rm.update_correct split: split_if_asm)
done

lemma map_of_fields_init_fields:
  assumes "map_of FDTs (F, D) = \<lfloor>(T, fm)\<rfloor>"
  shows "\<exists>fs' v. tm_\<alpha> (init_fields (map (\<lambda>(FD, (T, fm)). (FD, T)) FDTs)) (String.explode F) = \<lfloor>fs'\<rfloor> \<and> lm_\<alpha> fs' D = \<lfloor>v\<rfloor> \<and> sc.conf P h v T"
using assms
by(induct FDTs)(auto simp add: tm.lookup_correct tm.update_correct lm.update_correct init_fields_def explode_inject)

lemma sc_oconf_init_arr:
  assumes type: "is_type P (T\<lfloor>\<rceil>)"
  shows "P,h \<turnstile>sc Arr T n (init_fields_array (map (\<lambda>((F, D), (T, fm)). (F, T)) (TypeRel.fields P Object))) (init_cells T n) \<surd>"
proof -
  { fix n'
    assume "n' < n"
    { fix rm and k :: nat
      assume "\<forall>i<k. \<exists>v. rm_\<alpha> rm i = \<lfloor>v\<rfloor> \<and> sc.conf P h v T"
      with `n' < n` have "\<exists>v. rm_\<alpha> (foldl (\<lambda>cells i. rm_update i (default_val T) cells) rm [k..<n]) n' = \<lfloor>v\<rfloor> \<and> sc.conf P h v T"
        by(induct m\<equiv>"n-k" arbitrary: n k rm)(auto simp add: rm.update_correct upt_conv_Cons type)
    }
    from this[of 0 "rm_empty ()"]
    have "\<exists>v. rm_\<alpha> (foldl (\<lambda>cells i. rm_update i (default_val T) cells) (rm_empty ()) [0..<n]) n' = \<lfloor>v\<rfloor> \<and> sc.conf P h v T" by simp
  }
  moreover
  { fix F T fm
    assume "P \<turnstile> Object has F:T (fm) in Object"
    then obtain FDTs where has: "P \<turnstile> Object has_fields FDTs"
      and FDTs: "map_of FDTs (F, Object) = \<lfloor>(T, fm)\<rfloor>"
      by(auto simp add: has_field_def)
    from has have "snd ` fst ` set FDTs \<subseteq> {Object}" by(rule Object_has_fields_Object)
    with FDTs have "map_of (map ((\<lambda>(F, T). (F, default_val T)) \<circ> (\<lambda>((F, D), T, fm). (F, T))) FDTs) F = \<lfloor>default_val T\<rfloor>"
      by(induct FDTs) auto
    with has FDTs
    have "\<exists>v. lm_lookup F (init_fields_array (map (\<lambda>((F, D), T, fm). (F, T)) (TypeRel.fields P Object))) = \<lfloor>v\<rfloor> \<and>
              sc.conf P h v T"
      by(auto simp add: init_fields_array_def lm_correct has_field_def)
  }
  ultimately show ?thesis using type by(auto simp add: sc_oconf_def init_cells_def)
qed

lemma sc_oconf_fupd [intro?]:
  "\<lbrakk> P \<turnstile> C has F:T (fm) in D; P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Obj C fs) \<surd>;
    fs' = (case tm_lookup (String.explode F) fs of None \<Rightarrow> lm_empty () | Some fs' \<Rightarrow> fs') \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Obj C (tm_update (String.explode F) (lm_update D v fs') fs)) \<surd>"
unfolding sc_oconf_def has_field_def
apply(auto dest: has_fields_fun simp add: lm.update_correct tm.update_correct tm.lookup_correct explode_inject)
apply(drule (1) has_fields_fun, fastforce)
apply(drule (1) has_fields_fun, fastforce)
done

lemma sc_oconf_fupd_arr [intro?]:
  "\<lbrakk> P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Arr T si f el) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Arr T si f (rm_update i v el)) \<surd>"
unfolding sc_oconf_def
by(auto simp add: rm.update_correct)

lemma sc_oconf_fupd_arr_fields:
  "\<lbrakk> P \<turnstile> Object has F:T (fm) in Object; P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Arr T' si f el) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Arr T' si (lm_update F v f) el) \<surd>"
unfolding sc_oconf_def by(auto dest: has_field_fun simp add: lm_correct)

lemma sc_oconf_new: "\<lbrakk> P,h \<turnstile>sc obj \<surd>; rm_lookup a h = None \<rbrakk> \<Longrightarrow> P,rm_update a arrobj h \<turnstile>sc obj \<surd>"
by(erule sc_oconf_hext)(rule sc_hext_new)

lemmas sc_oconf_upd_obj = sc_oconf_hext [OF _ sc_hext_upd_obj]

lemma sc_oconf_upd_arr:
  assumes "P,h \<turnstile>sc obj \<surd>"
  and ha: "rm_lookup a h = \<lfloor>Arr T si f el\<rfloor>"
  shows "P,rm_update a (Arr T si f' el') h \<turnstile>sc obj \<surd>"
using assms
by(fastforce simp add: sc_oconf_def sc_conf_upd_arr[OF ha] split: heapobj.split)

lemma sc_oconf_blank: "is_htype P hT \<Longrightarrow> P,h \<turnstile>sc blank P hT \<surd>"
apply(cases hT)
 apply(fastforce dest: map_of_fields_init_fields simp add: has_field_def sc_oconf_def)
by(auto intro: sc_oconf_init_arr)

lemma sc_hconfD: "\<lbrakk> P \<turnstile>sc h \<surd>; rm_lookup a h = Some obj \<rbrakk> \<Longrightarrow> P,h \<turnstile>sc obj \<surd>"
unfolding sc_hconf_def by(auto simp add: rm.lookup_correct)

lemmas sc_preallocated_new = sc.preallocated_hext[OF _ sc_hext_new]
lemmas sc_preallocated_upd_obj = sc.preallocated_hext [OF _ sc_hext_upd_obj]
lemmas sc_preallocated_upd_arr = sc.preallocated_hext [OF _ sc_hext_upd_arr]

lemma sc_hconf_new: "\<lbrakk> P \<turnstile>sc h \<surd>; rm_lookup a h = None; P,h \<turnstile>sc obj \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc rm_update a obj h \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_new simp add: rm.lookup_correct rm.update_correct)

lemma sc_hconf_upd_obj: "\<lbrakk> P \<turnstile>sc h \<surd>; rm_lookup a h = Some (Obj C fs); P,h \<turnstile>sc (Obj C fs') \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc rm_update a (Obj C fs') h \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_obj simp add: rm.lookup_correct rm.update_correct)

lemma sc_hconf_upd_arr: "\<lbrakk> P \<turnstile>sc h \<surd>; rm_lookup a h = Some(Arr T si f el); P,h \<turnstile>sc (Arr T si f' el') \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc rm_update a (Arr T si f' el') h \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_arr simp add: rm.lookup_correct rm.update_correct)

lemma sc_heap_conf:
  "heap_conf addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_write (sc_hconf P) P"
proof
  show "P \<turnstile>sc sc_empty \<surd>" by(simp add: sc_hconf_def rm.empty_correct)
next
  fix h a hT
  assume "sc_typeof_addr h a = \<lfloor>hT\<rfloor>" "P \<turnstile>sc h \<surd>"
  thus "is_htype P hT"
    by(auto simp add: sc_typeof_addr_def sc_oconf_def dest!: sc_hconfD split: heapobj.split_asm)
next
  fix h' hT h a
  assume "P \<turnstile>sc h \<surd>" "(h', a) \<in> sc_allocate P h hT" "is_htype P hT"
  thus "P \<turnstile>sc h' \<surd>"
    by(auto simp add: sc_allocate_def dest!: new_Addr_SomeD intro: sc_hconf_new sc_oconf_blank split: split_if_asm)
next
  fix h a al T v h'
  assume "P \<turnstile>sc h \<surd>"
    and "sc.addr_loc_type P h a al T"
    and "P,h \<turnstile>sc v :\<le> T"
    and "sc_heap_write h a al v h'"
  thus "P \<turnstile>sc h' \<surd>"
    by(cases al)(fastforce elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def intro: sc_hconf_upd_obj sc_oconf_fupd sc_hconfD sc_hconf_upd_arr sc_oconf_fupd_arr sc_oconf_fupd_arr_fields)+
qed

interpretation sc!:
  heap_conf
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P
by(rule sc_heap_conf)

lemma sc_heap_progress:
  "heap_progress addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al T
  assume hconf: "P \<turnstile>sc h \<surd>"
    and alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "rm_lookup a h = \<lfloor>arrobj\<rfloor>"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  from alt show "\<exists>v. sc_heap_read h a al v \<and> P,h \<turnstile>sc v :\<le> T"
  proof(cases)
    case (addr_loc_type_field U F fm D)
    note [simp] = `al = CField D F`
    show ?thesis
    proof(cases "arrobj")
      case (Obj C' fs)
      with `sc_typeof_addr h a = \<lfloor>U\<rfloor>` arrobj
      have [simp]: "C' = class_type_of U" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Obj have "P,h \<turnstile>sc Obj (class_type_of U) fs \<surd>" by(auto dest: sc_hconfD)
      with `P \<turnstile> class_type_of U has F:T (fm) in D` obtain fs' v
      where "tm_lookup (String.explode F) fs = \<lfloor>fs'\<rfloor>" "lm_lookup D fs' = \<lfloor>v\<rfloor>" "P,h \<turnstile>sc v :\<le> T"
      by(fastforce simp add: sc_oconf_def tm.lookup_correct lm.lookup_correct)
      thus ?thesis using Obj arrobj by(auto intro: sc_heap_read.intros)
    next
      case (Arr T' si f el)
      with `sc_typeof_addr h a = \<lfloor>U\<rfloor>` arrobj
      have [simp]: "U = Array_type T' si" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Arr have "P,h \<turnstile>sc Arr T' si f el \<surd>" by(auto dest: sc_hconfD)
      from `P \<turnstile> class_type_of U has F:T (fm) in D` have [simp]: "D = Object"
        by(auto dest: has_field_decl_above)
      with `P,h \<turnstile>sc Arr T' si f el \<surd>` `P \<turnstile> class_type_of U has F:T (fm) in D`
      obtain v where "lm_lookup F f = \<lfloor>v\<rfloor>" "P,h \<turnstile>sc v :\<le> T"
        by(fastforce simp add: sc_oconf_def)
      thus ?thesis using Arr arrobj by(auto intro: sc_heap_read.intros)
    qed
  next
    case (addr_loc_type_cell n' n)
    with arrobj obtain si f el
      where [simp]: "arrobj = Arr T si f el"
      by(cases arrobj)(auto simp add: sc_typeof_addr_def)
    from addr_loc_type_cell arrobj
    have [simp]: "al = ACell n" and n: "n < si" by(auto simp add: sc_typeof_addr_def)
    from hconf arrobj have "P,h \<turnstile>sc Arr T si f el \<surd>" by(auto dest: sc_hconfD)
    with n obtain v where "rm_lookup n el = \<lfloor>v\<rfloor>" "P,h \<turnstile>sc v :\<le> T"
      by(fastforce simp add: sc_oconf_def rm.lookup_correct)
    thus ?thesis using arrobj n by(fastforce intro: sc_heap_read.intros)
  qed
next
  fix h a al T v
  assume alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "rm_lookup a h = \<lfloor>arrobj\<rfloor>"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  thus "\<exists>h'. sc_heap_write h a al v h'" using alt
    by(cases arrobj)(fastforce intro: sc_heap_write.intros elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def dest: has_field_decl_above)+
qed

interpretation sc!:
  heap_progress
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P
by(rule sc_heap_progress)

lemma sc_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al v T
  assume read: "sc_heap_read h a al v"
    and alt: "sc.addr_loc_type P h a al T"
    and hconf: "P \<turnstile>sc h \<surd>"
  thus "P,h \<turnstile>sc v :\<le> T"
    apply(auto elim!: sc_heap_read.cases sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
    apply(fastforce dest!: sc_hconfD simp add: sc_oconf_def tm.lookup_correct lm.lookup_correct rm.lookup_correct)+
    done
qed

interpretation sc!:
  heap_conf_read
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
    "sc_hconf P"
    "P"
  for P
by(rule sc_heap_conf_read)

abbreviation sc_deterministic_heap_ops :: "'m prog \<Rightarrow> bool"
where "sc_deterministic_heap_ops \<equiv> sc.deterministic_heap_ops TYPE('m)"

lemma sc_deterministic_heap_ops: "\<not> sc_spurious_wakeups \<Longrightarrow> sc_deterministic_heap_ops P"
by(rule sc.deterministic_heap_opsI)(auto elim: sc_heap_read.cases sc_heap_write.cases simp add: sc_allocate_def)

subsection {* Code generation *}

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  sc_heap_read .

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  sc_heap_write .

lemma eval_sc_heap_read_i_i_i_o:
  "Predicate.eval (sc_heap_read_i_i_i_o h ad al) = sc_heap_read h ad al"
by(auto elim: sc_heap_read_i_i_i_oE intro: sc_heap_read_i_i_i_oI intro!: ext)

lemma eval_sc_heap_write_i_i_i_i_o:
  "Predicate.eval (sc_heap_write_i_i_i_i_o h ad al v) = sc_heap_write h ad al v"
by(auto elim: sc_heap_write_i_i_i_i_oE intro: sc_heap_write_i_i_i_i_oI intro!: ext)

end


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

theory AsmSemanticsRespects

imports "GlobalsSwap"

begin

definition
  asm_semantics_protects_globs
    :: "('g \<Rightarrow> heap_raw_state) \<Rightarrow> ((heap_raw_state \<Rightarrow> heap_raw_state) \<Rightarrow> 'g \<Rightarrow> 'g)
    \<Rightarrow> ('g \<Rightarrow> 'a)
    \<Rightarrow> (string \<Rightarrow> addr) \<Rightarrow> ('g global_data list)
    \<Rightarrow> bool"
where
  "asm_semantics_protects_globs mem memu ms symtab xs
    \<equiv> (let sw = globals_swap mem memu symtab xs
        in (\<forall>v v' s m' ms' specname. (v', m', ms')
            \<in> asm_semantics specname v
                (hrs_mem (mem (sw s)), ms s)
           \<longrightarrow> const_globals_in_memory symtab xs
                (hrs_mem (mem (sw (sw s))))
           \<longrightarrow> const_globals_in_memory symtab xs
                (hrs_mem (mem (sw (memu (hrs_mem_update (\<lambda>_. m')) (sw s)))))))"

abbreviation(input)
  asm_ops_are_swap
    :: "('g \<Rightarrow> heap_raw_state) \<Rightarrow> ((heap_raw_state \<Rightarrow> heap_raw_state) \<Rightarrow> 'g \<Rightarrow> 'g)
    \<Rightarrow> ('g \<Rightarrow> 'a) \<Rightarrow> (('a \<Rightarrow> 'a) \<Rightarrow> 'g \<Rightarrow> 'g)
    \<Rightarrow> (string \<Rightarrow> addr) \<Rightarrow> ('g \<Rightarrow> 'b) \<Rightarrow> ('g global_data list)
    \<Rightarrow> bool"
where
  "asm_ops_are_swap mem memu ms msu symtab gdata xs
    \<equiv> (let sw = globals_swap mem memu symtab xs
      in (\<forall>s. asm_fetch s = (hrs_mem (mem (sw s)), ms (sw s)))
        \<and> (\<forall>v s. asm_store gdata v s = sw (msu (\<lambda>_. snd v)
            (memu (hrs_mem_update (\<lambda>_. fst v)) (sw s))))
        \<and> asm_semantics_protects_globs mem memu ms symtab xs)"

lemma asm_semantics_protects_globs_revD[OF refl]:
  "sw = globals_swap mem memu symtab xs
    \<Longrightarrow> (v', m', ms')
            \<in> asm_semantics specname v
                (hrs_mem (mem (sw s)), ms s)
    \<Longrightarrow> asm_semantics_protects_globs mem memu ms symtab xs
            \<longrightarrow> const_globals_in_memory symtab xs
                (hrs_mem (mem (sw (sw s))))
            \<longrightarrow> const_globals_in_memory symtab xs
                (hrs_mem (mem (sw (memu (hrs_mem_update (\<lambda>_. m')) (sw s)))))"
  apply (simp add: asm_semantics_protects_globs_def Let_def)
  apply blast
  done

end