(*  Title:       Noninterference Security in Communicating Sequential Processes
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "CSP noninterference vs. generalized noninterference"

theory GeneralizedNoninterference
imports ClassicalNoninterference
begin

text \<open>
\null

The purpose of this section is to compare CSP noninterference security as defined previously with
McCullough's notion of generalized noninterference security as formulated in \cite{R4}. It will be
shown that this security property is weaker than both CSP noninterference security for a generic
process, and classical noninterference security for classical processes, viz. it is a necessary but
not sufficient condition for them. This renders CSP noninterference security preferable as an
extension of classical noninterference security to nondeterministic systems.

For clarity, all the constants and fact names defined in this section, with the possible exception
of datatype constructors and main theorems, contain prefix \<open>g_\<close>.
\<close>

subsection "Generalized noninterference"

text \<open>
The original formulation of generalized noninterference security as contained in \cite{R4} focuses
on systems whose events, split in inputs and outputs, are mapped into either of two security levels,
\emph{high} and \emph{low}. Such a system is said to be secure just in case, for any trace
\<open>xs\<close> and any high-level input \<open>x\<close>, the set of the \emph{possible low-level futures} of
\<open>xs\<close>, i.e. of the sequences of low-level events that may succeed \<open>xs\<close> in the traces of
the system, is equal to the set of the possible low-level futures of \<open>xs @ [x]\<close>.

This definition requires the following corrections:

\begin{itemize}

\item
Variable \<open>x\<close> must range over all high-level events rather than over high-level inputs alone,
since high-level outputs must not be allowed to affect low-level futures as well.

\item
For any \<open>x\<close>, the range of trace \<open>xs\<close> must be restricted to the traces of the system that
may be succeeded by \<open>x\<close>, viz. trace \<open>xs\<close> must be such that event list \<open>xs @ [x]\<close>
be itself a trace.
\\Otherwise, a system that admits both high-level and low-level events in its alphabet but never
accepts any high-level event, always accepting any low-level one instead, would turn out not to be
secure, which is paradoxical since \emph{high} can by no means affect \emph{low} in a system never
engaging in high-level events. The cause of the paradox is that, for each trace \<open>xs\<close> and each
high-level event \<open>x\<close> of such a system, the set of the possible low-level futures of \<open>xs\<close>
matches the Kleene closure of the set of low-level events, whereas the set of the possible low-level
futures of \<open>xs @ [x]\<close> matches the empty set as \<open>xs @ [x]\<close> is not a trace.

\end{itemize}

Observe that the latter correction renders it unnecessary to explicitly assume that event list
\<open>xs\<close> be a trace of the system, as this follows from the assumption that \<open>xs @ [x]\<close> be
such.

Here below is a formal definition of the notion of generalized noninterference security for
processes, amended in accordance with the previous considerations.

\null
\<close>

datatype g_level = High | Low

definition g_secure :: "'a process \<Rightarrow> ('a \<Rightarrow> g_level) \<Rightarrow> bool" where
"g_secure P L \<equiv> \<forall>xs x. xs @ [x] \<in> traces P \<and> L x = High \<longrightarrow>
  {ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]} =
  {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]}"

text \<open>
\null

It is possible to prove that a weaker sufficient (as well as necessary, as obvious) condition for
generalized noninterference security is that the set of the possible low-level futures of trace
\<open>xs\<close> be included in the set of the possible low-level futures of trace \<open>xs @ [x]\<close>,
because the latter is always included in the former.

In what follows, such security property is defined formally and its sufficiency for generalized
noninterference security to hold is demonstrated in the form of an introduction rule, which will
turn out to be useful in subsequent proofs.

\null
\<close>

definition g_secure_suff :: "'a process \<Rightarrow> ('a \<Rightarrow> g_level) \<Rightarrow> bool" where
"g_secure_suff P L \<equiv> \<forall>xs x. xs @ [x] \<in> traces P \<and> L x = High \<longrightarrow>
  {ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]} \<subseteq>
  {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]}"

lemma g_secure_suff_implies_g_secure:
  assumes S: "g_secure_suff P L"
  shows "g_secure P L"
proof (simp add: g_secure_def, (rule allI)+, rule impI, erule conjE)
  fix xs x
  assume
    A: "xs @ [x] \<in> traces P" and
    B: "L x = High"
  show "{ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys . L y = Low]} =
    {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys . L y = Low]}"
   (is "{ys'. \<exists>ys. ?Q ys ys'} = {ys'. \<exists>ys. ?Q' ys ys'}")
  proof (rule equalityI, rule_tac [2] subsetI, simp_all, erule_tac [2] exE,
   erule_tac [2] conjE)
    show "{ys'. \<exists>ys. ?Q ys ys'} \<subseteq> {ys'. \<exists>ys. ?Q' ys ys'}"
     using S and A and B by (simp add: g_secure_suff_def)
  next
    fix ys ys'
    assume "xs @ x # ys \<in> traces P"
    moreover assume "ys' = [y\<leftarrow>ys. L y = Low]"
    hence "ys' = [y\<leftarrow>x # ys. L y = Low]" using B by simp
    ultimately have "?Q (x # ys) ys'" ..
    thus "\<exists>ys. ?Q ys ys'" ..
  qed
qed

subsection "Comparison between security properties"

text \<open>
In the continuation, it will be proven that CSP noninterference security is a sufficient condition
for generalized noninterference security for any process whose events are mapped into either
security domain \<open>High\<close> or \<open>Low\<close>, under the policy that \<open>High\<close> may not affect
\<open>Low\<close>.

Particularly, this is the case for any such classical process. This fact, along with the equivalence
between CSP noninterference security and classical noninterference security for classical processes,
is used to additionally prove that the classical noninterference security of a deterministic state
machine is a sufficient condition for the generalized noninterference security of the corresponding
classical process under the aforesaid policy.

\null
\<close>

definition g_I :: "(g_level \<times> g_level) set" where
"g_I \<equiv> {(High, High), (Low, Low), (Low, High)}"

lemma g_I_refl: "refl g_I"
proof (simp add: refl_on_def, rule allI)
  fix x
  show "(x, x) \<in> g_I" by (cases x, simp_all add: g_I_def)
qed

lemma g_sinks: "sinks g_I L High xs \<subseteq> {High}"
proof (induction xs rule: rev_induct, simp)
  fix x xs
  assume A: "sinks g_I L High xs \<subseteq> {High}"
  show "sinks g_I L High (xs @ [x]) \<subseteq> {High}"
  proof (cases "L x")
    assume "L x = High"
    thus ?thesis using A by simp
  next
    assume B: "L x = Low"
    have "\<not> ((High, L x) \<in> g_I \<or> (\<exists>v \<in> sinks g_I L High xs. (v, L x) \<in> g_I))"
    proof (rule notI, simp add: B, erule disjE)
      assume "(High, Low) \<in> g_I"
      moreover have "(High, Low) \<notin> g_I" by (simp add: g_I_def)
      ultimately show False by contradiction
    next
      assume "\<exists>v \<in> sinks g_I L High xs. (v, Low) \<in> g_I"
      then obtain v where C: "v \<in> sinks g_I L High xs" and D: "(v, Low) \<in> g_I" ..
      have "v \<in> {High}" using A and C ..
      hence "(High, Low) \<in> g_I" using D by simp
      moreover have "(High, Low) \<notin> g_I" by (simp add: g_I_def)
      ultimately show False by contradiction
    qed
    thus ?thesis using A by simp
  qed
qed

lemma g_ipurge_tr: "ipurge_tr g_I L High xs = [x\<leftarrow>xs. L x = Low]"
proof (induction xs rule: rev_induct, simp)
  fix x xs
  assume A: "ipurge_tr g_I L High xs = [x'\<leftarrow>xs. L x' = Low]"
  show "ipurge_tr g_I L High (xs @ [x]) = [x'\<leftarrow>xs @ [x]. L x' = Low]"
  proof (cases "L x")
    assume B: "L x = High"
    hence "ipurge_tr g_I L High (xs @ [x]) = ipurge_tr g_I L High xs"
     by (simp add: g_I_def)
    moreover have "[x'\<leftarrow>xs @ [x]. L x' = Low] = [x'\<leftarrow>xs. L x' = Low]"
     using B by simp
    ultimately show ?thesis using A by simp
  next
    assume B: "L x = Low"
    have "L x \<notin> sinks g_I L High (xs @ [x])"
    proof (rule notI, simp only: B)
      have "sinks g_I L High (xs @ [x]) \<subseteq> {High}" by (rule g_sinks)
      moreover assume "Low \<in> sinks g_I L High (xs @ [x])"
      ultimately have "Low \<in> {High}" ..
      thus False by simp
    qed
    hence "ipurge_tr g_I L High (xs @ [x]) = ipurge_tr g_I L High xs @ [x]"
     by simp
    moreover have "[x'\<leftarrow>xs @ [x]. L x' = Low] = [x'\<leftarrow>xs. L x' = Low] @ [x]"
     using B by simp
    ultimately show ?thesis using A by simp
  qed
qed

theorem secure_implies_g_secure:
  assumes S: "secure P g_I L"
  shows "g_secure P L"
proof (rule g_secure_suff_implies_g_secure, simp add: g_secure_suff_def, (rule allI)+,
 rule impI, rule subsetI, simp, erule exE, (erule conjE)+)
  fix xs x ys ys'
  assume "xs @ [x] \<in> traces P"
  hence "\<exists>X. ([x], X) \<in> futures P xs"
   by (simp add: traces_def Domain_iff futures_def)
  then obtain X where "([x], X) \<in> futures P xs" ..
  moreover assume "xs @ ys \<in> traces P"
  hence "\<exists>Y. (ys, Y) \<in> futures P xs"
   by (simp add: traces_def Domain_iff futures_def)
  then obtain Y where "(ys, Y) \<in> futures P xs" ..
  ultimately have "(x # ipurge_tr g_I L (L x) ys,
    ipurge_ref g_I L (L x) ys Y) \<in> futures P xs"
   (is "(_, ?Y') \<in> futures P xs") using S by (simp add: secure_def)
  moreover assume "L x = High" and A: "ys' = [y\<leftarrow>ys. L y = Low]"
  ultimately have "(x # ys', ?Y') \<in> futures P xs" by (simp add: g_ipurge_tr)
  hence "\<exists>Y'. (x # ys', Y') \<in> futures P xs" ..
  hence "xs @ x # ys' \<in> traces P"
   by (simp add: traces_def Domain_iff futures_def)
  moreover have "ys' = [y\<leftarrow>ys'. L y = Low]" using A by simp
  ultimately have "xs @ x # ys' \<in> traces P \<and> ys' = [y\<leftarrow>ys'. L y = Low]" ..
  thus "\<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]" ..
