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

section \<open>Store Properties\<close>

theory StoreProperties
imports Store
begin

text \<open>This theory formalizes advanced concepts and properties of stores.\<close>

subsection \<open>Reachability of a Location from a Reference\<close>

text \<open>For a given store, the function \<open>reachS\<close> 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 \<open>reach\<close> decides whether a location is reachable from a value in a store.
\<close>

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 \<open>Note that we explicitly exclude \<open>nullV\<close> as legal reference
for reachability.
Keep in mind that static fields are not associated to any object,
therefore \<open>ref\<close> yields \<open>nullV\<close> if invoked on static fields
(see the
definition of the function \<open>ref\<close>, 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 \<open>nullV\<close> reference in the pointer
chain.\<close>

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

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 \<open>Lemma 3.2 (i)\<close>
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 \<open>Lemma 3.2 (ii)\<close>
lemma reach2:
  "\<not> s\<turnstile> l reachable_from x \<Longrightarrow> \<not> s\<langle>l:=y\<rangle>\<turnstile> l reachable_from x"
  by (simp)

text \<open>Lemma 3.2 (iv)\<close>
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 \<open>Lemma 3.2 (v)\<close>
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 \<open>Lemma 3.2 (vi)\<close>
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 \<open>Lemma 3.2 (iii)\<close>
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 \<open>Lemma 3.2 (vii).\<close>

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 \<open>Lemma 3.2 (viii)\<close>
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 \<open>Lemma 3.2 (ix)\<close>
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 \<open>Reachability of a Reference from a Reference\<close>

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

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

subsection \<open>Disjointness of Reachable Locations\<close>

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

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 \<open>Lemma 3.3 (i) in \cite{Poetzsch-Heffter97specification}\<close>
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 \<open>Lemma 3.3 (ii)\<close>
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 \<open>Lemma 3.3 (iii)\<close>
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 \<open>Lemma 3.3 (iv)\<close>
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 \<open>X-Equivalence\<close>

text \<open>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
\<open>xeq\<close>. Lemma 3.4 of  \cite{Poetzsch-Heffter97specification} is then proven for \<open>xeq\<close>.
\<close>

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"
  ("_/ (\<equiv>[_])/ _" [900,0,900] 900)
where "s \<equiv>[x] t == xeq x s t"

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 \<open>Lemma 3.4 (i) in  \cite{Poetzsch-Heffter97specification}.\<close>
lemma xeq1_refl: "s \<equiv>[x] s"
  by (simp add: xeq_def)

text \<open>Lemma 3.4 (i)\<close>
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 \<open>Lemma 3.4 (i)\<close>
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 \<open>Lemma 3.4 (ii)\<close>
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 \<open>Lemma 3.4 (iii)\<close>
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 \<open>Lemma 3.4 (iv)\<close>

text \<open>Lemma 3.4 (v)\<close>
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 \<open>T-Equivalence\<close>

text \<open>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 \<open>teq\<close> \cite[p. 55]{Poetzsch-Heffter97specification}.\<close>

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 \<open>Less Alive\<close>

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

definition lessalive:: "Store \<Rightarrow> Store \<Rightarrow> bool" ("_/ \<lless> _" [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))"

text \<open>We define an introduction rule for the new operator.\<close>

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 \<open>It can be shown that \<open>lessalive\<close> is reflexive, transitive and antisymmetric.\<close>

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

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 \<open>We prove Lemma 3.5 of \cite[p. 56]{Poetzsch-Heffter97specification} for this relation.
\<close>

text \<open>Lemma 3.5 (i)\<close>

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 \<open>Lemma 3.5 (ii)\<close>
lemma lessalive2: "\<lbrakk>s \<lless> t; alive x s\<rbrakk> \<Longrightarrow> alive x t"
  by (simp add: lessalive_def xeq_def)

text \<open>Lemma 3.5 (iii)\<close>
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 \<open>Lemma 3.5 (iv)\<close>
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 \<open>Lemma 3.5 (v)\<close>
lemma lessalive_alloc [simp,intro]: "s \<lless> s\<langle>t\<rangle>"
  by (simp add: lessalive_def Xequ4')

subsection \<open>Reachability of Types from Types\<close>

text \<open>The predicate \<open>treach\<close> 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
\<open>not_treach_ref_impl_not_reach\<close> below.
\<close>

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 \<open>Lemma 4.6 in \cite[p. 107]{Poetzsch-Heffter97specification}.\<close>
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


section\<open>Storage\<close>

theory Storage
imports Valuetypes "HOL-Library.Finite_Map"

begin

(*Covered*)
fun hash :: "Location \<Rightarrow> String.literal \<Rightarrow> Location"
where "hash loc ix = ix + (STR ''.'' + loc)"

subsection \<open>General Store\<close>

(*Covered*)
record 'v Store =
  mapping :: "(Location,'v) fmap"
  toploc :: nat

fun accessStore :: "Location \<Rightarrow> 'v Store \<Rightarrow> 'v option"
where "accessStore loc st = fmlookup (mapping st) loc"

definition emptyStore :: "'v Store"
where "emptyStore = \<lparr> mapping=fmempty, toploc=0 \<rparr>"

declare emptyStore_def [solidity_symbex]

fun allocate :: "'v Store \<Rightarrow> Location * ('v Store)"
where "allocate s = (let ntop = Suc(toploc s) in (ShowL\<^sub>n\<^sub>a\<^sub>t ntop, s \<lparr>toploc := ntop\<rparr>))"

fun updateStore :: "Location \<Rightarrow> 'v \<Rightarrow> 'v Store \<Rightarrow> 'v Store"
where "updateStore loc val s = s \<lparr> mapping := fmupd loc val (mapping s)\<rparr>"

fun push :: "'v \<Rightarrow> 'v Store \<Rightarrow> 'v Store"
  where "push val sto = (let s = updateStore (ShowL\<^sub>n\<^sub>a\<^sub>t (toploc sto)) val sto in snd (allocate s))"

subsection \<open>Stack\<close>
(*Covered*)
datatype Stackvalue = KValue Valuetype
                    | KCDptr Location
                    | KMemptr Location
                    | KStoptr Location

(*Covered*)
type_synonym Stack = "Stackvalue Store"

subsection \<open>Storage\<close>

subsubsection \<open>Definition\<close>

type_synonym Storagevalue = Valuetype

(*Covered*)
type_synonym StorageT = "(Location,Storagevalue) fmap"

(*Covered*)
datatype STypes = STArray int STypes
                | STMap Types STypes
                | STValue Types

subsubsection \<open>Example\<close>

abbreviation mystorage::StorageT
where "mystorage \<equiv> (fmap_of_list
  [(STR ''0.0.1'', STR ''True''),
   (STR ''1.0.1'', STR ''False''),
   (STR ''0.1.1'', STR ''True''),
   (STR ''1.1.1'', STR ''False'')])"

subsubsection \<open>Access storage\<close>

(*Covered*)
fun accessStorage :: "Types \<Rightarrow> Location \<Rightarrow> StorageT \<Rightarrow> Storagevalue"
where
  "accessStorage t loc sto =
    (case fmlookup sto loc of
      Some v \<Rightarrow> v
    | None \<Rightarrow> ival t)"

subsubsection \<open>Copy from storage to storage\<close>

fun copyRec :: "Location \<Rightarrow> Location \<Rightarrow> STypes \<Rightarrow> StorageT \<Rightarrow> StorageT option"
where
  "copyRec loc loc' (STArray x t) sto =
    iter' (\<lambda>i s'. copyRec (hash loc (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash loc' (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t s') sto x"
| "copyRec loc loc' (STValue t) sto =
    (let e = accessStorage t loc sto in Some (fmupd loc' e sto))"
| "copyRec _ _ (STMap _ _) _ = None"

fun copy :: "Location \<Rightarrow> Location \<Rightarrow> int \<Rightarrow> STypes \<Rightarrow> StorageT \<Rightarrow> StorageT option"
where
  "copy loc loc' x t sto =
    iter' (\<lambda>i s'. copyRec (hash loc (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash loc' (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t s') sto x"

subsection \<open>Memory and Calldata\<close>

subsubsection \<open>Definition\<close>

(*Covered*)
datatype Memoryvalue =
  MValue Valuetype
  | MPointer Location
(*Covered*)
type_synonym MemoryT = "Memoryvalue Store"
(*Covered*)
type_synonym CalldataT = MemoryT
(*Covered*)
datatype MTypes = MTArray int MTypes
  | MTValue Types

subsubsection \<open>Example\<close>

abbreviation mymemory::MemoryT
  where "mymemory \<equiv>
    \<lparr>mapping = fmap_of_list
      [(STR ''1.1.0'', MValue STR ''False''),
       (STR ''0.1.0'', MValue STR ''True''),
       (STR ''1.0'', MPointer STR ''1.0''),
       (STR ''1.0.0'', MValue STR ''False''),
       (STR ''0.0.0'', MValue STR ''True''),
       (STR ''0.0'', MPointer STR ''0.0'')],
     toploc = 1\<rparr>"

subsubsection \<open>Initialization\<close>

subsubsection \<open>Definition\<close>

(*Covered*)
fun minitRec :: "Location \<Rightarrow> MTypes \<Rightarrow> MemoryT \<Rightarrow> MemoryT"
where
  "minitRec loc (MTArray x t) = (\<lambda>mem.
    let m = updateStore loc (MPointer loc) mem
    in iter (\<lambda>i m' . minitRec (hash loc (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t m') m x)"
| "minitRec loc (MTValue t) = updateStore loc (MValue (ival t))"

(*Covered*)
fun minit :: "int \<Rightarrow> MTypes \<Rightarrow> MemoryT \<Rightarrow> MemoryT"
where
  "minit x t mem =
    (let l = ShowL\<^sub>n\<^sub>a\<^sub>t (toploc mem);
         m = iter (\<lambda>i m' . minitRec (hash l (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t m') mem x
     in snd (allocate m))"

subsubsection \<open>Example\<close>

lemma "minit 2 (MTArray 2 (MTValue TBool)) emptyStore =
\<lparr>mapping = fmap_of_list
  [(STR ''0.0'', MPointer STR ''0.0''), (STR ''0.0.0'', MValue STR ''False''),
   (STR ''1.0.0'', MValue STR ''False''), (STR ''1.0'', MPointer STR ''1.0''),
   (STR ''0.1.0'', MValue STR ''False''), (STR ''1.1.0'', MValue STR ''False'')],
  toploc = 1\<rparr>" by eval

subsubsection \<open>Copy from memory to memory\<close>

subsubsection \<open>Definition\<close>

fun cpm2mrec :: "Location \<Rightarrow> Location \<Rightarrow> MTypes \<Rightarrow> MemoryT \<Rightarrow> MemoryT \<Rightarrow> MemoryT option"
where
  "cpm2mrec l\<^sub>s l\<^sub>d (MTArray x t) m\<^sub>s m\<^sub>d =
    (case accessStore l\<^sub>s m\<^sub>s of
      Some e \<Rightarrow>
        (case e of
          MPointer l \<Rightarrow> (let m = updateStore l\<^sub>d (MPointer l\<^sub>d) m\<^sub>d
             in iter' (\<lambda>i m'. cpm2mrec (hash l\<^sub>s (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash l\<^sub>d (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t m\<^sub>s m') m x)
        | _ \<Rightarrow> None)
    | None \<Rightarrow> None)"
| "cpm2mrec l\<^sub>s l\<^sub>d (MTValue t) m\<^sub>s m\<^sub>d =
    (case accessStore l\<^sub>s m\<^sub>s of
      Some e \<Rightarrow> (case e of
          MValue v \<Rightarrow> Some (updateStore l\<^sub>d (MValue v) m\<^sub>d)
        | _ \<Rightarrow> None)
    | None \<Rightarrow> None)"

fun cpm2m :: "Location \<Rightarrow> Location \<Rightarrow> int \<Rightarrow> MTypes \<Rightarrow> MemoryT \<Rightarrow> MemoryT \<Rightarrow> MemoryT option"
where
  "cpm2m l\<^sub>s l\<^sub>d x t m\<^sub>s m\<^sub>d = iter' (\<lambda>i m. cpm2mrec (hash l\<^sub>s (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash l\<^sub>d (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t m\<^sub>s m) m\<^sub>d x"

subsubsection \<open>Example\<close>

lemma "cpm2m (STR ''0'') (STR ''0'') 2 (MTArray 2 (MTValue TBool)) mymemory (snd (allocate emptyStore)) = Some mymemory"
  by eval

subsection \<open>Copy from storage to memory\<close>

subsubsection \<open>Definition\<close>

(*Covered*)
fun cps2mrec :: "Location \<Rightarrow> Location \<Rightarrow> STypes \<Rightarrow> StorageT \<Rightarrow> MemoryT \<Rightarrow> MemoryT option"
where
  "cps2mrec locs locm (STArray x t) sto mem =
    (let m = updateStore locm (MPointer locm) mem
    in iter' (\<lambda>i m'. cps2mrec (hash locs (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash locm (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t sto m') m x)"
| "cps2mrec locs locm (STValue t) sto mem =
    (let v = accessStorage t locs sto
    in Some (updateStore locm (MValue v) mem))"
| "cps2mrec _ _ (STMap _ _) _ _ = None"

(*Covered*)
fun cps2m :: "Location \<Rightarrow> Location \<Rightarrow> int \<Rightarrow> STypes \<Rightarrow> StorageT \<Rightarrow> MemoryT \<Rightarrow> MemoryT option"
where
  "cps2m locs locm x t sto mem =
    iter' (\<lambda>i m'. cps2mrec (hash locs (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash locm (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t sto m') mem x"

subsubsection \<open>Example\<close>

lemma "cps2m (STR ''1'') (STR ''0'') 2 (STArray 2 (STValue TBool)) mystorage (snd (allocate emptyStore)) = Some mymemory"
  by eval

subsection \<open>Copy from memory to storage\<close>

subsubsection \<open>Definition\<close>

(*covered*)
fun cpm2srec :: "Location \<Rightarrow> Location \<Rightarrow> MTypes \<Rightarrow> MemoryT \<Rightarrow> StorageT \<Rightarrow> StorageT option"
where
  "cpm2srec locm locs (MTArray x t) mem sto =
    (case accessStore locm mem of
      Some e \<Rightarrow>
        (case e of
          MPointer l \<Rightarrow> iter' (\<lambda>i s'. cpm2srec (hash locm (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash locs (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t mem s') sto x
        | _ \<Rightarrow> None)
    | None \<Rightarrow> None)"
| "cpm2srec locm locs (MTValue t) mem sto =
    (case accessStore locm mem of
      Some e \<Rightarrow> (case e of
          MValue v \<Rightarrow> Some (fmupd locs v sto)
        | _ \<Rightarrow> None)
    | None \<Rightarrow> None)"

(*covered*)
fun cpm2s :: "Location \<Rightarrow> Location \<Rightarrow> int \<Rightarrow> MTypes \<Rightarrow> MemoryT \<Rightarrow> StorageT \<Rightarrow> StorageT option"
where
  "cpm2s locm locs x t mem sto =
    iter' (\<lambda>i s'. cpm2srec (hash locm (ShowL\<^sub>i\<^sub>n\<^sub>t i)) (hash locs (ShowL\<^sub>i\<^sub>n\<^sub>t i)) t mem s') sto x"

subsubsection \<open>Example\<close>

lemma "cpm2s (STR ''0'') (STR ''1'') 2 (MTArray 2 (MTValue TBool)) mymemory fmempty = Some mystorage"
  by eval

end


(*:maxLineLen=78:*)

theory Eq
imports Base
begin

chapter \<open>Equational reasoning\<close>

text \<open>
  Equality is one of the most fundamental concepts of mathematics. The
  Isabelle/Pure logic (\chref{ch:logic}) provides a builtin relation \<open>\<equiv> :: \<alpha> \<Rightarrow>
  \<alpha> \<Rightarrow> prop\<close> that expresses equality of arbitrary terms (or propositions) at
  the framework level, as expressed by certain basic inference rules
  (\secref{sec:eq-rules}).

  Equational reasoning means to replace equals by equals, using reflexivity
  and transitivity to form chains of replacement steps, and congruence rules
  to access sub-structures. Conversions (\secref{sec:conv}) provide a
  convenient framework to compose basic equational steps to build specific
  equational reasoning tools.

  Higher-order matching is able to provide suitable instantiations for giving
  equality rules, which leads to the versatile concept of \<open>\<lambda>\<close>-term rewriting
  (\secref{sec:rewriting}). Internally this is based on the general-purpose
  Simplifier engine of Isabelle, which is more specific and more efficient
  than plain conversions.

  Object-logics usually introduce specific notions of equality or equivalence,
  and relate it with the Pure equality. This enables to re-use the Pure tools
  for equational reasoning for particular object-logic connectives as well.
\<close>

section \<open>Basic equality rules \label{sec:eq-rules}\<close>

text \<open>
  Isabelle/Pure uses \<open>\<equiv>\<close> for equality of arbitrary terms, which includes
  equivalence of propositions of the logical framework. The conceptual
  axiomatization of the constant \<open>\<equiv> :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> prop\<close> is given in
  \figref{fig:pure-equality}. The inference kernel presents slightly different
  equality rules, which may be understood as derived rules from this minimal
  axiomatization. The Pure theory also provides some theorems that express the
  same reasoning schemes as theorems that can be composed like object-level
  rules as explained in \secref{sec:obj-rules}.

  For example, \<^ML>\<open>Thm.symmetric\<close> as Pure inference is an ML function that
  maps a theorem \<open>th\<close> stating \<open>t \<equiv> u\<close> to one stating \<open>u \<equiv> t\<close>. In contrast,
  @{thm [source] Pure.symmetric} as Pure theorem expresses the same reasoning
  in declarative form. If used like \<open>th [THEN Pure.symmetric]\<close> in Isar source
  notation, it achieves a similar effect as the ML inference function,
  although the rule attribute @{attribute THEN} or ML operator \<^ML>\<open>op RS\<close>
  involve the full machinery of higher-order unification (modulo
  \<open>\<beta>\<eta>\<close>-conversion) and lifting of \<open>\<And>/\<Longrightarrow>\<close> contexts.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML Thm.reflexive: "cterm -> thm"} \\
  @{define_ML Thm.symmetric: "thm -> thm"} \\
  @{define_ML Thm.transitive: "thm -> thm -> thm"} \\
  @{define_ML Thm.abstract_rule: "string -> cterm -> thm -> thm"} \\
  @{define_ML Thm.combination: "thm -> thm -> thm"} \\[0.5ex]
  @{define_ML Thm.equal_intr: "thm -> thm -> thm"} \\
  @{define_ML Thm.equal_elim: "thm -> thm -> thm"} \\
  \end{mldecls}

  See also \<^file>\<open>~~/src/Pure/thm.ML\<close> for further description of these inference
  rules, and a few more for primitive \<open>\<beta>\<close> and \<open>\<eta>\<close> conversions. Note that \<open>\<alpha>\<close>
  conversion is implicit due to the representation of terms with de-Bruijn
  indices (\secref{sec:terms}).
\<close>

section \<open>Conversions \label{sec:conv}\<close>

text \<open>
  The classic article \<^cite>\<open>"paulson:1983"\<close> introduces the concept of
  conversion for Cambridge LCF. This was historically important to implement
  all kinds of ``simplifiers'', but the Isabelle Simplifier is done quite
  differently, see \<^cite>\<open>\<open>\S9.3\<close> in "isabelle-isar-ref"\<close>.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML_structure Conv} \\
  @{define_ML_type conv} \\
  @{define_ML Simplifier.asm_full_rewrite : "Proof.context -> conv"} \\
  \end{mldecls}

  \<^descr> \<^ML_structure>\<open>Conv\<close> is a library of combinators to build conversions,
  over type \<^ML_type>\<open>conv\<close> (see also \<^file>\<open>~~/src/Pure/conv.ML\<close>). This is one
  of the few Isabelle/ML modules that are usually used with \<^verbatim>\<open>open\<close>: finding
  examples works by searching for ``\<^verbatim>\<open>open Conv\<close>'' instead of ``\<^verbatim>\<open>Conv.\<close>''.

  \<^descr> \<^ML>\<open>Simplifier.asm_full_rewrite\<close> invokes the Simplifier as a
  conversion. There are a few related operations, corresponding to the various
  modes of simplification.
\<close>

section \<open>Rewriting \label{sec:rewriting}\<close>

text \<open>
  Rewriting normalizes a given term (theorem or goal) by replacing instances
  of given equalities \<open>t \<equiv> u\<close> in subterms. Rewriting continues until no
  rewrites are applicable to any subterm. This may be used to unfold simple
  definitions of the form \<open>f x\<^sub>1 \<dots> x\<^sub>n \<equiv> u\<close>, but is slightly more general than
  that. \<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML rewrite_rule: "Proof.context -> thm list -> thm -> thm"} \\
  @{define_ML rewrite_goals_rule: "Proof.context -> thm list -> thm -> thm"} \\
  @{define_ML rewrite_goal_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML rewrite_goals_tac: "Proof.context -> thm list -> tactic"} \\
  @{define_ML fold_goals_tac: "Proof.context -> thm list -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>rewrite_rule\<close>~\<open>ctxt rules thm\<close> rewrites the whole theorem by the
  given rules.

  \<^descr> \<^ML>\<open>rewrite_goals_rule\<close>~\<open>ctxt rules thm\<close> rewrites the outer premises of
  the given theorem. Interpreting the same as a goal state
  (\secref{sec:tactical-goals}) it means to rewrite all subgoals (in the same
  manner as \<^ML>\<open>rewrite_goals_tac\<close>).

  \<^descr> \<^ML>\<open>rewrite_goal_tac\<close>~\<open>ctxt rules i\<close> rewrites subgoal \<open>i\<close> by the given
  rewrite rules.

  \<^descr> \<^ML>\<open>rewrite_goals_tac\<close>~\<open>ctxt rules\<close> rewrites all subgoals by the given
  rewrite rules.

  \<^descr> \<^ML>\<open>fold_goals_tac\<close>~\<open>ctxt rules\<close> essentially uses \<^ML>\<open>rewrite_goals_tac\<close>
  with the symmetric form of each member of \<open>rules\<close>, re-ordered to fold longer
  expression first. This supports to idea to fold primitive definitions that
  appear in expended form in the proof state.
\<close>

end