qed

theorem c_secure_implies_g_secure:
 "c_secure step out s\<^sub>0 g_I L \<Longrightarrow> g_secure (c_process step out s\<^sub>0) (c_dom L)"
by (rule secure_implies_g_secure, rule c_secure_implies_secure, rule g_I_refl)

text \<open>
\null

Since the definition of generalized noninterference security does not impose any explicit
requirement on process refusals, intuition suggests that this security property is likely to be
generally weaker than CSP noninterference security for nondeterministic processes, which are such
that even a complete specification of their traces leaves underdetermined their refusals. This is
not the case for deterministic processes, so the aforesaid security properties might in principle
be equivalent as regards such processes.

However, a counterexample proving the contrary is provided by a deterministic state machine
resembling systems \emph{A} and \emph{B} described in \cite{R4}, section 3.1. This machine is proven
not to be classical noninterference-secure, whereas the corresponding classical process turns out to
be generalized noninterference-secure, which proves that the generalized noninterference security of
a classical process is not a sufficient condition for the classical noninterference security of the
associated deterministic state machine.

This result, along with the equivalence between CSP noninterference security and classical
noninterference security for classical processes, is then used to demonstrate that the generalized
noninterference security of the aforesaid classical process does not entail its CSP noninterference
security, which proves that generalized noninterference security is actually not a sufficient
condition for CSP noninterference security even in the case of deterministic processes.

The remainder of this section is dedicated to the construction of such counterexample.

\null
\<close>

datatype g_state = Even | Odd

datatype g_action = Any | Count

primrec g_step :: "g_state \<Rightarrow> g_action \<Rightarrow> g_state" where
"g_step s Any = (case s of Even \<Rightarrow> Odd | Odd \<Rightarrow> Even)" |
"g_step s Count = s"

primrec g_out :: "g_state \<Rightarrow> g_action \<Rightarrow> g_state option" where
"g_out _ Any = None" |
"g_out s Count = Some s"

primrec g_D :: "g_action \<Rightarrow> g_level" where
"g_D Any = High" |
"g_D Count = Low"

definition g_s\<^sub>0 :: g_state where
"g_s\<^sub>0 \<equiv> Even"

lemma g_secure_counterexample:
 "g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D)"
proof (rule g_secure_suff_implies_g_secure, simp add: g_secure_suff_def, (rule allI)+,
 rule impI, rule subsetI, simp, erule exE, (erule conjE)+)
  fix xps x p yps yps'
  assume "xps @ [(x, p)] \<in> traces (c_process g_step g_out g_s\<^sub>0)"
  hence "\<exists>X. (xps @ [(x, p)], X) \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_traces)
  then obtain X where "(xps @ [(x, p)], X) \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "xps @ [(x, p)] = c_tr g_step g_out g_s\<^sub>0 (map fst (xps @ [(x, p)]))"
   by (rule c_failures_tr)
  moreover assume "c_dom g_D (x, p) = High"
  hence "x = Any" by (cases x, simp_all add: c_dom_def)
  ultimately have "xps @ [(x, p)] = c_tr g_step g_out g_s\<^sub>0 (map fst xps @ [Any])"
   (is "_ = _ (?xs @ _)") by simp
  moreover assume "xps @ yps \<in> traces (c_process g_step g_out g_s\<^sub>0)"
  hence "\<exists>Y. (xps @ yps, Y) \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_traces)
  then obtain Y where "(xps @ yps, Y) \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "(yps, Y) \<in> futures (c_process g_step g_out g_s\<^sub>0) xps"
   by (simp add: c_futures_failures)
  hence "yps = c_tr g_step g_out (foldl g_step g_s\<^sub>0 ?xs) (map fst yps)"
   (is "_ = c_tr _ _ _ ?ys") by (rule c_futures_tr)
  hence "yps =
    c_tr g_step g_out (foldl g_step (foldl g_step g_s\<^sub>0 (?xs @ [Any])) [Any]) ?ys"
   (is "_ = c_tr _ _ (foldl _ ?s _) _") by (cases "foldl g_step g_s\<^sub>0 ?xs", simp_all)
  hence "c_tr g_step g_out ?s [Any] @ yps = c_tr g_step g_out ?s ([Any] @ ?ys)"
   (is "?yp @ _ = _") by (simp only: c_tr_append)
  moreover have "(c_tr g_step g_out ?s ([Any] @ ?ys),
    {(x, p). p \<noteq> g_out (foldl g_step ?s ([Any] @ ?ys)) x})
    \<in> futures (c_process g_step g_out g_s\<^sub>0) (c_tr g_step g_out g_s\<^sub>0 (?xs @ [Any]))"
   (is "(_, ?Y') \<in> _") by (rule c_tr_futures)
  ultimately have "(?yp @ yps, ?Y')
    \<in> futures (c_process g_step g_out g_s\<^sub>0) (xps @ [(x, p)])"
   by simp
  hence "(xps @ (x, p) # ?yp @ yps, ?Y') \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_futures_failures)
  hence "\<exists>Y'. (xps @ (x, p) # ?yp @ yps, Y') \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "xps @ (x, p) # ?yp @ yps \<in> traces (c_process g_step g_out g_s\<^sub>0)"
   (is "?P (?yp @ yps)") by (simp add: c_traces)
  moreover assume "yps' = [yp\<leftarrow>yps. c_dom g_D yp = Low]"
  hence "yps' = [yp\<leftarrow>?yp @ yps. c_dom g_D yp = Low]"
   (is "?Q (?yp @ yps)") by (simp add: c_tr_singleton c_dom_def)
  ultimately have "?P (?yp @ yps) \<and> ?Q (?yp @ yps)" ..
  thus "\<exists>yps. ?P yps \<and> ?Q yps" ..
qed

lemma not_c_secure_counterexample:
 "\<not> c_secure g_step g_out g_s\<^sub>0 g_I g_D"
proof (simp add: c_secure_def)
  have "g_out (foldl g_step g_s\<^sub>0 [Any]) Count = Some Odd"
   (is "?f Count [Any] = _") by (simp add: g_s\<^sub>0_def)
  moreover have
    "g_out (foldl g_step g_s\<^sub>0 (c_ipurge g_I g_D (g_D Count) [Any])) Count =
    Some Even"
   (is "?g Count [Any] = _") by (simp add: g_I_def g_s\<^sub>0_def)
  ultimately have "?f Count [Any] \<noteq> ?g Count [Any]" by simp
  thus "\<exists>x xs. ?f x xs \<noteq> ?g x xs" by blast
qed

theorem not_g_secure_implies_c_secure:
 "\<not> (g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D) \<longrightarrow>
  c_secure g_step g_out g_s\<^sub>0 g_I g_D)"
proof (simp, rule conjI, rule g_secure_counterexample)
qed (rule not_c_secure_counterexample)

theorem not_g_secure_implies_secure:
 "\<not> (g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D) \<longrightarrow>
  secure (c_process g_step g_out g_s\<^sub>0) g_I (c_dom g_D))"
proof (simp, rule conjI, rule g_secure_counterexample)
qed (rule notI, drule secure_implies_c_secure, erule contrapos_pp,
 rule not_c_secure_counterexample)

end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>, 2003
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

header {* Store Properties *}

theory StoreProperties
imports Store
begin

text {* This theory formalizes advanced concepts and properties of stores. *}

subsection {* Reachability of a Location from a Reference *}

text {* For a given store, the function @{text "reachS"} yields the set of all pairs
$(l,v)$ where $l$ is a location that is reachable from the value $v$ (which must be a reference)
in the given store.
The predicate @{text "reach"} decides whether a location is reachable from a value in a store.
*}

inductive
  reach :: "Store \<Rightarrow> Location \<Rightarrow> Value \<Rightarrow> bool"
    ("_\<turnstile> _ reachable'_from _" [91,91,91]90)
  for s :: Store
where
  Immediate: "ref l \<noteq> nullV \<Longrightarrow> s\<turnstile> l reachable_from (ref l)"
| Indirect: "\<lbrakk>s\<turnstile> l reachable_from (s@@k); ref k \<noteq> nullV\<rbrakk>
             \<Longrightarrow> s\<turnstile> l reachable_from (ref k)"

text {* Note that we explicitly exclude @{text "nullV"} as legal reference
for reachability.
Keep in mind that static fields are not associated to any object,
therefore @{text "ref"} yields @{text "nullV"} if invoked on static fields
(see the
definition of the function @{text "ref"}, Sect. \ref{ref_def}).
Reachability only describes the locations directly
reachable from the object or array by following the pointers and should not include
the static fields if we encounter a @{text "nullV"} reference in the pointer
chain.*}

text {* We formalize some properties of reachability.
Especially, Lemma 3.2 as given in \cite[p. 53]{Poetzsch-Heffter97specification} is proven. *}

lemma unreachable_Null:
  assumes reach: "s\<turnstile> l reachable_from x" shows "x\<noteq>nullV"
  using reach by (induct) auto

corollary unreachable_Null_simp [simp]:
  "\<not> s\<turnstile> l reachable_from nullV"
  by (iprover dest: unreachable_Null)

corollary unreachable_NullE [elim]:
  "s\<turnstile> l reachable_from nullV \<Longrightarrow> P"
  by (simp)

lemma reachObjLoc [simp,intro]:
  "C=cls cf \<Longrightarrow> s\<turnstile> objLoc cf a reachable_from objV C a"
  by (iprover intro: reach.Immediate [of "objLoc cf a",simplified])

lemma reachArrLoc [simp,intro]: "s\<turnstile> arrLoc T a i reachable_from arrV T a"
  by (rule reach.Immediate [of "arrLoc T a i",simplified])

lemma reachArrLen [simp,intro]: "s\<turnstile> arrLenLoc T a reachable_from arrV T a"
  by (rule reach.Immediate [of "arrLenLoc T a",simplified])

lemma unreachStatic [simp]: "\<not> s\<turnstile> staticLoc f reachable_from x"
proof -
  {
    fix y assume "s\<turnstile> y reachable_from x" "y=staticLoc f"
    then have False
      by induct auto
  }
  thus ?thesis
    by auto
qed

lemma unreachStaticE [elim]: "s\<turnstile> staticLoc f reachable_from x \<Longrightarrow> P"
  by (simp add: unreachStatic)

lemma reachable_from_ArrLoc_impl_Arr [simp,intro]:
  assumes reach_loc: "s\<turnstile> l reachable_from (s@@arrLoc T a i)"
  shows "s\<turnstile> l reachable_from (arrV T a)"
  using reach.Indirect [OF reach_loc]
  by simp

lemma reachable_from_ObjLoc_impl_Obj [simp,intro]:
  assumes reach_loc: "s\<turnstile> l reachable_from (s@@objLoc cf a)"
  assumes C: "C=cls cf"
  shows "s\<turnstile> l reachable_from (objV C a)"
  using C reach.Indirect [OF reach_loc]
  by simp

text {* Lemma 3.2 (i) *}
lemma reach_update [simp]:
  assumes unreachable_l_x: "\<not> s\<turnstile> l reachable_from x"
  shows "s\<langle>l:=y\<rangle>\<turnstile> k reachable_from  x = s\<turnstile> k reachable_from x"
proof
  assume "s\<turnstile> k reachable_from x"
  from this unreachable_l_x
  show "s\<langle>l := y\<rangle>\<turnstile> k reachable_from x"
  proof (induct)
    case (Immediate k)
    have "ref k \<noteq> nullV" by fact
    then show "s\<langle>l := y\<rangle>\<turnstile> k reachable_from (ref k)"
      by (rule reach.Immediate)
  next
    case (Indirect k m)
    have hyp: "\<not> s\<turnstile> l reachable_from (s@@m)
               \<Longrightarrow> s\<langle>l:=y\<rangle> \<turnstile> k reachable_from (s@@m)" by fact
    have "ref m \<noteq> nullV" and "\<not> s\<turnstile> l reachable_from (ref m)" by fact+
    hence "l\<noteq>m" "\<not> s\<turnstile> l reachable_from (s@@m)"
      by (auto intro: reach.intros)
    with hyp have "s\<langle>l := y\<rangle> \<turnstile> k reachable_from (s\<langle>l := y\<rangle>@@m)"
      by simp
    then show "s\<langle>l := y\<rangle>\<turnstile> k reachable_from (ref m)"
      by (rule reach.Indirect) (rule Indirect.hyps)
  qed
next
  assume "s\<langle>l := y\<rangle>\<turnstile> k reachable_from x"
  from this unreachable_l_x
  show "s\<turnstile> k reachable_from x"
  proof (induct)
    case (Immediate k)
    have "ref k \<noteq> nullV" by fact
    then show "s \<turnstile> k reachable_from (ref k)"
      by (rule reach.Immediate)
  next
    case (Indirect k m)
    with Indirect.hyps
    have hyp: "\<not> s\<turnstile> l reachable_from (s\<langle>l := y\<rangle>@@m)
               \<Longrightarrow> s\<turnstile> k reachable_from (s\<langle>l := y\<rangle>@@m)" by simp
    have "ref m \<noteq> nullV" and "\<not> s\<turnstile> l reachable_from (ref m)" by fact+
    hence "l\<noteq>m" "\<not> s \<turnstile> l reachable_from (s@@m)"
      by (auto intro: reach.intros)
    with hyp have "s \<turnstile> k reachable_from (s@@m)"
      by simp
    thus "s\<turnstile> k reachable_from (ref m)"
      by (rule reach.Indirect) (rule Indirect.hyps)
  qed
qed

text {* Lemma 3.2 (ii) *}
lemma reach2:
  "\<not> s\<turnstile> l reachable_from x \<Longrightarrow> \<not> s\<langle>l:=y\<rangle>\<turnstile> l reachable_from x"
  by (simp)

text {* Lemma 3.2 (iv) *}
lemma reach4: "\<not> s \<turnstile> l reachable_from (ref k) \<Longrightarrow> k \<noteq> l \<or> (ref k) = nullV"
  by (auto intro: reach.intros)

lemma reachable_isRef:
  assumes reach: "s\<turnstile>l reachable_from x"
  shows "isRefV x"
  using reach
proof (induct)
  case (Immediate l)
  show "isRefV (ref l)"
    by (cases l) simp_all
next
  case (Indirect l k)
  show "isRefV (ref k)"
    by (cases k) simp_all
qed

lemma val_ArrLen_IntgT: "isArrLenLoc l \<Longrightarrow> typeof (s@@l) = IntgT"
proof -
  assume isArrLen: "isArrLenLoc l"
  have T: "typeof (s@@l) \<le> ltype l"
    by (simp)
  also from isArrLen have I: "ltype l = IntgT"
    by (cases l) simp_all
  finally show ?thesis
    by (auto elim: rtranclE simp add: le_Javatype_def subtype_defs)
qed

lemma access_alloc' [simp]:
  assumes no_arr_len: "\<not> isArrLenLoc l"
  shows "s\<langle>t\<rangle>@@l = s@@l"
proof -
  from no_arr_len
  have "isNewArr t \<longrightarrow> l \<noteq> arr_len (new s t)"
    by (cases t) (auto simp add: new_def isArrLenLoc_def split: Location.splits)
  thus ?thesis
    by (rule access_alloc)
qed

text {* Lemma 3.2 (v) *}
lemma reach_alloc [simp]: "s\<langle>t\<rangle>\<turnstile> l reachable_from x = s\<turnstile> l reachable_from x"
proof
  assume "s\<langle>t\<rangle>\<turnstile> l reachable_from x"
  thus "s\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    thus "s\<turnstile> l reachable_from ref l"
      by (rule reach.intros)
  next
    case (Indirect l k)
    have reach_k: "s\<turnstile> l reachable_from (s\<langle>t\<rangle>@@k)" by fact
    moreover
    have "s\<langle>t\<rangle>@@k = s@@k"
    proof -
      from reach_k have isRef: "isRefV (s\<langle>t\<rangle>@@k)"
        by (rule reachable_isRef)
      have "\<not> isArrLenLoc k"
      proof (rule ccontr,simp)
        assume "isArrLenLoc k"
        then have "typeof (s\<langle>t\<rangle>@@k) = IntgT"
          by (rule val_ArrLen_IntgT)
        with isRef
        show "False"
          by (cases "(s\<langle>t\<rangle>@@k)") simp_all
      qed
      thus ?thesis
        by (rule access_alloc')
    qed
    ultimately have "s\<turnstile> l reachable_from (s@@k)"
      by simp
    thus "s\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
  qed
next
  assume "s\<turnstile> l reachable_from x"
  thus "s\<langle>t\<rangle>\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    thus "s\<langle>t\<rangle>\<turnstile> l reachable_from ref l"
      by (rule reach.intros)
  next
    case (Indirect l k)
    have reach_k: "s\<langle>t\<rangle>\<turnstile> l reachable_from (s@@k)" by fact
    moreover
    have "s\<langle>t\<rangle>@@k = s@@k"
    proof -
      from reach_k have isRef: "isRefV (s@@k)"
        by (rule reachable_isRef)
      have "\<not> isArrLenLoc k"
      proof (rule ccontr,simp)
        assume "isArrLenLoc k"
        then have "typeof (s@@k) = IntgT"
          by (rule val_ArrLen_IntgT)
        with isRef
        show "False"
          by (cases "(s@@k)") simp_all
      qed
      thus ?thesis
        by (rule access_alloc')
    qed
    ultimately have "s\<langle>t\<rangle>\<turnstile> l reachable_from (s\<langle>t\<rangle>@@k)"
      by simp
    thus "s\<langle>t\<rangle>\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
  qed
qed

text {* Lemma 3.2 (vi) *}
lemma reach6: "isprimitive(typeof x) \<Longrightarrow> \<not> s \<turnstile> l reachable_from x"
proof
  assume prim: "isprimitive(typeof x)"
  assume "s \<turnstile> l reachable_from x"
  hence "isRefV x"
    by (rule reachable_isRef)
  with prim show False
    by (cases x) simp_all
qed

text {* Lemma 3.2 (iii) *}
lemma reach3:
  assumes k_y: "\<not> s\<turnstile> k reachable_from y"
  assumes k_x: "\<not> s\<turnstile> k reachable_from x"
  shows "\<not> s\<langle>l:=y\<rangle>\<turnstile> k reachable_from x"
proof
  assume "s\<langle>l:=y\<rangle>\<turnstile> k reachable_from x"
  from this k_y k_x
  show False
  proof (induct)
    case (Immediate l)
    have "\<not> s\<turnstile> l reachable_from ref l" and "ref l \<noteq> nullV" by fact+
    thus False
      by (iprover intro: reach.intros)
  next
    case (Indirect m k)
    have k_not_Null: "ref k \<noteq> nullV" by fact
    have not_m_y: "\<not> s\<turnstile> m reachable_from y" by fact
    have not_m_k: "\<not> s\<turnstile> m reachable_from ref k" by fact
    have hyp: "\<lbrakk>\<not> s\<turnstile> m reachable_from y; \<not> s\<turnstile> m reachable_from (s\<langle>l := y\<rangle>@@k)\<rbrakk>
               \<Longrightarrow> False" by fact
    have m_upd_k: "s\<langle>l := y\<rangle>\<turnstile> m reachable_from (s\<langle>l := y\<rangle>@@k)" by fact
    show False
    proof (cases "l=k")
      case False
      then have "s\<langle>l := y\<rangle>@@k = s@@k" by simp
      moreover
      from not_m_k k_not_Null have "\<not> s\<turnstile> m reachable_from (s@@k)"
        by (iprover intro: reach.intros)
      ultimately show False
        using not_m_y hyp by simp
    next
      case True note eq_l_k = this
      show ?thesis
      proof (cases "alive (ref l) s \<and> alive y s \<and> typeof y \<le> ltype l")
        case True
        with eq_l_k have "s\<langle>l := y\<rangle>@@k = y"
          by simp
        with not_m_y hyp show False by simp
      next
        case False
        hence "s\<langle>l := y\<rangle> = s"
          by auto
        moreover
        from not_m_k k_not_Null have "\<not> s\<turnstile> m reachable_from (s@@k)"
          by (iprover intro: reach.intros)
        ultimately show False
          using not_m_y hyp by simp
      qed
    qed
  qed
qed

text {* Lemma 3.2 (vii). *}

lemma unreachable_from_init [simp,intro]: "\<not> s\<turnstile> l reachable_from (init T)"
  using reach6 by (cases T) simp_all

lemma ref_reach_unalive:
  assumes unalive_x:"\<not> alive x s"
  assumes l_x: "s\<turnstile> l reachable_from x"
  shows "x = ref l"
using l_x unalive_x
proof induct
  case (Immediate l)
  show "ref l = ref l"
    by simp
next
  case (Indirect l k)
  have "ref k \<noteq> nullV" by fact
  have "\<not> alive (ref k) s" by fact
  hence "s@@k = init (ltype k)" by simp
  moreover have "s\<turnstile> l reachable_from (s@@k)" by fact
  ultimately have False by simp
  thus ?case ..
qed

lemma loc_new_reach:
  assumes l: "ref l = new s t"
  assumes l_x: "s\<turnstile> l reachable_from x"
  shows "x = new s t"
using l_x l
proof induct
  case (Immediate l)
  show "ref l = new s t" by fact
next
  case (Indirect l k)
  hence "s@@k = new s t" by iprover
  moreover
  have "\<not> alive (new s t) s"
    by simp
  moreover
  have "alive (s@@k) s"
    by simp
  ultimately have False by simp
  thus ?case ..
qed

text {* Lemma 3.2 (viii) *}
lemma alive_reach_alive:
  assumes alive_x: "alive x s"
  assumes reach_l: "s \<turnstile> l reachable_from x"
  shows "alive (ref l) s"
using reach_l alive_x
proof (induct)
  case (Immediate l)
  show ?case by fact
next
  case (Indirect l k)
  have hyp: "alive (s@@k) s \<Longrightarrow> alive (ref l) s" by fact
  moreover have "alive (s@@k) s" by simp
  ultimately
  show "alive (ref l) s"
    by iprover
qed

text {* Lemma 3.2 (ix) *}
lemma reach9:
  assumes reach_impl_access_eq: "\<forall>l. s1\<turnstile>l reachable_from x \<longrightarrow> (s1@@l = s2@@l)"
  shows "s1\<turnstile> l reachable_from x = s2\<turnstile> l reachable_from x"
proof
  assume "s1\<turnstile> l reachable_from x"
  from this reach_impl_access_eq
  show "s2\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    show "s2\<turnstile> l reachable_from ref l"
      by (rule reach.intros) (rule Immediate.hyps)
  next
    case (Indirect l k)
    have hyp: "\<forall>l. s1\<turnstile> l reachable_from (s1@@k) \<longrightarrow> s1@@l = s2@@l
               \<Longrightarrow> s2\<turnstile> l reachable_from (s1@@k)" by fact
    have k_not_Null: "ref k \<noteq> nullV" by fact
    have reach_impl_access_eq:
      "\<forall>l. s1\<turnstile> l reachable_from ref k \<longrightarrow> s1@@l = s2@@l" by fact
    have "s1\<turnstile> l reachable_from (s1@@k)" by fact
    with k_not_Null
    have "s1@@k = s2@@k"
      by (iprover intro: reach_impl_access_eq [rule_format] reach.intros)
    moreover from reach_impl_access_eq k_not_Null
    have "\<forall>l. s1\<turnstile> l reachable_from (s1@@k) \<longrightarrow> s1@@l = s2@@l"
      by (iprover intro: reach.intros)
    then have "s2\<turnstile> l reachable_from (s1@@k)"
      by (rule hyp)
    ultimately have "s2\<turnstile> l reachable_from (s2@@k)"
      by simp
    thus "s2\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
  qed
next
  assume "s2\<turnstile> l reachable_from x"
  from this reach_impl_access_eq
  show "s1\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    show "s1\<turnstile> l reachable_from ref l"
      by (rule reach.intros) (rule Immediate.hyps)
  next
    case (Indirect l k)
    have hyp: "\<forall>l. s1\<turnstile> l reachable_from (s2@@k) \<longrightarrow> s1@@l = s2@@l
               \<Longrightarrow> s1\<turnstile> l reachable_from (s2@@k)" by fact
    have k_not_Null: "ref k \<noteq> nullV" by fact
    have reach_impl_access_eq:
      "\<forall>l. s1\<turnstile> l reachable_from ref k \<longrightarrow> s1@@l = s2@@l" by fact
    have "s1\<turnstile> k reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
    with reach_impl_access_eq
    have eq_k: "s1@@k = s2@@k"
      by simp
    from reach_impl_access_eq k_not_Null
    have "\<forall>l. s1\<turnstile> l reachable_from (s1@@k) \<longrightarrow> s1@@l = s2@@l"
      by (iprover intro: reach.intros)
    then
    have "\<forall>l. s1\<turnstile> l reachable_from (s2@@k) \<longrightarrow> s1@@l = s2@@l"
      by (simp add: eq_k)
    with eq_k hyp have "s1\<turnstile> l reachable_from (s1@@k)"
      by simp
    thus "s1\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
   qed
qed

subsection {* Reachability of a Reference from a Reference *}

text {* The predicate @{text "rreach"} tests whether a value is reachable from
another value. This is an extension of the predicate @{text "oreach"} as described
in \cite[p. 54]{Poetzsch-Heffter97specification} because now arrays are handled as well.
*}

definition rreach:: "Store \<Rightarrow> Value \<Rightarrow> Value \<Rightarrow> bool"
  ("_|-Ref _ reachable'_from _" [91,91,91]90) where
"s|-Ref y reachable_from x = (\<exists> l. s\<turnstile> l reachable_from x \<and> y = ref l)"

notation (xsymbols)
  rreach  ("_\<turnstile>Ref _ reachable'_from _" [91,91,91]90)

subsection {* Disjointness of Reachable Locations *}

text {* The predicate @{text "disj"} tests whether two values are disjoint
in a given store. Its properties as given in
\cite[Lemma 3.3, p. 54]{Poetzsch-Heffter97specification} are then proven.
*}

definition disj:: "Value \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> bool" where
"disj x y s = (\<forall> l. \<not> s\<turnstile> l reachable_from x \<or> \<not> s\<turnstile> l reachable_from y)"

lemma disjI1: "\<lbrakk>\<And> l. s\<turnstile> l reachable_from x \<Longrightarrow> \<not> s\<turnstile> l reachable_from y\<rbrakk>
 \<Longrightarrow> disj x y s"
  by (simp add: disj_def)

lemma disjI2: "\<lbrakk>\<And> l. s\<turnstile> l reachable_from y \<Longrightarrow> \<not> s\<turnstile> l reachable_from x\<rbrakk>
 \<Longrightarrow> disj x y s"
  by (auto simp add: disj_def)

lemma disj_cases [consumes 1]:
  assumes "disj x y s"
  assumes "\<And> l.  \<not> s\<turnstile> l reachable_from x \<Longrightarrow> P"
  assumes "\<And> l.  \<not> s\<turnstile> l reachable_from y \<Longrightarrow> P"
  shows "P"
  using assms by (auto simp add: disj_def)

text {* Lemma 3.3 (i) in \cite{Poetzsch-Heffter97specification} *}
lemma disj1: "\<lbrakk>disj x y s; \<not> s\<turnstile> l reachable_from x; \<not> s\<turnstile> l reachable_from y\<rbrakk>
              \<Longrightarrow> disj x y (s\<langle>l:=z\<rangle>)"
  by (auto simp add: disj_def)

text {* Lemma 3.3 (ii) *}
lemma disj2:
  assumes disj_x_y: "disj x y s"
  assumes disj_x_z: "disj x z s"
  assumes unreach_l_x: "\<not> s\<turnstile> l reachable_from x"
  shows "disj x y (s\<langle>l:=z\<rangle>)"
proof (rule disjI1)
  fix k
  assume reach_k_x: "s\<langle>l := z\<rangle>\<turnstile> k reachable_from x"
  show "\<not> s\<langle>l := z\<rangle>\<turnstile> k reachable_from y"
  proof -
    from unreach_l_x reach_k_x
    have reach_s_k_x: "s\<turnstile> k reachable_from x"
      by simp
    with disj_x_z
    have "\<not> s\<turnstile> k reachable_from z"
      by (simp add: disj_def)
    moreover from reach_s_k_x disj_x_y
    have "\<not> s\<turnstile> k reachable_from y"
      by (simp add: disj_def)
    ultimately show ?thesis
      by (rule reach3)
  qed
qed

text {* Lemma 3.3 (iii) *}
lemma disj3: assumes alive_x_s: "alive x s"
  shows "disj x (new s t) (s\<langle>t\<rangle>)"
proof (rule disjI1,simp only: reach_alloc)
  fix l
  assume reach_l_x: "s\<turnstile> l reachable_from x"
  show "\<not> s\<turnstile> l reachable_from new s t"
  proof
    assume reach_l_new: "s\<turnstile> l reachable_from new s t"
    have unalive_new: "\<not> alive (new s t) s" by simp
    from this reach_l_new
    have  "new s t = ref l"
      by (rule ref_reach_unalive)
    moreover from alive_x_s reach_l_x
    have "alive (ref l) s"
      by (rule alive_reach_alive)
    ultimately show False
      using unalive_new
      by simp
  qed
qed

text {* Lemma 3.3 (iv) *}
lemma disj4: "\<lbrakk>disj (objV C a) y s; CClassT C \<le> dtype f \<rbrakk>
              \<Longrightarrow> disj (s@@(objV C a)..f) y s"
  by (auto simp add: disj_def)

lemma disj4': "\<lbrakk>disj (arrV T a) y s \<rbrakk>
              \<Longrightarrow> disj (s@@(arrV T a).[i]) y s"
  by (auto simp add: disj_def)

subsection {* X-Equivalence *}

text {* We call two stores $s_1$ and $s_2$ equivalent wrt. a given value $X$
(which is called X-equivalence)
 iff $X$ and all values
reachable from $X$ in $s_1$ or $s_2$ have the same state \cite[p. 55]{Poetzsch-Heffter97specification}.
This is tested by  the predicate
@{text "xeq"}. Lemma 3.4 of  \cite{Poetzsch-Heffter97specification} is then proven for @{text "xeq"}.
*}

definition xeq:: "Value \<Rightarrow> Store \<Rightarrow> Store \<Rightarrow> bool" where
"xeq x s t = (alive x s = alive x t \<and>
             (\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = t@@l))"

abbreviation xeq_syntax :: "Store \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> bool"
  ("_/ (==[_])/ _" [900,0,900] 900)
where "s ==[x] t == xeq x s t"

notation (xsymbols) xeq_syntax  ("_/ (\<equiv>[_])/ _" [900,0,900] 900)

lemma xeqI: "\<lbrakk>alive x s = alive x t;
             \<And> l. s\<turnstile> l reachable_from x \<Longrightarrow> s@@l = t@@l
             \<rbrakk> \<Longrightarrow> s \<equiv>[x] t"
  by (auto simp add: xeq_def)

text {* Lemma 3.4 (i) in  \cite{Poetzsch-Heffter97specification}.  *}
lemma xeq1_refl: "s \<equiv>[x] s"
  by (simp add: xeq_def)

text {* Lemma 3.4 (i)  *}
lemma xeq1_sym':
  assumes s_t: "s \<equiv>[x] t"
  shows "t \<equiv>[x] s"
proof -
  from s_t have "alive x s = alive x t" by (simp add: xeq_def)
  moreover
  from s_t have "\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = t@@l"
    by (simp add: xeq_def)
  with reach9 [OF this]
  have "\<forall> l. t\<turnstile> l reachable_from x \<longrightarrow> t@@l = s@@l"
    by simp
  ultimately show ?thesis
    by (simp add: xeq_def)
qed

lemma xeq1_sym: "s \<equiv>[x] t = t \<equiv>[x] s"
  by (auto intro: xeq1_sym')

text {* Lemma 3.4 (i) *}
lemma xeq1_trans [trans]:
  assumes s_t: "s \<equiv>[x] t"
  assumes t_r: "t \<equiv>[x] r"
  shows "s \<equiv>[x] r"
proof -
  from s_t t_r
  have "alive x s = alive x r"
    by (simp add: xeq_def)
  moreover
  have "\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = r@@l"
  proof (intro allI impI)
    fix l
    assume reach_l: "s\<turnstile> l reachable_from x"
    show "s@@l = r@@l"
    proof -
      from reach_l s_t have "s@@l=t@@l"
        by (simp add: xeq_def)
      also have "t@@l = r@@l"
      proof -
        from s_t have "\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = t@@l"
          by (simp add: xeq_def)
        from reach9 [OF this] reach_l have "t\<turnstile> l reachable_from x"
          by simp
        with t_r show ?thesis
          by (simp add: xeq_def)
      qed
      finally show ?thesis .
    qed
  qed
  ultimately show ?thesis
    by (simp add: xeq_def)
qed

text {* Lemma 3.4 (ii) *}
lemma xeq2:
  assumes xeq: "\<forall> x. s \<equiv>[x] t"
  assumes static_eq: "\<forall> f. s@@(staticLoc f) = t@@(staticLoc f)"
  shows "s = t"
proof (rule Store_eqI)
  from xeq
  show "\<forall>x. alive x s = alive x t"
    by (simp add: xeq_def)
next
  show "\<forall>l. s@@l = t@@l"
  proof
    fix l
    show "s@@l = t@@l"
    proof (cases l)
      case (objLoc cf a)
      have "l = objLoc cf a" by fact
      hence "s\<turnstile> l reachable_from (objV (cls cf) a)"
        by simp
      with xeq show ?thesis
        by (simp add: xeq_def)
    next
      case (staticLoc f)
      have "l = staticLoc f" by fact
      with static_eq show ?thesis
        by (simp add: xeq_def)
    next
      case (arrLenLoc T a)
      have "l = arrLenLoc T a" by fact
      hence "s\<turnstile> l reachable_from (arrV T a)"
        by simp
      with xeq show ?thesis
        by (simp add: xeq_def)
    next
      case (arrLoc T a i)
      have "l = arrLoc T a i" by fact
      hence "s\<turnstile> l reachable_from (arrV T a)"
        by simp
      with xeq show ?thesis
        by (simp add: xeq_def)
    qed
  qed
qed

text {* Lemma 3.4 (iii) *}
lemma xeq3:
  assumes unreach_l: "\<not> s\<turnstile> l reachable_from x"
  shows "s \<equiv>[x] s\<langle>l:=y\<rangle>"
proof (rule xeqI)
  show "alive x s = alive x (s\<langle>l := y\<rangle>)"
    by simp
next
  fix k
  assume reach_k: "s\<turnstile> k reachable_from x"
  with unreach_l have "l\<noteq>k" by auto
  then show "s@@k = s\<langle>l := y\<rangle>@@k"
    by simp
qed

text {* Lemma 3.4 (iv) *}

text {* Lemma 3.4 (v) *}
lemma xeq5: "s \<equiv>[x] t \<Longrightarrow> s\<turnstile> l reachable_from x = t\<turnstile> l reachable_from x"
  by (rule reach9) (simp add:  xeq_def)

subsection {* T-Equivalence *}

text {* T-equivalence is the extension of X-equivalence from values to types. Two stores are
T-equivalent iff they are X-equivalent for all values of type T. This is formalized by the
predicate @{text "teq"} \cite[p. 55]{Poetzsch-Heffter97specification}. *}

definition teq:: "Javatype \<Rightarrow> Store \<Rightarrow> Store \<Rightarrow> bool" where
"teq t s1 s2 = (\<forall> x. typeof x \<le> t \<longrightarrow> s1 \<equiv>[x] s2)"

subsection {* Less Alive *}

text {* To specify that methods have no side-effects, the following binary relation on stores
plays a prominent role. It expresses that the two stores differ only in values that are alive
in the store passed as first argument. This is formalized by the predicate @{text "lessalive"}
\cite[p. 55]{Poetzsch-Heffter97specification}.
The stores have to be X-equivalent for the references of the
first store that are alive, and the values of the static fields have to be the same in both stores.
*}

definition lessalive:: "Store \<Rightarrow> Store \<Rightarrow> bool" ("_/ << _" [70,71] 70)
  where "lessalive s t = ((\<forall> x. alive x s \<longrightarrow> s \<equiv>[x] t) \<and> (\<forall> f. s@@staticLoc f = t@@staticLoc f))"

abbreviation (xsymbols)
  lessalive_syntax :: "Store \<Rightarrow> Store \<Rightarrow> bool" ("_/ \<lless> _" [70,71] 70)
  where "s \<lless> t == lessalive s t"

text {* We define an introduction rule for the new operator. *}

lemma lessaliveI:
  "\<lbrakk>\<And> x. alive x s \<Longrightarrow>  s \<equiv>[x] t; \<And> f. s@@staticLoc f = t@@staticLoc f\<rbrakk>
   \<Longrightarrow> s \<lless> t"
by (simp add: lessalive_def)

text {* It can be shown that @{text "lessalive"} is reflexive, transitive and antisymmetric. *}

lemma lessalive_refl: "s \<lless> s"
  by (simp add: lessalive_def xeq1_refl)

lemma lessalive_trans [trans]:
  assumes s_t: "s \<lless> t"
  assumes t_w: "t \<lless> w"
  shows "s \<lless> w"
proof (rule lessaliveI)
  fix x
  assume alive_x_s: "alive x s"
  with s_t have "s \<equiv>[x] t"
    by (simp add: lessalive_def)
  also
  have "t \<equiv>[x] w"
  proof -
    from alive_x_s s_t have "alive x t" by (simp add: lessalive_def xeq_def)
    with t_w show ?thesis
      by (simp add: lessalive_def)
  qed
  finally show "s \<equiv>[x] w".
next
  fix f
  from s_t t_w show "s@@staticLoc f = w@@staticLoc f"
    by (simp add: lessalive_def)
qed

lemma lessalive_antisym:
  assumes s_t: "s \<lless> t"
  assumes t_s: "t \<lless> s"
  shows "s = t"
proof (rule xeq2)
  show "\<forall>x. s \<equiv>[x] t"
  proof
    fix x show "s \<equiv>[x] t"
    proof (cases "alive x s")
      case True
      with s_t show ?thesis by (simp add: lessalive_def)
    next
      case False note unalive_x_s = this
      show ?thesis
      proof (cases "alive x t")
        case True
        with t_s show ?thesis
          by (subst xeq1_sym) (simp add: lessalive_def)
      next
        case False
        show ?thesis
        proof (rule xeqI)
          from False unalive_x_s show "alive x s = alive x t" by simp
        next
          fix l assume reach_s_x: "s\<turnstile> l reachable_from x"
          with unalive_x_s have x: "x = ref l"
            by (rule ref_reach_unalive)
          with unalive_x_s have "s@@l = init (ltype l)"
            by simp
          also from reach_s_x x have "t\<turnstile> l reachable_from x"
            by (auto intro: reach.Immediate unreachable_Null)
          with False x have "t@@l = init (ltype l)"
            by simp
          finally show "s@@l = t@@l"
            by simp
        qed
      qed
    qed
  qed
next
  from s_t show "\<forall>f. s@@staticLoc f = t@@staticLoc f"
    by (simp add: lessalive_def)
qed

text {* This gives us a partial ordering on the store. Thus, the type @{typ "Store"}
can be added to the appropriate type class @{term "ord"} which lets us define the $<$ and
$\leq$ symbols, and to the type class  @{term "order"} which axiomatizes partial orderings.
*}

instantiation Store :: order
begin

definition
  le_Store_def: "s \<le> t \<longleftrightarrow> s \<lless> t"

definition
  less_Store_def: "(s::Store) < t \<longleftrightarrow> s \<le> t \<and> \<not> t \<le> s"

text {* We prove Lemma 3.5 of \cite[p. 56]{Poetzsch-Heffter97specification} for this relation.
*}

text {* Lemma 3.5 (i) *}

instance  proof
  fix s t w:: "Store"
  {
    show "s \<le> s"
      by (simp add: le_Store_def lessalive_refl)
  next
    assume "s \<le> t" "t \<le> w"
    then show "s \<le> w"
      by (unfold le_Store_def) (rule lessalive_trans)
  next
    assume "s \<le> t" "t \<le> s"
    then show "s = t"
      by (unfold le_Store_def) (rule lessalive_antisym)
  next
    show "(s < t) = (s \<le> t \<and> \<not> t \<le> s)"
      by (simp add: less_Store_def)
  }
qed

end

text {* Lemma 3.5 (ii) *}
lemma lessalive2: "\<lbrakk>s \<lless> t; alive x s\<rbrakk> \<Longrightarrow> alive x t"
  by (simp add: lessalive_def xeq_def)

text {* Lemma 3.5 (iii) *}
lemma lessalive3:
  assumes s_t: "s \<lless> t"
  assumes alive: "alive x s \<or> \<not> alive x t"
  shows "s \<equiv>[x] t"
proof (cases "alive x s")
  case True
  with s_t show ?thesis
    by (simp add: lessalive_def)
next
  case False
  note unalive_x_s = this
  with alive have unalive_x_t: "\<not> alive x t"
    by simp
  show ?thesis
  proof (rule xeqI)
    from False alive show "alive x s = alive x t"
      by simp
  next
    fix l assume reach_s_x: "s\<turnstile> l reachable_from x"
    with unalive_x_s have x: "x = ref l"
      by (rule ref_reach_unalive)
    with unalive_x_s have "s@@l = init (ltype l)"
      by simp
    also from reach_s_x x have "t\<turnstile> l reachable_from x"
      by (auto intro: reach.Immediate unreachable_Null)
    with unalive_x_t x have "t@@l = init (ltype l)"
      by simp
    finally show "s@@l = t@@l"
      by simp
  qed
qed

text {* Lemma 3.5 (iv) *}
lemma lessalive_update [simp,intro]:
  assumes s_t: "s \<lless> t"
  assumes unalive_l: "\<not> alive (ref l) t"
  shows "s \<lless> t\<langle>l:=x\<rangle>"
proof -
  from unalive_l have "t\<langle>l:=x\<rangle> = t"
    by simp
  with s_t show ?thesis by simp
qed

lemma Xequ4':
  assumes alive: "alive x s"
  shows "s \<equiv>[x] s\<langle>t\<rangle>"
proof -
  from alive have "x \<noteq> new s t"
    by auto
  thus ?thesis
    by (rule xeq4)
qed

text {* Lemma 3.5 (v)  *}
lemma lessalive_alloc [simp,intro]: "s \<lless> s\<langle>t\<rangle>"
  by (simp add: lessalive_def Xequ4')

subsection {* Reachability of Types from Types *}

text {* The predicate @{text "treach"} denotes the fact that the first type reaches
the second type by stepping finitely many times from a type to the range type of one
of its fields. This formalization diverges from \cite[p. 106]{Poetzsch-Heffter97specification}
in that it does not include the number of steps that are allowed to reach the second type.
Reachability of types is a static approximation of reachability in
the store. If I cannot reach the type of a location from the type of a
reference, I cannot reach the location from the reference. See lemma
@{text "not_treach_ref_impl_not_reach"} below.
*}

inductive
  treach :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool"
where
  Subtype:       "U \<le> T \<Longrightarrow> treach T U"
| Attribute:     "\<lbrakk>treach T S; S \<le> dtype f; U \<le> rtype f\<rbrakk>  \<Longrightarrow> treach T U"
| ArrLength:     "treach (ArrT AT) IntgT"
| ArrElem:       "treach (ArrT AT) (at2jt AT)"
| Trans [trans]: "\<lbrakk>treach T U; treach U V\<rbrakk> \<Longrightarrow> treach T V"

lemma treach_ref_l [simp,intro]:
  assumes not_Null: "ref l \<noteq> nullV"
  shows "treach (typeof (ref l)) (ltype l)"
proof (cases l)
  case (objLoc cf a)
  have "l=objLoc cf a" by fact
  moreover
  have "treach (CClassT (cls cf)) (rtype (att cf))"
    by (rule treach.Attribute [where ?f="att cf" and ?S="CClassT (cls cf)"])
       (auto intro: treach.Subtype)
  ultimately show ?thesis
    by simp
next
  case (staticLoc f)
  have "l=staticLoc f" by fact
  hence "ref l = nullV" by simp
  with not_Null show ?thesis
    by simp
next
  case (arrLenLoc T a)
  have "l=arrLenLoc T a" by fact
  then show ?thesis
    by (auto intro: treach.ArrLength)
next
  case (arrLoc T a i)
  have "l=arrLoc T a i" by fact
  then show ?thesis
    by (auto intro: treach.ArrElem)
qed

lemma treach_ref_l' [simp,intro]:
  assumes not_Null: "ref l \<noteq> nullV"
  shows "treach (typeof (ref l)) (typeof (s@@l))"
proof -
  from not_Null have "treach (typeof (ref l)) (ltype l)" by (rule treach_ref_l)
  also have "typeof (s@@l) \<le> ltype l"
    by simp
  hence "treach (ltype l) (typeof (s@@l))"
    by (rule treach.intros)
  finally show ?thesis .
qed

lemma reach_impl_treach:
  assumes reach_l: "s \<turnstile> l reachable_from x"
  shows "treach (typeof x) (ltype l)"
using reach_l
proof (induct)
  case (Immediate l)
  have "ref l \<noteq> nullV" by fact
  then show "treach (typeof (ref l)) (ltype l)"
    by (rule treach_ref_l)
next
  case (Indirect l k)
  have "treach (typeof (s@@k)) (ltype l)" by fact
  moreover
  have "ref k \<noteq> nullV" by fact
  hence "treach (typeof (ref k)) (typeof (s@@k))"
    by simp
  ultimately show "treach (typeof (ref k)) (ltype l)"
    by (iprover intro: treach.Trans)
qed

lemma not_treach_ref_impl_not_reach:
  assumes not_treach: "\<not> treach (typeof x) (typeof (ref l))"
  shows "\<not> s \<turnstile> l reachable_from x"
proof
  assume reach_l: "s\<turnstile> l reachable_from x"
  from this not_treach
  show False
  proof (induct)
    case (Immediate l)
    have "\<not> treach (typeof (ref l)) (typeof (ref l))" by fact
    thus False by (iprover intro: treach.intros order_refl)
  next
    case (Indirect l k)
    have hyp: "\<not> treach (typeof (s@@k)) (typeof (ref l)) \<Longrightarrow> False" by fact
    have not_Null: "ref k \<noteq> nullV" by fact
    have not_k_l:"\<not> treach (typeof (ref k)) (typeof (ref l))" by fact
    show False
    proof (cases "treach (typeof (s@@k)) (typeof (ref l))")
      case False thus False by (rule hyp)
    next
      case True
      from not_Null have "treach (typeof (ref k)) (typeof (s@@k))"
        by (rule treach_ref_l')
      also note True
      finally have "treach (typeof (ref k)) (typeof (ref l))" .
      with not_k_l show False ..
    qed
  qed
qed

text {* Lemma 4.6 in \cite[p. 107]{Poetzsch-Heffter97specification}.  *}
lemma treach1:
  assumes x_t: "typeof x \<le> T"
  assumes not_treach: "\<not> treach T (typeof (ref l))"
  shows "\<not> s \<turnstile> l reachable_from x"
proof -
  have "\<not> treach (typeof x) (typeof (ref l))"
  proof
    from x_t have "treach T (typeof x)" by (rule treach.intros)
    also assume "treach (typeof x) (typeof (ref l))"
    finally have "treach T (typeof (ref l))" .
    with not_treach show False ..
  qed
  thus ?thesis
    by (rule not_treach_ref_impl_not_reach)
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_35
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun dropWhile :: "('a => bool) => 'a list => 'a list" where
"dropWhile x (nil2) = nil2"
| "dropWhile x (cons2 z xs) =
     (if x z then dropWhile x xs else cons2 z xs)"

theorem property0 :
  "((dropWhile (% (x :: 'a) => False) xs) = xs)"
  oops

end


(*  Title:       POSIX Lexing with Derivatives of Regular Expressions
    Authors:     Fahad Ausaf <fahad.ausaf at icloud.com>, 2016
                 Roy Dyckhoff <roy.dyckhoff at st-andrews.ac.uk>, 2016
                 Christian Urban <christian.urban at kcl.ac.uk>, 2016
    Maintainer:  Christian Urban <christian.urban at kcl.ac.uk>
*)

theory Simplifying
  imports Lexer
begin

section \<open>Lexer including simplifications\<close>

fun F_RIGHT where
  "F_RIGHT f v = Right (f v)"

fun F_LEFT where
  "F_LEFT f v = Left (f v)"

fun F_Plus where
  "F_Plus f\<^sub>1 f\<^sub>2 (Right v) = Right (f\<^sub>2 v)"
| "F_Plus f\<^sub>1 f\<^sub>2 (Left v) = Left (f\<^sub>1 v)"
| "F_Plus f1 f2 v = v"

fun F_Times1 where
  "F_Times1 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 Void) (f\<^sub>2 v)"

fun F_Times2 where
  "F_Times2 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 v) (f\<^sub>2 Void)"

fun F_Times where
  "F_Times f\<^sub>1 f\<^sub>2 (Seq v\<^sub>1 v\<^sub>2) = Seq (f\<^sub>1 v\<^sub>1) (f\<^sub>2 v\<^sub>2)"
| "F_Times f1 f2 v = v"

fun simp_Plus where
  "simp_Plus (Zero, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_RIGHT f\<^sub>2)"
| "simp_Plus (r\<^sub>1, f\<^sub>1) (Zero, f\<^sub>2) = (r\<^sub>1, F_LEFT f\<^sub>1)"
| "simp_Plus (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) =
  (if r\<^sub>1 = r\<^sub>2 then (r\<^sub>1, F_LEFT f\<^sub>1) else (Plus r\<^sub>1 r\<^sub>2, F_Plus f\<^sub>1 f\<^sub>2))"

fun simp_Times where
  "simp_Times (Zero, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (Zero, undefined)"
| "simp_Times (r\<^sub>1, f\<^sub>1) (Zero, f\<^sub>2) = (Zero, undefined)"
| "simp_Times (One, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_Times1 f\<^sub>1 f\<^sub>2)"
| "simp_Times (r\<^sub>1, f\<^sub>1) (One, f\<^sub>2) = (r\<^sub>1, F_Times2 f\<^sub>1 f\<^sub>2)"
| "simp_Times (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (Times r\<^sub>1 r\<^sub>2, F_Times f\<^sub>1 f\<^sub>2)"

lemma simp_Times_simps[simp]:
  "simp_Times p1 p2 = (if (fst p1 = Zero) then (Zero, undefined)
                    else (if (fst p2 = Zero) then (Zero, undefined)
                    else (if (fst p1 = One) then (fst p2, F_Times1 (snd p1) (snd p2))
                    else (if (fst p2 = One) then (fst p1, F_Times2 (snd p1) (snd p2))
                    else (Times (fst p1) (fst p2), F_Times (snd p1) (snd p2))))))"
 by (induct p1 p2 rule: simp_Times.induct)(auto)

lemma simp_Plus_simps[simp]:
  "simp_Plus p1 p2 = (if (fst p1 = Zero) then (fst p2, F_RIGHT (snd p2))
                    else (if (fst p2 = Zero) then (fst p1, F_LEFT (snd p1))
                    else (if (fst p1 = fst p2) then (fst p1, F_LEFT (snd p1))
                    else (Plus (fst p1) (fst p2), F_Plus (snd p1) (snd p2)))))"
by (induct p1 p2 rule: simp_Plus.induct) (auto)

fun
  simp :: "'a rexp \<Rightarrow> 'a rexp * ('a val \<Rightarrow> 'a val)"
where
  "simp (Plus r1 r2) = simp_Plus (simp r1) (simp r2)"
| "simp (Times r1 r2) = simp_Times (simp r1) (simp r2)"
| "simp r = (r, id)"

fun
  slexer :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> ('a val) option"
where
  "slexer r [] = (if nullable r then Some(mkeps r) else None)"
| "slexer r (c#s) = (let (rs, fr) = simp (deriv c r) in
                         (case (slexer rs s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c (fr v))))"

lemma slexer_better_simp:
  "slexer r (c#s) = (case (slexer (fst (simp (deriv c r))) s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c ((snd (simp (deriv c r))) v)))"
by (auto split: prod.split option.split)

lemma L_fst_simp:
  shows "lang r = lang (fst (simp r))"
by (induct r) (auto)

lemma Posix_simp:
  assumes "s \<in> (fst (simp r)) \<rightarrow> v"
  shows "s \<in> r \<rightarrow> ((snd (simp r)) v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case (Plus r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (Plus r1 r2)) \<rightarrow> v" by fact
  consider (Zero_Zero) "fst (simp r1) = Zero" "fst (simp r2) = Zero"
         | (Zero_NZero) "fst (simp r1) = Zero" "fst (simp r2) \<noteq> Zero"
         | (NZero_Zero) "fst (simp r1) \<noteq> Zero" "fst (simp r2) = Zero"
         | (NZero_NZero1) "fst (simp r1) \<noteq> Zero" "fst (simp r2) \<noteq> Zero" "fst (simp r1) = fst (simp r2)"
         | (NZero_NZero2) "fst (simp r1) \<noteq> Zero" "fst (simp r2) \<noteq> Zero" "fst (simp r1) \<noteq> fst (simp r2)" by auto
  then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v"
    proof(cases)
      case (Zero_Zero)
      with as have "s \<in> Zero \<rightarrow> v" by simp
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" by (rule Posix_elims(1))
    next
      case (Zero_NZero)
      with as have "s \<in> fst (simp r2) \<rightarrow> v" by simp
      with IH2 have "s \<in> r2 \<rightarrow> snd (simp r2) v" by simp
      moreover
      from Zero_NZero have "fst (simp r1) = Zero" by simp
      then have "lang (fst (simp r1)) = {}" by simp
      then have "lang r1 = {}" using L_fst_simp by auto
      then have "s \<notin> lang r1" by simp
      ultimately have "s \<in> Plus r1 r2 \<rightarrow> Right (snd (simp r2) v)" by (rule Posix_Plus2)
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v"
      using Zero_NZero by simp
    next
      case (NZero_Zero)
      with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
      with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      then have "s \<in> Plus r1 r2 \<rightarrow> Left (snd (simp r1) v)" by (rule Posix_Plus1)
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" using NZero_Zero by simp
    next
      case (NZero_NZero1)
      with as have a: "s \<in> fst (simp r1) \<rightarrow> v" by simp
        then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v"
        using IH1 NZero_NZero1 Posix_Plus1 a by fastforce
    next
      case (NZero_NZero2)
      with as have "s \<in> Plus (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then consider (Left) v1 where "v = Left v1" "s \<in> (fst (simp r1)) \<rightarrow> v1"
                  | (Right) v2 where "v = Right v2" "s \<in> (fst (simp r2)) \<rightarrow> v2" "s \<notin> lang (fst (simp r1))"
                  by (erule_tac Posix_elims(4))
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v"
      proof(cases)
        case (Left)
        then have "v = Left v1" "s \<in> r1 \<rightarrow> (snd (simp r1) v1)" using IH1 by simp_all
        then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" using NZero_NZero2
          by (simp_all add: Posix_Plus1)
      next
        case (Right)
        then have "v = Right v2" "s \<in> r2 \<rightarrow> (snd (simp r2) v2)" "s \<notin> lang r1" using IH2 L_fst_simp by auto
        then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" using NZero_NZero2
          by (simp_all add: Posix_Plus2)
      qed
    qed
next
  case (Times r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (Times r1 r2)) \<rightarrow> v" by fact
  consider (Zero)  "fst (simp r1) = Zero \<or> fst (simp r2) = Zero"
         | (One_One) "fst (simp r1) = One" "fst (simp r2) = One"
         | (One_NOne) "fst (simp r1) = One" "fst (simp r2) \<noteq> One" "fst (simp r2) \<noteq> Zero"
         | (NOne_One) "fst (simp r1) \<noteq> One" "fst (simp r2) = One" "fst (simp r1) \<noteq> Zero"
         | (NOne_NOne) "fst (simp r1) \<noteq> One" "fst (simp r2) \<noteq> One"
                       "fst (simp r1) \<noteq> Zero" "fst (simp r2) \<noteq> Zero" by auto
  then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v"
  proof(cases)
    case (Zero)
    with as have "False"
      by (metis Posix_elims(1) fst_conv simp.simps(2) simp_Times_simps)
    then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" by simp
  next
    case (One_One)
      with as have b: "s \<in> One \<rightarrow> v" by simp
      from b have "s \<in> r1 \<rightarrow> snd (simp r1) v" using IH1 One_One by simp
      moreover
      from b have c: "s = []" "v = Void" using Posix_elims(2) by auto
      moreover
      have "[] \<in> One \<rightarrow> Void" by (simp add: Posix_One)
      then have "[] \<in> fst (simp r2) \<rightarrow> Void" using One_One by simp
      then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "([] @ []) \<in> Times r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) Void)"
        using Posix_Times by blast
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using c One_One by simp
    next
      case (One_NOne)
      with as have b: "s \<in> fst (simp r2) \<rightarrow> v" by simp
      from b have "s \<in> r2 \<rightarrow> snd (simp r2) v" using IH2 One_NOne by simp
      moreover
      have "[] \<in> One \<rightarrow> Void" by (simp add: Posix_One)
      then have "[] \<in> fst (simp r1) \<rightarrow> Void" using One_NOne by simp
      then have "[] \<in> r1 \<rightarrow> snd (simp r1) Void" using IH1 by simp
      moreover
      from One_NOne(1) have "lang (fst (simp r1)) = {[]}" by simp
      then have "lang r1 = {[]}" by (simp add: L_fst_simp[symmetric])
      ultimately have "([] @ s) \<in> Times r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) v)"
        by(rule_tac Posix_Times) auto
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using One_NOne by simp
    next
      case (NOne_One)
        with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
        with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      moreover
        have "[] \<in> One \<rightarrow> Void" by (simp add: Posix_One)
        then have "[] \<in> fst (simp r2) \<rightarrow> Void" using NOne_One by simp
        then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "(s @ []) \<in> Times r1 r2 \<rightarrow> Seq (snd (simp r1) v) (snd (simp r2) Void)"
        by(rule_tac Posix_Times) auto
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using NOne_One by simp
    next
      case (NOne_NOne)
      with as have "s \<in> Times (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then obtain s1 s2 v1 v2 where eqs: "s = s1 @ s2" "v = Seq v1 v2"
                     "s1 \<in> (fst (simp r1)) \<rightarrow> v1" "s2 \<in> (fst (simp r2)) \<rightarrow> v2"
                     "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
                     by (erule_tac Posix_elims(5)) (auto simp add: L_fst_simp[symmetric])
      then have "s1 \<in> r1 \<rightarrow> (snd (simp r1) v1)" "s2 \<in> r2 \<rightarrow> (snd (simp r2) v2)"
        using IH1 IH2 by auto
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using eqs NOne_NOne
        by(auto intro: Posix_Times)
    qed
qed (simp_all)

lemma slexer_correctness:
  shows "slexer r s = lexer r s"
proof(induct s arbitrary: r)
  case Nil
  show "slexer r [] = lexer r []" by simp
next
  case (Cons c s r)
  have IH: "\<And>r. slexer r s = lexer r s" by fact
  show "slexer r (c # s) = lexer r (c # s)"
   proof (cases "s \<in> lang (deriv c r)")
     case True
       assume a1: "s \<in> lang (deriv c r)"
       then obtain v1 where a2: "lexer (deriv c r) s = Some v1" "s \<in> deriv c r \<rightarrow> v1"
         using lexer_correct_Some by auto
       from a1 have "s \<in> lang (fst (simp (deriv c r)))" using L_fst_simp[symmetric] by auto
       then obtain v2 where a3: "lexer (fst (simp (deriv c r))) s = Some v2" "s \<in> (fst (simp (deriv c r))) \<rightarrow> v2"
          using lexer_correct_Some by auto
       then have a4: "slexer (fst (simp (deriv c r))) s = Some v2" using IH by simp
       from a3(2) have "s \<in> deriv c r \<rightarrow> (snd (simp (deriv c r))) v2" using Posix_simp by auto
       with a2(2) have "v1 = (snd (simp (deriv c r))) v2" using Posix_determ by auto
       with a2(1) a4 show "slexer r (c # s) = lexer r (c # s)" by (auto split: prod.split)
     next
     case False
       assume b1: "s \<notin> lang (deriv c r)"
       then have "lexer (deriv c r) s = None" using lexer_correct_None by auto
       moreover
       from b1 have "s \<notin> lang (fst (simp (deriv c r)))" using L_fst_simp[symmetric] by auto
       then have "lexer (fst (simp (deriv c r))) s = None" using lexer_correct_None by auto
       then have "slexer (fst (simp (deriv c r))) s = None" using IH by simp
       ultimately show "slexer r (c # s) = lexer r (c # s)"
         by (simp del: slexer.simps add: slexer_better_simp)
   qed
qed

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory WHATWHERE_Secure_Skip_Assign
imports Parallel_Composition
begin

context WHATWHERE_Secure_Programs
begin

abbreviation NextMem'
("\<lbrakk>_\<rbrakk>'(_')")
where
"\<lbrakk>c\<rbrakk>(m) \<equiv> NextMem c m"

-- "define when two expressions are indistinguishable with respect to a domain d"
definition d_indistinguishable :: "'d::order \<Rightarrow> 'exp \<Rightarrow> 'exp \<Rightarrow> bool"
where
"d_indistinguishable d e1 e2 \<equiv> \<forall>m m'. ((m =\<^bsub>d\<^esub> m')
  \<longrightarrow> ((E e1 m) = (E e2 m')))"

abbreviation d_indistinguishable' :: "'exp \<Rightarrow> 'd::order \<Rightarrow> 'exp \<Rightarrow> bool"
( "(_ \<equiv>\<^bsub>_\<^esub> _)" )
where
"e1 \<equiv>\<^bsub>d\<^esub> e2 \<equiv> d_indistinguishable d e1 e2"

-- "symmetry of d-indistinguishable"
lemma d_indistinguishable_sym:
"e \<equiv>\<^bsub>d\<^esub> e' \<Longrightarrow> e' \<equiv>\<^bsub>d\<^esub> e"
by (simp add: d_indistinguishable_def d_equal_def, metis)

--"transitivity of d-indistinguishable"
lemma d_indistinguishable_trans:
"\<lbrakk> e \<equiv>\<^bsub>d\<^esub> e'; e' \<equiv>\<^bsub>d\<^esub> e'' \<rbrakk> \<Longrightarrow> e \<equiv>\<^bsub>d\<^esub> e''"
by (simp add: d_indistinguishable_def d_equal_def, metis)

--"predicate for dH-indistinguishable"
definition dH_indistinguishable :: "'d \<Rightarrow> ('d, 'exp) Hatches
  \<Rightarrow> 'exp \<Rightarrow> 'exp \<Rightarrow> bool"
where
"dH_indistinguishable d H e1 e2 \<equiv> (\<forall>m m'. m \<sim>\<^bsub>d,H\<^esub> m'
  \<longrightarrow> (E e1 m = E e2 m'))"

abbreviation dH_indistinguishable' :: "'exp \<Rightarrow> 'd
  \<Rightarrow> ('d, 'exp) Hatches \<Rightarrow> 'exp \<Rightarrow> bool"
( "(_ \<equiv>\<^bsub>_,_\<^esub> _)" )
where
"e1 \<equiv>\<^bsub>d,H\<^esub> e2 \<equiv> dH_indistinguishable d H e1 e2"

lemma empH_implies_dHindistinguishable_eq_dindistinguishable:
"(e \<equiv>\<^bsub>d,{}\<^esub> e') = (e \<equiv>\<^bsub>d\<^esub> e')"
by (simp add: d_indistinguishable_def dH_indistinguishable_def
  dH_equal_def d_equal_def)

theorem WHATWHERE_Secure_Skip:
"WHATWHERE_Secure [skip\<^bsub>\<iota>\<^esub>]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP
  def R \<equiv> "{(V::('exp,'id) MWLsCom list,V'::('exp,'id) MWLsCom list).
    V = V' \<and> (V = [] \<or> V = [skip\<^bsub>\<iota>\<^esub>])}"

  have inR: "([skip\<^bsub>\<iota>\<^esub>],[skip\<^bsub>\<iota>\<^esub>]) \<in> R"
    by (simp add: R_def)

  have "SdlHPPB d PP R"
    proof (simp add: Strong_dlHPP_Bisimulation_def R_def sym_def trans_def
      NDC_def NextMem_def, auto)
      fix m1 m1'
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"
      have nextm1: "(THE m2. (\<exists>p \<alpha>. \<langle>skip\<^bsub>\<iota>\<^esub>,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>)) = m1"
        by (insert MWLsSteps_det.simps[of "skip\<^bsub>\<iota>\<^esub>" "m1"],
          force)

      have nextm1':
        "(THE m2'. (\<exists>p \<alpha>. \<langle>skip\<^bsub>\<iota>\<^esub>,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2'\<rangle>)) = m1'"
        by (insert MWLsSteps_det.simps[of "skip\<^bsub>\<iota>\<^esub>" "m1'"],
          force)

      with dequal nextm1 show
        "THE m2. \<exists>p \<alpha>. \<langle>skip\<^bsub>\<iota>\<^esub>,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle> =\<^bsub>d\<^esub>
        THE m2'. \<exists>p \<alpha>. \<langle>skip\<^bsub>\<iota>\<^esub>,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2'\<rangle>"
        by auto
     next
       fix p m1 m1' m2 \<alpha>
       assume dequal: "m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1'"
       assume skipstep: "\<langle>skip\<^bsub>\<iota>\<^esub>,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
       with  MWLsSteps_det.simps[of "skip\<^bsub>\<iota>\<^esub>" "m1" "\<alpha>" "p" "m2"]
       have aux: "p = None \<and> m2 = m1 \<and> \<alpha> = []"
         by auto
       with dequal skipstep MWLsSteps_det.skip
       show "\<exists>p' m2'.
         \<langle>skip\<^bsub>\<iota>\<^esub>,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p',m2'\<rangle> \<and>
         stepResultsinR p p' {(V, V'). V = V' \<and>
         (V = [] \<or> V = [skip\<^bsub>\<iota>\<^esub>])} \<and>
         (\<alpha> = [] \<or> \<alpha> = [skip\<^bsub>\<iota>\<^esub>]) \<and>
         dhequality_alternative d PP \<iota> m2 m2'"
         by (simp add: stepResultsinR_def dhequality_alternative_def,
           fastforce)
     qed

     with inR show "\<exists>R. SdlHPPB d PP R \<and> ([skip\<^bsub>\<iota>\<^esub>],[skip\<^bsub>\<iota>\<^esub>]) \<in> R"
       by auto
qed

--"auxiliary lemma for assign side condition (lemma 9 in original paper)"
lemma semAssignSC_aux:
  assumes dhind: "e \<equiv>\<^bsub>DA x,(htchLoc \<iota>)\<^esub> e"
  shows "NDC d (x :=\<^bsub>\<iota>\<^esub> e) \<or> IDC d (x :=\<^bsub>\<iota>\<^esub> e) (htchLoc (pp (x:=\<^bsub>\<iota>\<^esub> e)))"
proof (simp add: IDC_def, auto, simp add: NDC_def)
  fix m1 m1'
  assume dhequal: "m1 \<sim>\<^bsub>d,htchLoc \<iota>\<^esub> m1'"
  hence dequal: "m1 =\<^bsub>d\<^esub> m1'"
    by (simp add: dH_equal_def)

  obtain v where veq: "E e m1 = v" by auto
  hence m2eq: "\<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) = m1(x := v)"
    by (simp add: NextMem_def,
      insert MWLsSteps_det.simps[of "x :=\<^bsub>\<iota>\<^esub> e" "m1"],
      force)

  obtain v' where v'eq: "E e m1' = v'" by auto
  hence m2'eq: "\<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1') = m1'(x := v')"
    by (simp add: NextMem_def,
      insert MWLsSteps_det.simps[of "x :=\<^bsub>\<iota>\<^esub> e" "m1'"],
      force)

  from dhequal have shiftdomain:
    "DA x \<le> d \<Longrightarrow> m1 \<sim>\<^bsub>DA x,(htchLoc \<iota>)\<^esub> m1'"
    by (simp add: dH_equal_def d_equal_def htchLoc_def)

  with veq v'eq dhind
  have "(DA x) \<le> d \<Longrightarrow> v = v'"
    by (simp add: dH_indistinguishable_def)

  with dequal m2eq m2'eq
  show "\<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) =\<^bsub>d\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1')"
    by (simp add: d_equal_def)
qed

theorem WHATWHERE_Secure_Assign:
  assumes dhind: "e \<equiv>\<^bsub>DA x,(htchLoc \<iota>)\<^esub> e"
  assumes dheq_imp: "\<forall>m m' d \<iota>'. (m \<sim>\<^bsub>d,(htchLoc \<iota>')\<^esub> m' \<and>
  \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m'))
  \<longrightarrow> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m) \<sim>\<^bsub>d,(htchLoc \<iota>')\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m')"
  shows "WHATWHERE_Secure [x :=\<^bsub>\<iota>\<^esub> e]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP
  def R \<equiv> "{(V::('exp,'id) MWLsCom list,V'::('exp,'id) MWLsCom list).
    V = V' \<and> (V = [] \<or> V = [x :=\<^bsub>\<iota>\<^esub> e])}"

  have inR: "([x :=\<^bsub>\<iota>\<^esub> e],[x :=\<^bsub>\<iota>\<^esub> e]) \<in> R"
    by (simp add: R_def)

  have "SdlHPPB d PP R"
    proof (simp add: Strong_dlHPP_Bisimulation_def R_def
        sym_def trans_def, auto)
      assume notIDC: "\<not> IDC d (x :=\<^bsub>\<iota>\<^esub> e) (htchLoc \<iota>)"
      with dhind semAssignSC_aux
      show "NDC d (x :=\<^bsub>\<iota>\<^esub> e)"
        by force
    next
      fix m1 m1' m2 p \<alpha>
      assume assignstep: "\<langle>x :=\<^bsub>\<iota>\<^esub> e,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
      assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

      from assignstep have nextm1:
        "p = None \<and> \<alpha> = [] \<and> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) = m2"
        by (simp add: NextMem_def,
          insert MWLsSteps_det.simps[of "x :=\<^bsub>\<iota>\<^esub> e" "m1"], force)

      obtain m2' where nextm1':
        "\<langle>x :=\<^bsub>\<iota>\<^esub> e,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>None,m2'\<rangle> \<and> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1') = m2'"
        by (simp add: NextMem_def,
          insert MWLsSteps_det.simps[of "x :=\<^bsub>\<iota>\<^esub> e" "m1'"], force)

      from dhequal have dhequal_\<iota>: "\<And>\<iota>. htchLoc \<iota> \<subseteq> htchLocSet PP
        \<Longrightarrow> m1 \<sim>\<^bsub>d,(htchLoc \<iota>)\<^esub> m1'"
        by (simp add: dH_equal_def, auto)

      with dhind semAssignSC_aux
      have "htchLoc \<iota> \<subseteq> htchLocSet PP \<Longrightarrow>
        \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) =\<^bsub>d\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1')"
        by (simp add: NDC_def IDC_def dH_equal_def, fastforce)

      with dhind dheq_imp dhequal_\<iota>
      have "htchLoc \<iota> \<subseteq> htchLocSet PP \<Longrightarrow>
        \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1')"
        by (simp add: htchLocSet_def dH_equal_def, blast)

      with nextm1 nextm1' assignstep dhequal
      show "\<exists>p' m2'.
        \<langle>x :=\<^bsub>\<iota>\<^esub> e,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' {(V, V'). V = V' \<and> (V = [] \<or> V = [x:=\<^bsub>\<iota>\<^esub> e])} \<and>
        (\<alpha> = [] \<or> \<alpha> = [x:=\<^bsub>\<iota>\<^esub> e]) \<and> dhequality_alternative d PP \<iota> m2 m2'"
        by (auto simp add: stepResultsinR_def dhequality_alternative_def)
    qed

  with inR show "\<exists>R. SdlHPPB d PP R \<and> ([x:=\<^bsub>\<iota>\<^esub> e],[x:=\<^bsub>\<iota>\<^esub> e]) \<in> R"
    by auto
qed

end

end