(*

Copyright (c) 2017, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

(*<*)
theory Syntax
  imports Equivalence Resolution Model
begin
(*>*)

subsection {* Abstract Syntax for Nets *}
text_raw {* \label{sec:isasyntax} *}

text {* This is the abstract syntax, corresponding to the concrete sytax
        introduced in \autoref{sec:model}.  We do not yet have a parser, and
        thus models are constructed by hand. *}

text {* A contiguous block of addresses, expressed as a base-limit pair: *}

record block_spec =
  base    :: genaddr
  limit   :: genaddr
  require :: "property list"
  reject  :: "property list"

definition block :: "genaddr \<Rightarrow> genaddr \<Rightarrow> property list \<Rightarrow> property list \<Rightarrow> block_spec"
  where "block b l r f  = \<lparr> base = b, limit = l, require = r, reject = f \<rparr>"

definition blockn :: "genaddr \<Rightarrow> genaddr \<Rightarrow> block_spec"
  where "blockn b l  = \<lparr> base = b, limit = l, require = [], reject = [] \<rparr>"

text {* For each syntax item (nonterminal), we have a translation function into
        the abstract semantic model.  Together these define the parse() function
        of \autoref{sec:reductions}. *}

text {* An address contains a set of properties. When specifying a set of addresses
        that are translated or accepted we use the notion of required and rejected properties.
        An address that is element of the accept or translate set must fulfill the following
        predicate. *}

definition prop_pred :: "property set \<Rightarrow> property set \<Rightarrow> property set \<Rightarrow> bool"
  where "prop_pred incl excl props =  (excl \<inter> props = {}  \<and> incl \<subseteq> props)"

text {* When creating the block from it's spec we include a set of net properties which are the
        properties mentioned in the decoding net and therefore the properties we care about. *}

definition mk_block :: "property set \<Rightarrow> block_spec \<Rightarrow> addr set"
  where "mk_block netpropss s = {(a, p) | a p. (base s) \<le> a \<and> a \<le> (limit s)
                                   \<and> prop_pred (set (require s)) (set (reject s)) p
                                   \<and> p \<subseteq> netpropss }"

text {* We obtain the relevant properties of a block by the union of the reject and require lists *}

primrec mk_block_propset :: "block_spec list \<Rightarrow> property set"
  where "mk_block_propset [] = {}" |
        "mk_block_propset (m#mm) = (mk_block_propset mm) \<union> set (require m) \<union> set (reject m)"

text {* A single block mapping that maps the specified source block to the given
        destination node, beginning at the given base address and adds or strips some
        properties. *}

record map_spec =
  src_block :: block_spec
  dest_node :: nodeid
  dest_base :: genaddr
  propadd   :: "property list"
  propstrip :: "property list"

text {* Map a block without changing its base address: *}

definition block_map :: "block_spec \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> map_spec"
  where "block_map blk nd ba = \<lparr> src_block = blk, dest_node = nd, dest_base = ba,
                                 propadd = [], propstrip = [] \<rparr>"

definition block_map_p :: "block_spec \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> property list
                                        \<Rightarrow> property list \<Rightarrow> map_spec"
  where "block_map_p blk nd ba pa ps  = \<lparr> src_block = blk, dest_node = nd,
                                          dest_base = ba, propadd = pa,
                                          propstrip = ps \<rparr>"

definition direct_map :: "block_spec \<Rightarrow> nodeid \<Rightarrow> map_spec"
  where "direct_map blk nd = \<lparr> src_block = blk, dest_node = nd,
                              dest_base = (base blk),
                              propadd = [], propstrip = [] \<rparr>"

definition direct_map_p :: "block_spec \<Rightarrow> nodeid \<Rightarrow> property list
                                       \<Rightarrow> property list \<Rightarrow> map_spec"
  where "direct_map_p blk nd pa ps = \<lparr> src_block = blk, dest_node = nd,
                                      dest_base = (base blk),
                                      propadd =  pa, propstrip =  ps \<rparr>"

definition one_map :: "addr \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> map_spec"
  where "one_map src nd ba =  \<lparr> src_block = \<lparr> base = (fst src), limit = (fst src),
                                             require = [], reject = [] \<rparr>,
                               dest_node = nd, dest_base = ba,
                               propadd =[],propstrip = [] \<rparr>"

definition one_map_p :: "addr \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> property list
                              \<Rightarrow> property list \<Rightarrow> map_spec"
  where "one_map_p src nd ba pa ps =  \<lparr> src_block = \<lparr> base = (fst src),
                                                     limit = (fst src),
                                                     require = [],
                                                     reject = [] \<rparr>,
                                       dest_node = nd, dest_base = ba,
                                       propadd =  pa,propstrip =  ps \<rparr>"

definition mk_map :: "property set \<Rightarrow> map_spec \<Rightarrow> addr \<Rightarrow> name set"
  where "mk_map ps s =
    (\<lambda>a. if a \<in> mk_block ps (src_block s)
      then {
        (dest_node s, (dest_base s + (fst a - base (src_block s))),
                         (snd a) \<union> (set (propadd s)) - (set (propstrip s))) }
      else {})"

text {* we can obtain the relevant properties of the map by the union of the propadd, propetrip
        and source block properties *}

primrec mk_map_propset :: "map_spec list \<Rightarrow> property set"
  where "mk_map_propset [] = {}" |
        "mk_map_propset (m#mm) = (mk_map_propset mm) \<union> set (propadd m)
                                      \<union> set (propstrip m) \<union> mk_block_propset [src_block m]"

text {* A finitely-specified decoding node, with a list of blocks to accept
        locally, and a list of those to translate: *}

record node_spec =
  acc_blocks :: "block_spec list"
  map_blocks :: "map_spec list"
  overlay    :: "nodeid option"

definition empty_spec :: "node_spec"
  where "empty_spec = \<lparr> acc_blocks = [], map_blocks = [], overlay = None \<rparr>"

(*<*)
lemma acc_blocks_empty:
  "acc_blocks empty_spec = []"
  by(simp add:empty_spec_def)
(*>*)

text {* If an overlay node is specified, initialise the map by forwarding all
        addresses to that  node: *}

definition mk_overlay :: "nodeid option \<Rightarrow> node"
  where "mk_overlay ov = \<lparr>
          accept = {},
          translate = (case ov of None \<Rightarrow> \<lambda>_. {} | Some n \<Rightarrow> (\<lambda>a. {(n,a)})) \<rparr>"

(*<*)
lemma accept_mk_overlay:
  "accept (mk_overlay ov) = {}"
  by(simp add:mk_overlay_def)
(*>*)

primrec add_blocks :: "property set \<Rightarrow> block_spec list \<Rightarrow> node \<Rightarrow> node"
  where "add_blocks ps [] node = node" |
        "add_blocks ps (s#ss) node = accept_update (op \<union> (mk_block ps s))
                                                   (add_blocks ps ss node)"

(*<*)
lemma translate_add_blocks:
  "translate (add_blocks ps bs node) = translate node"
  by(induct bs, simp_all)

lemma add_blocks_overlay:
  "accept (add_blocks ps bs (mk_overlay ov)) =
   accept (add_blocks ps bs empty_node)"
  by(induct bs, simp_all add:empty_node_def accept_mk_overlay)
(*>*)

definition add_maps :: "property set \<Rightarrow> map_spec list \<Rightarrow> node \<Rightarrow> node"
  where "add_maps ps ss node = translate_update
                                   (\<lambda>t a. \<Union>{mk_map ps s a |s. s\<in>(set ss) } \<union> t a)
                                    node"

primrec add_maps_rec :: "property set \<Rightarrow> map_spec list \<Rightarrow> node \<Rightarrow> node"
  where "add_maps_rec ps [] node = node" |
        "add_maps_rec ps (s#ss) node = translate_update
                                          (\<lambda>t a. mk_map ps s a \<union> t a)
                                          (add_maps_rec ps ss node)"

definition remove_maps :: "property set \<Rightarrow> map_spec list \<Rightarrow> node \<Rightarrow> node"
  where "remove_maps ps ss node = translate_update
                                   (\<lambda>t a. t a - \<Union>{mk_map ps s a |s. s\<in>(set ss) })
                                    node"

lemma remove_maps_set_diff:
  "A - \<Union>{mk_map ps s a |s. s \<in> set ms \<or> s \<in> set ns}
    = A - \<Union>{mk_map ps s a |s. s \<in> set ns} - \<Union>{mk_map ps s a |s. s \<in> set ms}"
  by(auto)

lemma remove_maps_append :
  "remove_maps ps (ms @ ns) node = remove_maps ps ms (remove_maps ps ns node)"
  by(auto simp add:remove_maps_def o_def remove_maps_set_diff)

definition add_one_map :: "property set \<Rightarrow> map_spec \<Rightarrow> node \<Rightarrow> node"
  where "add_one_map ps m n = translate_update (\<lambda>t a. mk_map ps m a \<union> t a) n"

definition remove_one_map :: "property set \<Rightarrow> map_spec \<Rightarrow> node \<Rightarrow> node"
  where "remove_one_map ps m n = n \<lparr> translate := (\<lambda>a. translate n a - mk_map ps m a) \<rparr>"

definition update_one_map :: "property set \<Rightarrow> map_spec \<Rightarrow> map_spec \<Rightarrow> node \<Rightarrow> node"
  where "update_one_map ps m m' n = add_one_map ps m' (remove_one_map ps m n)"

lemma update_commute:
  assumes m_distinct: "\<And>a. translate node a \<inter> mk_map ps m a = {}"
      and n_contained: "\<And>a. mk_map ps n a \<subseteq> translate node a"
  shows "update_one_map ps m n (update_one_map ps n m node) = node"
proof -
  have "\<And>a. translate node a - mk_map ps n a \<subseteq> translate node a" by(auto)
  hence "\<And>a. (translate node a - mk_map ps n a) \<inter> mk_map ps m a
                    \<subseteq> translate node a \<inter> mk_map ps m a"
    by(auto)
  also note m_distinct
  finally have "\<And>a.(translate node a - mk_map ps n a) \<inter> mk_map ps m a = {}" by(auto)
  with m_distinct
  have "\<And>a. translate node a - mk_map ps n a - mk_map ps m a =
             translate node a - mk_map ps n a"
    by(simp add:Diff_triv)
  with n_contained show ?thesis
    by(simp add:update_one_map_def add_one_map_def remove_one_map_def o_def
                Un_Diff Un_absorb1)
qed

lemma mk_map_set_append :
  "mk_map ps a aa \<union> \<Union>{mk_map ps s aa |s. s \<in> set ss}
     = \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)}"
  by(auto)

lemma mk_map_set_commute :
  "mk_map ps a aa \<union> (\<Union>{mk_map ps s aa |s. s \<in> set ss}\<union> t aa)
     = \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)} \<union> t aa"
  by(auto)

lemma translate_update_append:
  "translate_update (\<lambda>t aa. \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)} \<union> t aa) node =
  translate_update (\<lambda>t aa. mk_map ps a aa \<union> (\<Union>{mk_map ps s aa |s. s \<in> set (ss)}) \<union> t aa) node"
  by(simp add:mk_map_set_append)

lemma translate_update_commute:
  "translate_update (\<lambda>t aa. \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)} \<union> t aa) node =
  translate_update (\<lambda>t aa. mk_map ps a aa \<union> ((\<Union>{mk_map ps s aa |s. s \<in> set (ss)}) \<union> t aa)) node"
  by(subst mk_map_set_commute, auto)

lemma add_maps_recursive:
  "add_maps_rec ps ss node = add_maps ps ss node"
  apply(induct ss)
  apply(simp_all add:add_maps_def add_maps_rec_def o_def)
  apply(simp add:translate_update_commute[symmetric])
  done

(*<*)
lemma accept_add_maps:
  "accept (add_maps ps ms node) = accept node"
  by(simp add:add_maps_def)

lemma translate_update_chain :
  "translate_update (\<lambda>t a. A \<union> t a) (translate_update (\<lambda>t a. B \<union> t a) node) =
   translate_update (\<lambda>t a. A \<union> B \<union> t a) node"
  by(simp add:o_def Un_assoc)

lemma add_maps_set_union:
     "\<Union>{mk_map ps s a |s. s \<in> set ms \<or> s \<in> set ns} =
      \<Union>{mk_map ps s a |s. s \<in> set ms} \<union> \<Union>{mk_map ps s a |s. s \<in> set ns}"
  by(auto)

lemma add_maps_set_append :
      "\<Union>{mk_map ps s a |s. s \<in> set (ms @ ns)} =
       \<Union>{mk_map ps s a |s. s \<in> set ms} \<union> \<Union>{mk_map ps s a |s. s \<in> set ns}"
  by(auto)

lemma add_maps_append_direct:
   "add_maps ps ms (add_maps ps ns node) =
    translate_update (\<lambda>t a. \<Union>{mk_map ps s a |s. s\<in>(set (ms @ ns)) } \<union> t a) node"
  by(simp add:add_maps_def o_def Un_assoc[symmetric] add_maps_set_union)

lemma add_maps_append:
  "add_maps ps (ms @ ns) node = add_maps ps ms (add_maps ps ns node)"
  by(simp add:add_maps_def o_def  Un_assoc[symmetric] add_maps_set_union)

lemma add_maps_append2 :
  "add_maps ps (a' @ b' @ c' @ d') node = add_maps ps (a' @ b') (add_maps  ps(c' @ d') node)"
  by(simp add:add_maps_append)

lemma set_commute: "set [a, b] = set [b, a]"
  by(auto)

lemma add_maps_list_commute :
  shows   "add_maps ps [a, b] node = add_maps ps [b, a] node"
  by(simp only:add_maps_def set_commute)

lemma add_maps_commute:
  "add_maps ps (a @ b) node = add_maps ps (b @ a) node"
  by(simp only:add_maps_def add_maps_set_append Un_commute)

lemma add_maps_commute3:
  "add_maps ps (a @ b @ c) node = add_maps ps (b @ a @ c) node"
  apply(simp only:add_maps_def add_maps_set_append)
  apply(simp only:Un_assoc[symmetric])
  apply(simp only: Un_commute)
  done

lemma add_maps_append_commute:
   "add_maps ps a (add_maps ps b node) = add_maps ps b (add_maps ps a node)"
  by(simp add:add_maps_append[symmetric] add_maps_commute)

(*>*)

definition mk_node :: "property set \<Rightarrow> node_spec \<Rightarrow> node"
  where "mk_node ps s = add_maps ps (map_blocks s)
                         (add_blocks ps (acc_blocks s)
                         (mk_overlay (overlay s)))"

text {* the set of used properties in the node is the union of the accept list and
        translate list properties*}

definition mk_node_propset :: "node_spec \<Rightarrow> property set"
  where "mk_node_propset n = mk_map_propset (map_blocks n) \<union> mk_block_propset (acc_blocks n)"

(*<*)
lemma accept_mk_node:
  "accept (mk_node ps s) = accept (add_blocks ps (acc_blocks s) empty_node)"
  by(simp add:mk_node_def accept_add_maps add_blocks_overlay)

lemma maps_blocks_comm:
  "add_maps ps ms (add_blocks ps bs node) = add_blocks ps bs (add_maps ps ms node)"
proof(simp only: add_maps_recursive[symmetric], induct ms, simp_all)
  fix m ms
  assume IH: "add_maps_rec ps ms (add_blocks ps bs node)
                  = add_blocks ps bs (add_maps_rec ps ms node)"

  have tu_au_comm:
    "\<And>f g node. translate_update f (accept_update g node) =
                accept_update g (translate_update f node)"
    by(simp)

  show "translate_update (\<lambda>t a. mk_map ps m a \<union> t a)
                         (add_blocks ps bs (add_maps_rec ps ms node)) =
        add_blocks ps bs (translate_update (\<lambda>t a. mk_map ps m a \<union> t a)
                                        (add_maps_rec ps ms node))"
    by(induct bs, simp_all add:tu_au_comm)
qed

lemma translate_mk_node:
  "translate (mk_node ps s) = translate (add_maps ps (map_blocks s)
                                     (mk_overlay (overlay s)))"
  by(simp add:mk_node_def maps_blocks_comm translate_add_blocks)
(*>*)

type_synonym net_spec = "(nodeid \<times> node_spec) list"

definition "empty_net = (\<lambda>_. empty_node)"

primrec repeat_node :: "node_spec \<Rightarrow> nodeid \<Rightarrow> nat \<Rightarrow> net_spec"
  where "repeat_node node ba 0 = []" |
        "repeat_node node ba (Suc n) = (ba, node) # repeat_node node (Suc ba) n"

text {* we can obtain the relevant properties of the net by the union of all the nodes *}

primrec mk_net_propset :: "net_spec \<Rightarrow> property set"
  where "mk_net_propset [] = {}" |
        "mk_net_propset (s#ss) = (mk_net_propset ss) \<union> (mk_node_propset (snd s))"

(*
primrec mk_net_step :: "property set \<Rightarrow> net_spec \<Rightarrow> net"
  where "mk_net_step ps [] = empty_net" |
        "mk_net_step ps (s#ss) = (mk_net_step ps ss)(fst s := mk_node ps (snd s))"

definition mk_net :: "net_spec \<Rightarrow> net"
  where "mk_net ns = mk_net_step {0..<4} ns"
*)

primrec mk_net :: "net_spec \<Rightarrow> net"
  where "mk_net [] = empty_net" |
        "mk_net (s#ss) = (mk_net ss)(fst s := mk_node ALLPROPERTIES (snd s))"

(*<*)
lemma map_blocks_empty_spec:
  "map_blocks empty_spec = []"
  by(simp add:mk_overlay_def empty_spec_def)

lemma mk_net_empty:
  "mk_net [] nd = empty_node"
  by(simp add:mk_net_def empty_net_def)

subsubsection {* Finitness of property sets *}

text {* we show that the property sets we obtain from the syntax are finite *}

lemma mk_block_propset_finite :
"finite (mk_block_propset m)"
  apply(induct m)
  apply(simp_all add:mk_block_propset_def)
  done

lemma mk_map_propset_finite:
"finite (mk_map_propset m)"
  apply(induct m)
  apply(simp_all add:mk_map_propset_def)
  done

lemma mk_node_propset_finite:
"finite (mk_node_propset n)"
  by(simp add:mk_node_propset_def mk_map_propset_finite mk_block_propset_finite)

lemma mk_net_propset_finite:
"finite (mk_net_propset n)"
  apply(induct n)
  apply(simp_all add:mk_node_propset_finite mk_net_propset_def)
  done

subsubsection {* Correctness by Construction *}

definition wf_node :: "node \<Rightarrow> bool"
  where "wf_node node \<longleftrightarrow> finite (accept node) \<and> (\<forall>a. finite (translate node a))"

lemma wf_nodeI:
  "finite (accept node) \<Longrightarrow> (\<And>a. finite (translate node a)) \<Longrightarrow> wf_node node"
  by(simp add:wf_node_def)

lemma wf_node_wf_net:
  "(\<And>nd. wf_node (net nd)) \<Longrightarrow> wf_net net"
  unfolding wf_node_def wf_net_def
  by(auto simp:Image_def decodes_to_def decode_step_def)

lemma wf_empty_node:
  "wf_node empty_node"
  unfolding empty_node_def by(auto intro:wf_nodeI)

lemma wf_overlay:
  "wf_node (mk_overlay s)"
  unfolding mk_overlay_def by(cases s, simp_all add:wf_node_def)

lemma mk_block_finite:
  assumes psfini: "finite ps"
  shows "finite (mk_block ps s)"
proof -
  have sep: "{(a, p) | a p. (base s) \<le> a \<and> a \<le> (limit s)
               \<and> prop_pred (set (require s)) (set (reject s)) p
               \<and> p \<subseteq> ps } = {a.(base s) \<le> a \<and> a \<le> (limit s) } \<times>
                  {p. prop_pred (set (require s)) (set (reject s)) p
               \<and> p \<subseteq> ps}"
    by(auto)
  have fina: "finite {a.(base s) \<le> a \<and> a \<le> (limit s) }"
    by(auto)
  from psfini have finb: "finite {p. prop_pred (set (require s)) (set (reject s)) p
               \<and> p \<subseteq> ps}"
    by(auto)

  from finb fina sep show ?thesis
    by(auto simp: mk_block_def )
qed

lemma wf_add_blocks:
  assumes wf_base: "wf_node node"
      and psfini: "finite ps"
  shows "wf_node (add_blocks ps ss node)"
proof(induct ss, simp_all add:wf_base)
  fix s ss
  assume IH: "wf_node (add_blocks ps ss node)"
  hence "finite (accept (add_blocks ps ss node))" "\<And>s. finite (translate (add_blocks ps ss node) s)"
    by(auto simp:wf_node_def)
  moreover from psfini have "finite (mk_block ps s)"
    by(simp add: mk_block_finite)
  ultimately show "wf_node (accept_update (op \<union> (mk_block ps s)) (add_blocks ps ss node))"
    by(auto intro:wf_nodeI)
qed

lemma wf_add_maps:
  assumes wf_base: "wf_node node"
      and psfini: "finite ps"
  shows "wf_node (add_maps ps ss node)"
proof(simp only: add_maps_recursive[symmetric],induct ss, simp_all add:wf_base)
  fix s ss
  assume IH: "wf_node (add_maps_rec ps ss node)"
  hence "finite (accept (add_maps_rec ps ss node))" "\<And>a. finite (translate (add_maps_rec ps ss node) a)"
    by(auto simp:wf_node_def)
  moreover have "\<And>a. finite (mk_map ps s a)"
    unfolding mk_map_def by(simp)
  ultimately show "wf_node (translate_update (\<lambda>t a. mk_map ps s a \<union> t a) (add_maps_rec ps ss node))"
    by(auto intro:wf_nodeI)
qed

lemma wf_mk_node:
  "finite ps \<Longrightarrow> wf_node (mk_node ps s)"
  unfolding mk_node_def by(auto intro:wf_add_maps wf_add_blocks wf_overlay)

lemma wf_empty_net:
  "wf_net empty_net"
  unfolding empty_net_def by(auto intro:wf_node_wf_net wf_empty_node)
(*>*)

text {* Nets built from abstract syntax are correct by construction: *}

(*
lemma wf_mk_net_step :
  assumes psfini: "finite ps"
  shows "wf_net (mk_net_step ps ss)"
proof (rule wf_node_wf_net, induct ss)
  case Nil
  then show ?case by(auto simp: wf_empty_net empty_net_def wf_empty_node)
next
  case (Cons a ss)
  then show ?case
    by(simp add:mk_net_step_def wf_mk_node psfini)
qed

lemma wf_mk_net:
  "wf_net (mk_net ss)"
  by(simp add:mk_net_def wf_mk_net_step mk_net_propset_finite)
*)

lemma wf_mk_net:
  "wf_net (mk_net ss)"
  by(rule wf_node_wf_net, induct ss, simp_all add:empty_net_def
          wf_empty_node wf_mk_node ALLPROPERTIES_def)

subsubsection {* Finding Fresh Nodes *}

text {* These functions are guaranteed to return a node that's unused in the supplied
  specification. *}
definition ff_overlay :: "nodeid option \<Rightarrow> nodeid"
  where "ff_overlay s = (case s of Some nd \<Rightarrow> Suc nd | None \<Rightarrow> 0)"

(*<*)
lemma ff_overlay_ub:
  assumes "(nd',a') \<in> translate (mk_overlay ov) a"
  shows "nd' < ff_overlay ov"
  using assms by(cases ov, simp_all add:mk_overlay_def ff_overlay_def)
(*>*)

primrec ff_map :: "map_spec list \<Rightarrow> nodeid"
  where "ff_map [] = 0" |
        "ff_map (s#ss) = max (Suc (dest_node s)) (ff_map ss)"

(*<*)
lemma ff_add_blocks_ub:
  assumes "\<And>nd' a' a. (nd',a') \<in> translate node a \<Longrightarrow> nd' < x"
      and "(nd',a') \<in> translate (add_blocks ps bs node) a"
    shows "nd' < x"
  using assms by(simp add:translate_add_blocks)

lemma ff_add_maps_ub:
  assumes ff_node: "\<And>nd' a' a. (nd',a') \<in> translate node a \<Longrightarrow> nd' < x"
      and nda': "(nd',a') \<in> translate (add_maps ps ms node) a"
    shows "nd' < max x (ff_map ms)"
  using nda'
proof(induct ms, simp add:ff_node add_maps_recursive[symmetric])
  fix m ms
  assume IH: "(nd', a') \<in> translate (add_maps ps ms node) a \<Longrightarrow> nd' < max x (ff_map ms)"
     and step: "(nd', a') \<in> translate (add_maps ps (m # ms) node) a"

  from step have "(nd',a') \<in> mk_map ps m a \<or> (nd',a') \<in> translate (add_maps ps ms node) a"
    by(simp add:add_maps_recursive[symmetric])
  thus "nd' < max x (ff_map (m # ms))"
  proof
    assume "(nd', a') \<in> mk_map ps m a"
    hence "nd' < Suc (dest_node m)"
      by(cases "a \<in> mk_block ps (src_block m)", simp_all add:mk_map_def)
    thus ?thesis by(simp)
  next
    assume "(nd', a') \<in> translate (add_maps ps ms node) a"
    thus ?thesis by(simp only:add_maps_recursive[symmetric], auto dest:IH)
  qed
qed
(*>*)

definition ff_node :: "node_spec \<Rightarrow> nodeid"
  where "ff_node s = max (ff_overlay (overlay s)) (ff_map (map_blocks s))"

(*<*)
lemma ff_node_ub:
  assumes step: "(nd',a') \<in> translate (mk_node ps s) a"
  shows "nd' < ff_node s"
  unfolding ff_node_def using ff_overlay_ub
  by(auto simp:translate_add_blocks intro:ff_add_maps_ub[OF _ step[unfolded mk_node_def]])
(*>*)

primrec ff_net :: "net_spec \<Rightarrow> nodeid"
  where "ff_net [] = 0" |
        "ff_net (s#ss) = Max {ff_node (snd s), ff_net ss, Suc (fst s)}"

(*<*)
lemma ff_net_empty:
  "ff_net s \<le> nd \<Longrightarrow> mk_net s nd = empty_node"
  by(induct s, simp_all add:empty_net_def mk_net_empty)

lemma decodes_to_empty_net:
  "decodes_to empty_net = {}"
  by(simp add:decodes_to_def decode_step_def empty_net_def empty_node_def)

lemma ff_net_ub:
    shows "(x,y) \<in> decodes_to (mk_net s) \<Longrightarrow> fst x < ff_net s"
proof(induct s, simp add:decodes_to_empty_net)
  fix s ss
  assume IH: "(x, y) \<in> decodes_to (mk_net ss) \<Longrightarrow> fst x < ff_net ss"
     and dec: "(x, y) \<in> decodes_to (mk_net (s # ss))"

  show "fst x < ff_net (s # ss)"
  proof(cases)
    assume "fst y = fst s"
    with  dec have "x \<in> translate (mk_node ALLPROPERTIES (snd s)) (snd y)"
      by(cases x, cases y, simp add:decodes_to_def decode_step_def ALLPROPERTIES_def)
    hence "fst x < ff_node (snd s)"
      by(cases x, auto intro:ff_node_ub)
    thus ?thesis by(simp)
  next
    assume "fst y \<noteq> fst s"
    with dec have "(x, y) \<in> decodes_to (mk_net ss)"
      by(cases y, simp add:decodes_to_def decode_step_def mk_net_def)
    with IH show ?thesis by(simp)
  qed
qed

lemma ff_net_fresh:
  assumes ff: "ff_net s \<le> nd"
  shows "fresh_node (mk_net s) nd"
  unfolding fresh_node_def
proof(intro conjI allI impI)
  fix a
  from ff have "mk_net s nd = empty_node" by(rule ff_net_empty)
  thus "accept (mk_net s nd) = {}" "translate (mk_net s nd) a = {}"
    by(simp_all add:empty_node_def)
next
  fix x y
  assume "(x, y) \<in> decodes_to (mk_net s)"
  hence "fst x < ff_net s"
    by(rule ff_net_ub)
  also note ff
  finally show "fst x \<noteq> nd" by(simp)
qed

lemma ff_net_idbound:
  "nd \<in> set (map fst s) \<Longrightarrow> nd < ff_net s"
proof(induct s, simp_all)
  fix s::"(nodeid \<times> node_spec)" and ss
  assume IH: "nd \<in> fst ` set ss \<Longrightarrow> nd < ff_net ss"
  assume "nd = fst s \<or> nd \<in> fst ` set ss"
  thus "nd < max (ff_node (snd s)) (max (ff_net ss) (Suc (fst s)))"
  proof
    assume "nd = fst s" thus ?thesis by(auto)
  next
    assume "nd \<in> fst ` set ss"
    with IH have "nd < ff_net ss" by(blast)
    thus ?thesis by(auto)
  qed
qed
(*>*)

(*<*)
end
(*>*)


(*  Title:      JinjaDCI/J/SmallStep.thy
    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   2003 Technische Universitaet Muenchen, 2019-20 UIUC

    Based on the Jinja theory J/SmallStep.thy by Tobias Nipkow
*)

section \<open> Small Step Semantics \<close>

theory SmallStep
imports Expr State WWellForm
begin

fun blocks :: "vname list * ty list * val list * expr \<Rightarrow> expr"
where
 "blocks(V#Vs, T#Ts, v#vs, e) = {V:T := Val v; blocks(Vs,Ts,vs,e)}"
|"blocks([],[],[],e) = e"

lemmas blocks_induct = blocks.induct[split_format (complete)]

lemma sub_RI_blocks_body[iff]: "length vs = length pns \<Longrightarrow> length Ts = length pns
 \<Longrightarrow> sub_RI (blocks (pns, Ts, vs, body)) \<longleftrightarrow> sub_RI body"
proof(induct pns arbitrary: Ts vs)
  case Nil then show ?case by simp
next
  case Cons then show ?case by(cases vs; cases Ts) auto
qed

definition assigned :: "'a \<Rightarrow> 'a exp \<Rightarrow> bool"
where
  "assigned V e  \<equiv>  \<exists>v e'. e = (V := Val v;; e')"

\<comment> \<open> expression is okay to go the right side of @{text INIT} or @{text "RI \<leftarrow>"}
 or to have indicator Boolean be True (in latter case, given that class is
 also verified initialized) \<close>
fun icheck :: "'m prog \<Rightarrow> cname \<Rightarrow> 'a exp \<Rightarrow> bool" where
"icheck P C' (new C) = (C' = C)" |
"icheck P D' (C\<bullet>\<^sub>sF{D}) = ((D' = D) \<and> (\<exists>T. P \<turnstile> C has F,Static:T in D))" |
"icheck P D' (C\<bullet>\<^sub>sF{D}:=(Val v)) = ((D' = D) \<and> (\<exists>T. P \<turnstile> C has F,Static:T in D))" |
"icheck P D (C\<bullet>\<^sub>sM(es)) = ((\<exists>vs. es = map Val vs) \<and> (\<exists>Ts T m. P \<turnstile> C sees M,Static:Ts\<rightarrow>T = m in D))" |
"icheck P _ _ = False"

lemma nicheck_SFAss_nonVal: "val_of e\<^sub>2 = None \<Longrightarrow> \<not>icheck P C' (C\<bullet>\<^sub>sF{D} := (e\<^sub>2::'a exp))"
 by(rule notI, cases e\<^sub>2, auto)

inductive_set
  red  :: "J_prog \<Rightarrow> ((expr \<times> state \<times> bool) \<times> (expr \<times> state \<times> bool)) set"
  and reds  :: "J_prog \<Rightarrow> ((expr list \<times> state \<times> bool) \<times> (expr list \<times> state \<times> bool)) set"
  and red' :: "J_prog \<Rightarrow> expr \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> expr \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool"
          ("_ \<turnstile> ((1\<langle>_,/_,/_\<rangle>) \<rightarrow>/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81)
  and reds' :: "J_prog \<Rightarrow> expr list \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> expr list \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool"
          ("_ \<turnstile> ((1\<langle>_,/_,/_\<rangle>) [\<rightarrow>]/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81)
  for P :: J_prog
where

  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<equiv> ((e,s,b), e',s',b') \<in> red P"
| "P \<turnstile> \<langle>es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle> \<equiv> ((es,s,b), es',s',b') \<in> reds P"

| RedNew:
  "\<lbrakk> new_Addr h = Some a; P \<turnstile> C has_fields FDTs; h' = h(a\<mapsto>blank P C) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>new C, (h,l,sh), True\<rangle> \<rightarrow> \<langle>addr a, (h',l,sh), False\<rangle>"

| RedNewFail:
  "\<lbrakk> new_Addr h = None; is_class P C \<rbrakk> \<Longrightarrow>
  P \<turnstile> \<langle>new C, (h,l,sh), True\<rangle> \<rightarrow> \<langle>THROW OutOfMemory, (h,l,sh), False\<rangle>"

| NewInitDoneRed:
  "sh C = Some (sfs, Done) \<Longrightarrow>
  P \<turnstile> \<langle>new C, (h,l,sh), False\<rangle> \<rightarrow> \<langle>new C, (h,l,sh), True\<rangle>"

| NewInitRed:
  "\<lbrakk> \<nexists>sfs. sh C = Some (sfs, Done); is_class P C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>new C,(h,l,sh),False\<rangle> \<rightarrow> \<langle>INIT C ([C],False) \<leftarrow> new C,(h,l,sh),False\<rangle>"

| CastRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>Cast C e, s, b\<rangle> \<rightarrow> \<langle>Cast C e', s', b'\<rangle>"

| RedCastNull:
  "P \<turnstile> \<langle>Cast C null, s, b\<rangle> \<rightarrow> \<langle>null,s,b\<rangle>"

| RedCast:
 "\<lbrakk> h a = Some(D,fs); P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>Cast C (addr a), (h,l,sh), b\<rangle> \<rightarrow> \<langle>addr a, (h,l,sh), b\<rangle>"

| RedCastFail:
  "\<lbrakk> h a = Some(D,fs); \<not> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>Cast C (addr a), (h,l,sh), b\<rangle> \<rightarrow> \<langle>THROW ClassCast, (h,l,sh), b\<rangle>"

| BinOpRed1:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e \<guillemotleft>bop\<guillemotright> e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>e' \<guillemotleft>bop\<guillemotright> e\<^sub>2, s', b'\<rangle>"

| BinOpRed2:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>(Val v\<^sub>1) \<guillemotleft>bop\<guillemotright> e, s, b\<rangle> \<rightarrow> \<langle>(Val v\<^sub>1) \<guillemotleft>bop\<guillemotright> e', s', b'\<rangle>"

| RedBinOp:
  "binop(bop,v\<^sub>1,v\<^sub>2) = Some v \<Longrightarrow>
  P \<turnstile> \<langle>(Val v\<^sub>1) \<guillemotleft>bop\<guillemotright> (Val v\<^sub>2), s, b\<rangle> \<rightarrow> \<langle>Val v,s,b\<rangle>"

| RedVar:
  "l V = Some v \<Longrightarrow>
  P \<turnstile> \<langle>Var V,(h,l,sh),b\<rangle> \<rightarrow> \<langle>Val v,(h,l,sh),b\<rangle>"

| LAssRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>V:=e,s,b\<rangle> \<rightarrow> \<langle>V:=e',s',b'\<rangle>"

| RedLAss:
  "P \<turnstile> \<langle>V:=(Val v), (h,l,sh), b\<rangle> \<rightarrow> \<langle>unit, (h,l(V\<mapsto>v),sh), b\<rangle>"

| FAccRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<bullet>F{D}, s, b\<rangle> \<rightarrow> \<langle>e'\<bullet>F{D}, s', b'\<rangle>"

| RedFAcc:
  "\<lbrakk> h a = Some(C,fs); fs(F,D) = Some v;
     P \<turnstile> C has F,NonStatic:t in D \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>F{D}, (h,l,sh), b\<rangle> \<rightarrow> \<langle>Val v,(h,l,sh),b\<rangle>"

| RedFAccNull:
  "P \<turnstile> \<langle>null\<bullet>F{D}, s, b\<rangle> \<rightarrow> \<langle>THROW NullPointer, s, b\<rangle>"

| RedFAccNone:
  "\<lbrakk> h a = Some(C,fs); \<not>(\<exists>b t. P \<turnstile> C has F,b:t in D) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>F{D},(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW NoSuchFieldError,(h,l,sh),b\<rangle>"

| RedFAccStatic:
  "\<lbrakk> h a = Some(C,fs); P \<turnstile> C has F,Static:t in D \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>F{D},(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW IncompatibleClassChangeError,(h,l,sh),b\<rangle>"

| RedSFAcc:
  "\<lbrakk> P \<turnstile> C has F,Static:t in D;
     sh D = Some (sfs,i);
     sfs F = Some v \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D},(h,l,sh),True\<rangle> \<rightarrow> \<langle>Val v,(h,l,sh),False\<rangle>"

| SFAccInitDoneRed:
  "\<lbrakk> P \<turnstile> C has F,Static:t in D;
     sh D = Some (sfs,Done) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D},(h,l,sh),False\<rangle> \<rightarrow> \<langle>C\<bullet>\<^sub>sF{D},(h,l,sh),True\<rangle>"

| SFAccInitRed:
  "\<lbrakk> P \<turnstile> C has F,Static:t in D;
     \<nexists>sfs. sh D = Some (sfs,Done) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D},(h,l,sh),False\<rangle> \<rightarrow> \<langle>INIT D ([D],False) \<leftarrow> C\<bullet>\<^sub>sF{D},(h,l,sh),False\<rangle>"

| RedSFAccNone:
  "\<not>(\<exists>b t. P \<turnstile> C has F,b:t in D)
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D},(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW NoSuchFieldError,(h,l,sh),False\<rangle>"

| RedSFAccNonStatic:
  "P \<turnstile> C has F,NonStatic:t in D
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D},(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW IncompatibleClassChangeError,(h,l,sh),False\<rangle>"

| FAssRed1:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<bullet>F{D}:=e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>e'\<bullet>F{D}:=e\<^sub>2, s', b'\<rangle>"

| FAssRed2:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>Val v\<bullet>F{D}:=e, s, b\<rangle> \<rightarrow> \<langle>Val v\<bullet>F{D}:=e', s', b'\<rangle>"

| RedFAss:
  "\<lbrakk> P \<turnstile> C has F,NonStatic:t in D; h a = Some(C,fs) \<rbrakk> \<Longrightarrow>
  P \<turnstile> \<langle>(addr a)\<bullet>F{D}:=(Val v), (h,l,sh), b\<rangle> \<rightarrow> \<langle>unit, (h(a \<mapsto> (C,fs((F,D) \<mapsto> v))),l,sh), b\<rangle>"

| RedFAssNull:
  "P \<turnstile> \<langle>null\<bullet>F{D}:=Val v, s, b\<rangle> \<rightarrow> \<langle>THROW NullPointer, s, b\<rangle>"

| RedFAssNone:
  "\<lbrakk> h a = Some(C,fs); \<not>(\<exists>b t. P \<turnstile> C has F,b:t in D) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>F{D}:=(Val v),(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW NoSuchFieldError,(h,l,sh),b\<rangle>"

| RedFAssStatic:
  "\<lbrakk> h a = Some(C,fs); P \<turnstile> C has F,Static:t in D \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>F{D}:=(Val v),(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW IncompatibleClassChangeError,(h,l,sh),b\<rangle>"

| SFAssRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D}:=e, s, b\<rangle> \<rightarrow> \<langle>C\<bullet>\<^sub>sF{D}:=e', s', b'\<rangle>"

| RedSFAss:
  "\<lbrakk> P \<turnstile> C has F,Static:t in D;
     sh D = Some(sfs,i);
     sfs' = sfs(F\<mapsto>v); sh' = sh(D\<mapsto>(sfs',i)) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D}:=(Val v),(h,l,sh),True\<rangle> \<rightarrow> \<langle>unit,(h,l,sh'),False\<rangle>"

| SFAssInitDoneRed:
  "\<lbrakk> P \<turnstile> C has F,Static:t in D;
     sh D = Some(sfs,Done) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D}:=(Val v),(h,l,sh),False\<rangle> \<rightarrow> \<langle>C\<bullet>\<^sub>sF{D}:=(Val v),(h,l,sh),True\<rangle>"

| SFAssInitRed:
  "\<lbrakk> P \<turnstile> C has F,Static:t in D;
     \<nexists>sfs. sh D = Some(sfs,Done) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D}:=(Val v),(h,l,sh),False\<rangle> \<rightarrow> \<langle>INIT D ([D],False)\<leftarrow> C\<bullet>\<^sub>sF{D}:=(Val v),(h,l,sh),False\<rangle>"

| RedSFAssNone:
  "\<not>(\<exists>b t. P \<turnstile> C has F,b:t in D)
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D}:=(Val v),s,b\<rangle> \<rightarrow> \<langle>THROW NoSuchFieldError,s,False\<rangle>"

| RedSFAssNonStatic:
  "P \<turnstile> C has F,NonStatic:t in D
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D}:=(Val v),s,b\<rangle> \<rightarrow> \<langle>THROW IncompatibleClassChangeError,s,False\<rangle>"

| CallObj:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e\<bullet>M(es),s,b\<rangle> \<rightarrow> \<langle>e'\<bullet>M(es),s',b'\<rangle>"

| CallParams:
  "P \<turnstile> \<langle>es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>(Val v)\<bullet>M(es),s,b\<rangle> \<rightarrow> \<langle>(Val v)\<bullet>M(es'),s',b'\<rangle>"

| RedCall:
  "\<lbrakk> h a = Some(C,fs); P \<turnstile> C sees M,NonStatic:Ts\<rightarrow>T = (pns,body) in D; size vs = size pns; size Ts = size pns \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>M(map Val vs), (h,l,sh), b\<rangle> \<rightarrow> \<langle>blocks(this#pns, Class D#Ts, Addr a#vs, body), (h,l,sh), b\<rangle>"

| RedCallNull:
  "P \<turnstile> \<langle>null\<bullet>M(map Val vs),s,b\<rangle> \<rightarrow> \<langle>THROW NullPointer,s,b\<rangle>"

| RedCallNone:
  "\<lbrakk> h a = Some(C,fs); \<not>(\<exists>b Ts T m D. P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in D) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>M(map Val vs),(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW NoSuchMethodError,(h,l,sh),b\<rangle>"

| RedCallStatic:
  "\<lbrakk> h a = Some(C,fs); P \<turnstile> C sees M,Static:Ts\<rightarrow>T = m in D \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>(addr a)\<bullet>M(map Val vs),(h,l,sh),b\<rangle> \<rightarrow> \<langle>THROW IncompatibleClassChangeError,(h,l,sh),b\<rangle>"

| SCallParams:
  "P \<turnstile> \<langle>es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>C\<bullet>\<^sub>sM(es),s,b\<rangle> \<rightarrow> \<langle>C\<bullet>\<^sub>sM(es'),s',b'\<rangle>"

| RedSCall:
  "\<lbrakk> P \<turnstile> C sees M,Static:Ts\<rightarrow>T = (pns,body) in D;
     length vs = length pns; size Ts = size pns \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sM(map Val vs),s,True\<rangle> \<rightarrow> \<langle>blocks(pns, Ts, vs, body), s, False\<rangle>"

| SCallInitDoneRed:
  "\<lbrakk> P \<turnstile> C sees M,Static:Ts\<rightarrow>T = (pns,body) in D;
     sh D = Some(sfs,Done) \<or> (M = clinit \<and> sh D = Some(sfs,Processing)) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sM(map Val vs),(h,l,sh), False\<rangle> \<rightarrow> \<langle>C\<bullet>\<^sub>sM(map Val vs),(h,l,sh), True\<rangle>"

| SCallInitRed:
  "\<lbrakk> P \<turnstile> C sees M,Static:Ts\<rightarrow>T = (pns,body) in D;
     \<nexists>sfs. sh D = Some(sfs,Done); M \<noteq> clinit \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sM(map Val vs),(h,l,sh), False\<rangle> \<rightarrow> \<langle>INIT D ([D],False) \<leftarrow> C\<bullet>\<^sub>sM(map Val vs),(h,l,sh),False\<rangle>"

| RedSCallNone:
  "\<lbrakk> \<not>(\<exists>b Ts T m D. P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in D) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sM(map Val vs),s,b\<rangle> \<rightarrow> \<langle>THROW NoSuchMethodError,s,False\<rangle>"

| RedSCallNonStatic:
  "\<lbrakk> P \<turnstile> C sees M,NonStatic:Ts\<rightarrow>T = m in D \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sM(map Val vs),s,b\<rangle> \<rightarrow> \<langle>THROW IncompatibleClassChangeError,s,False\<rangle>"

| BlockRedNone:
  "\<lbrakk> P \<turnstile> \<langle>e, (h,l(V:=None),sh), b\<rangle> \<rightarrow> \<langle>e', (h',l',sh'), b'\<rangle>; l' V = None; \<not> assigned V e \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>{V:T; e}, (h,l,sh), b\<rangle> \<rightarrow> \<langle>{V:T; e'}, (h',l'(V := l V),sh'), b'\<rangle>"

| BlockRedSome:
  "\<lbrakk> P \<turnstile> \<langle>e, (h,l(V:=None),sh), b\<rangle> \<rightarrow> \<langle>e', (h',l',sh'), b'\<rangle>; l' V = Some v;\<not> assigned V e \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>{V:T; e}, (h,l,sh), b\<rangle> \<rightarrow> \<langle>{V:T := Val v; e'}, (h',l'(V := l V),sh'), b'\<rangle>"

| InitBlockRed:
  "\<lbrakk> P \<turnstile> \<langle>e, (h,l(V\<mapsto>v),sh), b\<rangle> \<rightarrow> \<langle>e', (h',l',sh'), b'\<rangle>; l' V = Some v' \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>{V:T := Val v; e}, (h,l,sh), b\<rangle> \<rightarrow> \<langle>{V:T := Val v'; e'}, (h',l'(V := l V),sh'), b'\<rangle>"

| RedBlock:
  "P \<turnstile> \<langle>{V:T; Val u}, s, b\<rangle> \<rightarrow> \<langle>Val u, s, b\<rangle>"

| RedInitBlock:
  "P \<turnstile> \<langle>{V:T := Val v; Val u}, s, b\<rangle> \<rightarrow> \<langle>Val u, s, b\<rangle>"

| SeqRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e;;e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>e';;e\<^sub>2, s', b'\<rangle>"

| RedSeq:
  "P \<turnstile> \<langle>(Val v);;e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>e\<^sub>2, s, b\<rangle>"

| CondRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>if (e) e\<^sub>1 else e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>if (e') e\<^sub>1 else e\<^sub>2, s', b'\<rangle>"

| RedCondT:
  "P \<turnstile> \<langle>if (true) e\<^sub>1 else e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>e\<^sub>1, s, b\<rangle>"

| RedCondF:
  "P \<turnstile> \<langle>if (false) e\<^sub>1 else e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>e\<^sub>2, s, b\<rangle>"

| RedWhile:
  "P \<turnstile> \<langle>while(b) c, s, b'\<rangle> \<rightarrow> \<langle>if(b) (c;;while(b) c) else unit, s, b'\<rangle>"

| ThrowRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>throw e, s, b\<rangle> \<rightarrow> \<langle>throw e', s', b'\<rangle>"

| RedThrowNull:
  "P \<turnstile> \<langle>throw null, s, b\<rangle> \<rightarrow> \<langle>THROW NullPointer, s, b\<rangle>"

| TryRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>try e catch(C V) e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>try e' catch(C V) e\<^sub>2, s', b'\<rangle>"

| RedTry:
  "P \<turnstile> \<langle>try (Val v) catch(C V) e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>Val v, s, b\<rangle>"

| RedTryCatch:
  "\<lbrakk> hp s a = Some(D,fs); P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>try (Throw a) catch(C V) e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>{V:Class C := addr a; e\<^sub>2}, s, b\<rangle>"

| RedTryFail:
  "\<lbrakk> hp s a = Some(D,fs); \<not> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>try (Throw a) catch(C V) e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>Throw a, s, b\<rangle>"

| ListRed1:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>e#es,s,b\<rangle> [\<rightarrow>] \<langle>e'#es,s',b'\<rangle>"

| ListRed2:
  "P \<turnstile> \<langle>es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>Val v # es,s,b\<rangle> [\<rightarrow>] \<langle>Val v # es',s',b'\<rangle>"

\<comment> \<open>Initialization procedure\<close>

| RedInit:
  "\<not>sub_RI e \<Longrightarrow> P \<turnstile> \<langle>INIT C (Nil,b) \<leftarrow> e,s,b'\<rangle> \<rightarrow> \<langle>e,s,icheck P C e\<rangle>"

| InitNoneRed:
  "sh C = None
  \<Longrightarrow> P \<turnstile> \<langle>INIT C' (C#Cs,False) \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>INIT C' (C#Cs,False) \<leftarrow> e,(h,l,sh(C \<mapsto> (sblank P C, Prepared))),b\<rangle>"

| RedInitDone:
  "sh C = Some(sfs,Done)
  \<Longrightarrow> P \<turnstile> \<langle>INIT C' (C#Cs,False) \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>INIT C' (Cs,True) \<leftarrow> e,(h,l,sh),b\<rangle>"

| RedInitProcessing:
  "sh C = Some(sfs,Processing)
  \<Longrightarrow> P \<turnstile> \<langle>INIT C' (C#Cs,False) \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>INIT C' (Cs,True) \<leftarrow> e,(h,l,sh),b\<rangle>"

| RedInitError:
  "sh C = Some(sfs,Error)
  \<Longrightarrow> P \<turnstile> \<langle>INIT C' (C#Cs,False) \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>RI (C,THROW NoClassDefFoundError);Cs \<leftarrow> e,(h,l,sh),b\<rangle>"

| InitObjectRed:
  "\<lbrakk> sh C = Some(sfs,Prepared);
     C = Object;
     sh' = sh(C \<mapsto> (sfs,Processing)) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>INIT C' (C#Cs,False) \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>INIT C' (C#Cs,True) \<leftarrow> e,(h,l,sh'),b\<rangle>"

| InitNonObjectSuperRed:
  "\<lbrakk> sh C = Some(sfs,Prepared);
     C \<noteq> Object;
     class P C = Some (D,r);
     sh' = sh(C \<mapsto> (sfs,Processing)) \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<langle>INIT C' (C#Cs,False) \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>INIT C' (D#C#Cs,False) \<leftarrow> e,(h,l,sh'),b\<rangle>"

| RedInitRInit:
  "P \<turnstile> \<langle>INIT C' (C#Cs,True) \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>RI (C,C\<bullet>\<^sub>sclinit([]));Cs \<leftarrow> e,(h,l,sh),b\<rangle>"

| RInitRed:
  "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle> \<Longrightarrow>
  P \<turnstile> \<langle>RI (C,e);Cs \<leftarrow> e\<^sub>0, s, b\<rangle> \<rightarrow> \<langle>RI (C,e');Cs \<leftarrow> e\<^sub>0, s', b'\<rangle>"

| RedRInit:
  "\<lbrakk> sh C = Some (sfs, i);
     sh' = sh(C \<mapsto> (sfs,Done));
     C' = last(C#Cs) \<rbrakk> \<Longrightarrow>
  P \<turnstile> \<langle>RI (C, Val v);Cs \<leftarrow> e, (h,l,sh), b\<rangle> \<rightarrow> \<langle>INIT C' (Cs,True) \<leftarrow> e, (h,l,sh'), b\<rangle>"

\<comment> \<open>Exception propagation\<close>

| CastThrow: "P \<turnstile> \<langle>Cast C (throw e), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| BinOpThrow1: "P \<turnstile> \<langle>(throw e) \<guillemotleft>bop\<guillemotright> e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| BinOpThrow2: "P \<turnstile> \<langle>(Val v\<^sub>1) \<guillemotleft>bop\<guillemotright> (throw e), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| LAssThrow: "P \<turnstile> \<langle>V:=(throw e), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| FAccThrow: "P \<turnstile> \<langle>(throw e)\<bullet>F{D}, s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| FAssThrow1: "P \<turnstile> \<langle>(throw e)\<bullet>F{D}:=e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| FAssThrow2: "P \<turnstile> \<langle>Val v\<bullet>F{D}:=(throw e), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| SFAssThrow: "P \<turnstile> \<langle>C\<bullet>\<^sub>sF{D}:=(throw e), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| CallThrowObj: "P \<turnstile> \<langle>(throw e)\<bullet>M(es), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| CallThrowParams: "\<lbrakk> es = map Val vs @ throw e # es' \<rbrakk> \<Longrightarrow> P \<turnstile> \<langle>(Val v)\<bullet>M(es), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| SCallThrowParams: "\<lbrakk> es = map Val vs @ throw e # es' \<rbrakk> \<Longrightarrow> P \<turnstile> \<langle>C\<bullet>\<^sub>sM(es), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| BlockThrow: "P \<turnstile> \<langle>{V:T; Throw a}, s, b\<rangle> \<rightarrow> \<langle>Throw a, s, b\<rangle>"
| InitBlockThrow: "P \<turnstile> \<langle>{V:T := Val v; Throw a}, s, b\<rangle> \<rightarrow> \<langle>Throw a, s, b\<rangle>"
| SeqThrow: "P \<turnstile> \<langle>(throw e);;e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| CondThrow: "P \<turnstile> \<langle>if (throw e) e\<^sub>1 else e\<^sub>2, s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| ThrowThrow: "P \<turnstile> \<langle>throw(throw e), s, b\<rangle> \<rightarrow> \<langle>throw e, s, b\<rangle>"
| RInitInitThrow: "\<lbrakk> sh C = Some(sfs,i); sh' = sh(C \<mapsto> (sfs,Error)) \<rbrakk> \<Longrightarrow>
  P \<turnstile> \<langle>RI (C,Throw a);D#Cs \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>RI (D,Throw a);Cs \<leftarrow> e,(h,l,sh'),b\<rangle>"
| RInitThrow: "\<lbrakk> sh C = Some(sfs, i); sh' = sh(C \<mapsto> (sfs,Error)) \<rbrakk> \<Longrightarrow>
  P \<turnstile> \<langle>RI (C,Throw a);Nil \<leftarrow> e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>Throw a,(h,l,sh'),b\<rangle>"
(*<*)
lemmas red_reds_induct = red_reds.induct [split_format (complete)]
  and red_reds_inducts = red_reds.inducts [split_format (complete)]

inductive_cases [elim!]:
 "P \<turnstile> \<langle>V:=e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle>"
 "P \<turnstile> \<langle>e1;;e2,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle>"
(*>*)

subsection\<open> The reflexive transitive closure \<close>

abbreviation
  Step :: "J_prog \<Rightarrow> expr \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> expr \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool"
          ("_ \<turnstile> ((1\<langle>_,/_,/_\<rangle>) \<rightarrow>*/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81)
  where "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow>* \<langle>e',s',b'\<rangle> \<equiv> ((e,s,b), e',s',b') \<in> (red P)\<^sup>*"

abbreviation
  Steps :: "J_prog \<Rightarrow> expr list \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> expr list \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool"
          ("_ \<turnstile> ((1\<langle>_,/_,/_\<rangle>) [\<rightarrow>]*/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81)
  where "P \<turnstile> \<langle>es,s,b\<rangle> [\<rightarrow>]* \<langle>es',s',b'\<rangle> \<equiv> ((es,s,b), es',s',b') \<in> (reds P)\<^sup>*"

lemmas converse_rtrancl_induct3 =
  converse_rtrancl_induct [of "(ax, ay, az)" "(bx, by, bz)", split_format (complete),
    consumes 1, case_names refl step]

lemma converse_rtrancl_induct_red[consumes 1]:
assumes "P \<turnstile> \<langle>e,(h,l,sh),b\<rangle> \<rightarrow>* \<langle>e',(h',l',sh'),b'\<rangle>"
and "\<And>e h l sh b. R e h l sh b e h l sh b"
and "\<And>e\<^sub>0 h\<^sub>0 l\<^sub>0 sh\<^sub>0 b\<^sub>0 e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 b\<^sub>1 e' h' l' sh' b'.
       \<lbrakk> P \<turnstile> \<langle>e\<^sub>0,(h\<^sub>0,l\<^sub>0,sh\<^sub>0),b\<^sub>0\<rangle> \<rightarrow> \<langle>e\<^sub>1,(h\<^sub>1,l\<^sub>1,sh\<^sub>1),b\<^sub>1\<rangle>; R e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 b\<^sub>1 e' h' l' sh' b' \<rbrakk>
   \<Longrightarrow> R e\<^sub>0 h\<^sub>0 l\<^sub>0 sh\<^sub>0 b\<^sub>0 e' h' l' sh' b'"
shows "R e h l sh b e' h' l' sh' b'"
(*<*)
proof -
  { fix s s'
    assume reds: "P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow>* \<langle>e',s',b'\<rangle>"
       and base: "\<And>e s b. R e (hp s) (lcl s) (shp s) b e (hp s) (lcl s) (shp s) b"
       and red\<^sub>1: "\<And>e\<^sub>0 s\<^sub>0 b\<^sub>0 e\<^sub>1 s\<^sub>1 b\<^sub>1 e' s' b'.
           \<lbrakk> P \<turnstile> \<langle>e\<^sub>0,s\<^sub>0,b\<^sub>0\<rangle> \<rightarrow> \<langle>e\<^sub>1,s\<^sub>1,b\<^sub>1\<rangle>; R e\<^sub>1 (hp s\<^sub>1) (lcl s\<^sub>1) (shp s\<^sub>1) b\<^sub>1 e' (hp s') (lcl s') (shp s') b' \<rbrakk>
           \<Longrightarrow> R e\<^sub>0 (hp s\<^sub>0) (lcl s\<^sub>0) (shp s\<^sub>0) b\<^sub>0 e' (hp s') (lcl s') (shp s') b'"
    from reds have "R e (hp s) (lcl s) (shp s) b e' (hp s') (lcl s') (shp s') b'"
    proof (induct rule:converse_rtrancl_induct3)
      case refl show ?case by(rule base)
    next
      case step
      thus ?case by(blast intro:red\<^sub>1)
    qed
    }
  with assms show ?thesis by fastforce
qed
(*>*)

subsection\<open>Some easy lemmas\<close>

lemma [iff]: "\<not> P \<turnstile> \<langle>Val v,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle>"
(*<*)by(fastforce elim: red.cases)(*>*)

lemma val_no_step: "val_of e = \<lfloor>v\<rfloor> \<Longrightarrow> \<not> P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle>"
(*<*)by(drule val_of_spec, simp)(*>*)

lemma [iff]: "\<not> P \<turnstile> \<langle>Throw a,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle>"
(*<*)by(fastforce elim: red.cases)(*>*)

lemma map_Vals_no_step [iff]: "\<not> P \<turnstile> \<langle>map Val vs,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle>"
(*<*)
proof(induct vs arbitrary: es')
  case (Cons a vs)
  { assume "P \<turnstile> \<langle>map Val (a # vs),s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle>"
    then have False by(rule reds.cases) (insert Cons, auto)
  }
  then show ?case by clarsimp
qed simp
(*>*)

lemma vals_no_step: "map_vals_of es = \<lfloor>vs\<rfloor> \<Longrightarrow> \<not> P \<turnstile> \<langle>es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle>"
(*<*)by(drule map_vals_of_spec, simp)(*>*)

lemma vals_throw_no_step [iff]: "\<not> P \<turnstile> \<langle>map Val vs @ Throw a # es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle>"
(*<*)
proof(induct vs arbitrary: es')
  case Nil
  { assume "P \<turnstile> \<langle>Throw a # es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle>"
    then have False by(rule reds.cases) (insert Cons, auto)
  }
  then show ?case by clarsimp
next
  case (Cons a' vs')
  { assume "P \<turnstile> \<langle>map Val (a'#vs') @ Throw a # es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle>"
    then have False by(rule reds.cases) (insert Cons, auto)
  }
  then show ?case by clarsimp
qed
(*>*)

lemma lass_val_of_red:
 "\<lbrakk> lass_val_of e = \<lfloor>a\<rfloor>; P \<turnstile> \<langle>e,(h, l, sh),b\<rangle> \<rightarrow> \<langle>e',(h', l', sh'),b'\<rangle> \<rbrakk>
  \<Longrightarrow> e' = unit \<and> h' = h \<and> l' = l(fst a\<mapsto>snd a) \<and> sh' = sh \<and> b = b'"
(*<*)by(drule lass_val_of_spec, auto)(*>*)

lemma final_no_step [iff]: "final e \<Longrightarrow> \<not> P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow> \<langle>e',s',b'\<rangle>"
(*<*)by(erule finalE, simp+)(*>*)

lemma finals_no_step [iff]: "finals es \<Longrightarrow> \<not> P \<turnstile> \<langle>es,s,b\<rangle> [\<rightarrow>] \<langle>es',s',b'\<rangle>"
(*<*)by(erule finalsE, simp+)(*>*)

lemma reds_final_same:
"P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow>* \<langle>e',s',b'\<rangle> \<Longrightarrow> final e \<Longrightarrow> e = e' \<and> s = s' \<and> b = b'"
proof(induct rule:converse_rtrancl_induct3)
  case refl show ?case by simp
next
  case (step e0 s0 b0 e1 s1 b1) show ?case
  proof(rule finalE[OF step.prems(1)])
    fix v assume "e0 = Val v" then show ?thesis using step by simp
  next
    fix a assume "e0 = Throw a" then show ?thesis using step by simp
  qed
qed

lemma reds_throw:
"P \<turnstile> \<langle>e,s,b\<rangle> \<rightarrow>* \<langle>e',s',b'\<rangle> \<Longrightarrow> (\<And>e\<^sub>t. throw_of e = \<lfloor>e\<^sub>t\<rfloor> \<Longrightarrow> \<exists>e\<^sub>t'. throw_of e' = \<lfloor>e\<^sub>t'\<rfloor>)"
proof(induct rule:converse_rtrancl_induct3)
  case refl then show ?case by simp
next
  case (step e0 s0 b0 e1 s1 b1)
  then show ?case by(auto elim: red.cases)
qed

lemma red_hext_incr: "P \<turnstile> \<langle>e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>e',(h',l',sh'),b'\<rangle>  \<Longrightarrow> h \<unlhd> h'"
  and reds_hext_incr: "P \<turnstile> \<langle>es,(h,l,sh),b\<rangle> [\<rightarrow>] \<langle>es',(h',l',sh'),b'\<rangle>  \<Longrightarrow> h \<unlhd> h'"
(*<*)
proof(induct rule:red_reds_inducts)
  case RedNew thus ?case
    by(fastforce dest:new_Addr_SomeD simp:hext_def split:if_splits)
next
  case RedFAss thus ?case by(simp add:hext_def split:if_splits)
qed simp_all
(*>*)

lemma red_lcl_incr: "P \<turnstile> \<langle>e,(h\<^sub>0,l\<^sub>0,sh\<^sub>0),b\<rangle> \<rightarrow> \<langle>e',(h\<^sub>1,l\<^sub>1,sh\<^sub>1),b'\<rangle> \<Longrightarrow> dom l\<^sub>0 \<subseteq> dom l\<^sub>1"
and reds_lcl_incr: "P \<turnstile> \<langle>es,(h\<^sub>0,l\<^sub>0,sh\<^sub>0),b\<rangle> [\<rightarrow>] \<langle>es',(h\<^sub>1,l\<^sub>1,sh\<^sub>1),b'\<rangle> \<Longrightarrow> dom l\<^sub>0 \<subseteq> dom l\<^sub>1"
(*<*)by(induct rule: red_reds_inducts)(auto simp del:fun_upd_apply)(*>*)

lemma red_lcl_add: "P \<turnstile> \<langle>e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>e',(h',l',sh'),b'\<rangle> \<Longrightarrow> (\<And>l\<^sub>0. P \<turnstile> \<langle>e,(h,l\<^sub>0++l,sh),b\<rangle> \<rightarrow> \<langle>e',(h',l\<^sub>0++l',sh'),b'\<rangle>)"
and reds_lcl_add: "P \<turnstile> \<langle>es,(h,l,sh),b\<rangle> [\<rightarrow>] \<langle>es',(h',l',sh'),b'\<rangle> \<Longrightarrow> (\<And>l\<^sub>0. P \<turnstile> \<langle>es,(h,l\<^sub>0++l,sh),b\<rangle> [\<rightarrow>] \<langle>es',(h',l\<^sub>0++l',sh'),b'\<rangle>)"
(*<*)
proof (induct rule:red_reds_inducts)
  case RedCast thus ?case by(fastforce intro:red_reds.intros)
next
  case RedCastFail thus ?case by(force intro:red_reds.intros)
next
  case RedFAcc thus ?case by(fastforce intro:red_reds.intros)
next
  case RedCall thus ?case by(fastforce intro:red_reds.intros)
next
  case (InitBlockRed e h l V v sh b e' h' l' sh' b' v' T l\<^sub>0)
  have IH: "\<And>l\<^sub>0. P \<turnstile> \<langle>e,(h, l\<^sub>0 ++ l(V \<mapsto> v), sh),b\<rangle> \<rightarrow> \<langle>e',(h', l\<^sub>0 ++ l', sh'),b'\<rangle>"
    and l'V: "l' V = Some v'" by fact+
  from IH have IH': "P \<turnstile> \<langle>e,(h, (l\<^sub>0 ++ l)(V \<mapsto> v), sh),b\<rangle> \<rightarrow> \<langle>e',(h', l\<^sub>0 ++ l', sh'),b'\<rangle>"
    by simp
  have "(l\<^sub>0 ++ l')(V := (l\<^sub>0 ++ l) V) = l\<^sub>0 ++ l'(V := l V)"
    by(rule ext)(simp add:map_add_def)
  with red_reds.InitBlockRed[OF IH'] l'V show ?case by(simp del:fun_upd_apply)
next
  case (BlockRedNone e h l V sh b e' h' l' sh' b' T l\<^sub>0)
  have IH: "\<And>l\<^sub>0. P \<turnstile> \<langle>e,(h, l\<^sub>0 ++ l(V := None), sh),b\<rangle> \<rightarrow> \<langle>e',(h', l\<^sub>0 ++ l', sh'),b'\<rangle>"
    and l'V: "l' V = None" and unass: "\<not> assigned V e" by fact+
  have "l\<^sub>0(V := None) ++ l(V := None) = (l\<^sub>0 ++ l)(V := None)"
    by(simp add:fun_eq_iff map_add_def)
  hence IH': "P \<turnstile> \<langle>e,(h, (l\<^sub>0++l)(V := None), sh),b\<rangle> \<rightarrow> \<langle>e',(h', l\<^sub>0(V := None) ++ l', sh'),b'\<rangle>"
    using IH[of "l\<^sub>0(V := None)"] by simp
  have "(l\<^sub>0(V := None) ++ l')(V := (l\<^sub>0 ++ l) V) = l\<^sub>0 ++ l'(V := l V)"
    by(simp add:fun_eq_iff map_add_def)
  with red_reds.BlockRedNone[OF IH' _ unass] l'V show ?case
    by(simp add: map_add_def)
next
  case (BlockRedSome e h l V sh b e' h' l' sh' b' v T l\<^sub>0)
  have IH: "\<And>l\<^sub>0. P \<turnstile> \<langle>e,(h, l\<^sub>0 ++ l(V := None), sh),b\<rangle> \<rightarrow> \<langle>e',(h', l\<^sub>0 ++ l', sh'),b'\<rangle>"
    and l'V: "l' V = Some v" and unass: "\<not> assigned V e" by fact+
  have "l\<^sub>0(V := None) ++ l(V := None) = (l\<^sub>0 ++ l)(V := None)"
    by(simp add:fun_eq_iff map_add_def)
  hence IH': "P \<turnstile> \<langle>e,(h, (l\<^sub>0++l)(V := None), sh),b\<rangle> \<rightarrow> \<langle>e',(h', l\<^sub>0(V := None) ++ l', sh'),b'\<rangle>"
    using IH[of "l\<^sub>0(V := None)"] by simp
  have "(l\<^sub>0(V := None) ++ l')(V := (l\<^sub>0 ++ l) V) = l\<^sub>0 ++ l'(V := l V)"
    by(simp add:fun_eq_iff map_add_def)
  with red_reds.BlockRedSome[OF IH' _ unass] l'V show ?case
    by(simp add:map_add_def)
next
  case RedTryCatch thus ?case by(fastforce intro:red_reds.intros)
next
  case RedTryFail thus ?case by(force intro!:red_reds.intros)
qed (simp_all add:red_reds.intros)
(*>*)

lemma Red_lcl_add:
assumes "P \<turnstile> \<langle>e,(h,l,sh), b\<rangle> \<rightarrow>* \<langle>e',(h',l',sh'), b'\<rangle>" shows "P \<turnstile> \<langle>e,(h,l\<^sub>0++l,sh),b\<rangle> \<rightarrow>* \<langle>e',(h',l\<^sub>0++l',sh'),b'\<rangle>"
(*<*)
using assms
proof(induct rule:converse_rtrancl_induct_red)
  case 1 thus ?case by simp
next
  case 2 thus ?case
    by (blast dest: red_lcl_add intro: converse_rtrancl_into_rtrancl)
qed
(*>*)

lemma assumes wf: "wwf_J_prog P"
shows red_proc_pres: "P \<turnstile> \<langle>e,(h,l,sh),b\<rangle> \<rightarrow> \<langle>e',(h',l',sh'),b'\<rangle>
  \<Longrightarrow> not_init C e \<Longrightarrow> sh C = \<lfloor>(sfs, Processing)\<rfloor> \<Longrightarrow> not_init C e' \<and> (\<exists>sfs'. sh' C = \<lfloor>(sfs', Processing)\<rfloor>)"
  and reds_proc_pres: "P \<turnstile> \<langle>es,(h,l,sh),b\<rangle> [\<rightarrow>] \<langle>es',(h',l',sh'),b'\<rangle>
  \<Longrightarrow> not_inits C es \<Longrightarrow> sh C = \<lfloor>(sfs, Processing)\<rfloor> \<Longrightarrow> not_inits C es' \<and> (\<exists>sfs'. sh' C = \<lfloor>(sfs', Processing)\<rfloor>)"
(*<*)
proof(induct rule:red_reds_inducts)
  case RedCall then show ?case
  using sees_wwf_nsub_RI[OF wf RedCall.hyps(2)] sub_RI_blocks_body nsub_RI_not_init by auto
next
  case RedSCall then show ?case
  using sees_wwf_nsub_RI[OF wf RedSCall.hyps(1)] sub_RI_blocks_body nsub_RI_not_init by auto
next
  case (RedInitDone sh C sfs C' Cs e h l b)
  then show ?case by(cases Cs, auto)
next
  case (RedInitProcessing sh C sfs C' Cs e h l b)
  then show ?case by(cases Cs, auto)
next
  case (RedRInit sh C sfs i sh' C' Cs v e h l b)
  then show ?case by(cases Cs, auto)
next
  case (CallThrowParams es vs e es' v M h l sh b)
  then show ?case by(auto dest: not_inits_def')
next
  case (SCallThrowParams es vs e es' C M h l sh b)
  then show ?case by(auto dest: not_inits_def')
qed(auto)

end


(*  Title:      HOL/HOLCF/IOA/Storage/Correctness.thy
    Author:     Olaf Müller
*)

section \<open>Correctness Proof\<close>

theory Correctness
imports "../SimCorrectness" Spec Impl
begin

default_sort type

definition
  sim_relation :: "((nat * bool) * (nat set * bool)) set" where
  "sim_relation = {qua. let c = fst qua; a = snd qua ;
                            k = fst c;   b = snd c;
                            used = fst a; c = snd a
                        in
                        (! l:used. l < k) & b=c}"

declare split_paired_Ex [simp del]

(* Idea: instead of impl_con_lemma do not rewrite impl_ioa, but derive
         simple lemmas asig_of impl_ioa = impl_sig, trans_of impl_ioa = impl_trans
   Idea: ?ex. move .. should be generally replaced by a step via a subst tac if desired,
         as this can be done globally *)

lemma issimulation:
      "is_simulation sim_relation impl_ioa spec_ioa"
apply (simp (no_asm) add: is_simulation_def)
apply (rule conjI)
txt \<open>start states\<close>
apply (auto)[1]
apply (rule_tac x = " ({},False) " in exI)
apply (simp add: sim_relation_def starts_of_def spec_ioa_def impl_ioa_def)
txt \<open>main-part\<close>
apply (rule allI)+
apply (rule imp_conj_lemma)
apply (rename_tac k b used c k' b' a)
apply (induct_tac "a")
apply (simp_all (no_asm) add: sim_relation_def impl_ioa_def impl_trans_def trans_of_def)
apply auto
txt \<open>NEW\<close>
apply (rule_tac x = "(used,True)" in exI)
apply simp
apply (rule transition_is_ex)
apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
txt \<open>LOC\<close>
apply (rule_tac x = " (used Un {k},False) " in exI)
apply (simp add: less_SucI)
apply (rule transition_is_ex)
apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
apply fast
txt \<open>FREE\<close>
apply (rename_tac nat, rule_tac x = " (used - {nat},c) " in exI)
apply simp
apply (rule transition_is_ex)
apply (simp (no_asm) add: spec_ioa_def spec_trans_def trans_of_def)
done

lemma implementation:
"impl_ioa =<| spec_ioa"
apply (unfold ioa_implements_def)
apply (rule conjI)
apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
  asig_outputs_def asig_of_def asig_inputs_def)
apply (rule trace_inclusion_for_simulations)
apply (simp (no_asm) add: impl_sig_def spec_sig_def impl_ioa_def spec_ioa_def
  externals_def asig_outputs_def asig_of_def asig_inputs_def)
apply (rule issimulation)
done

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: utp_circus_prel.thy                                                  *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 18 Sep 2017 *)

section {* {\Circus} Preliminaries *}

theory utp_circus_prel
imports utp_theories_deep
begin

text {* Hide HOL's @{typ "'a rel"} type once again. *}

text {* TODO: The recall package ought to hide type syntax too! *}

hide_type (open) Relation.rel

type_synonym 'a hol_rel = "'a Relation.rel"

translations (type) "'a hol_rel" \<rightleftharpoons> (type)"'a Relation.rel"

subsection {* Syntax Adjustments *}

no_translations
  "a \<^bold>\<rightarrow> P" == "CONST PrefixCSP \<guillemotleft>a\<guillemotright> P"

translations
  "a \<^bold>\<rightarrow> P" == "CONST PrefixCSP \<guillemotleft>a()\<guillemotright> P"

subsection {* Channel Events *}

text {*
  The @{text "\<epsilon>(c)"} operator defined below yields the possible events for some
  channel @{text c}. It is useful to construct synchronisation sets of parallel
  compositions, for instance.
*}

definition events :: "('a, '\<epsilon>) chan \<Rightarrow> '\<epsilon> set" ("\<epsilon>'(_')") where
"events c = c ` UNIV"

subsection {* Proof Support *}

declare des_vars.extend_def [lens_defs]
declare des_vars.truncate_def [lens_defs]
declare rp_vars.extend_def [lens_defs]
declare rp_vars.truncate_def [lens_defs]
declare rsp_vars.extend_def [lens_defs]
declare rsp_vars.truncate_def [lens_defs]
declare csp_vars.extend_def [lens_defs]
declare csp_vars.truncate_def [lens_defs]

subsection {* State Hiding *}

text {* Note that the following lemma does not hold! *}

lemma hide_state_ex_cancel [simp]:
"abs_st (\<exists> {$st,$st\<acute>} \<bullet> P) = abs_st P"
apply (rel_auto)
oops

text \<open>Laws for the pre-, peri- and postcondition of @{const abs_st}\<close>

lemma pre\<^sub>R_abs_st [rdes]:
"pre\<^sub>R(abs_st P) = abs_st(pre\<^sub>R(P))"
apply (rel_auto)
done

lemma peri\<^sub>R_abs_st [rdes]:
"peri\<^sub>R(abs_st P) = abs_st(peri\<^sub>R(P))"
apply (rel_auto)
done

lemma post\<^sub>R_abs_st [rdes]:
"post\<^sub>R(abs_st P) = abs_st(post\<^sub>R(P))"
apply (rel_auto)
done

text \<open>Closure Laws\<close>

lemma abs_st_CSP_closure [closure]:
"P is CSP \<Longrightarrow> abs_st (\<exists> {$st, $st\<acute>} \<bullet> P) is CSP"
  by (metis SRD_state_srea state_srea_def)

subsection {* Instantiations *}

text {* Move this to the theory @{theory utp_dvar}. [TODO] *}

instantiation vstore :: vst
begin
definition vstore_lens_vstore :: "vstore \<Longrightarrow> vstore" where
"vstore_lens_vstore = 1\<^sub>L"
instance
apply (intro_classes)
apply (unfold vstore_lens_vstore_def)
apply (rule id_vwb_lens)
done
end
end


(*  Title:       CoreC++

    Author:      Tobias Nipkow, Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>
*)

header {* \isaheader{Well-formedness Constraints} *}

theory CWellForm imports WellForm WWellForm WellTypeRT DefAss begin

definition wf_C_mdecl :: "prog \<Rightarrow> cname \<Rightarrow> mdecl \<Rightarrow> bool" where
  "wf_C_mdecl P C \<equiv>  \<lambda>(M,Ts,T,(pns,body)).
  length Ts = length pns \<and>
  distinct pns \<and>
  this \<notin> set pns \<and>
  P,[this\<mapsto>Class C,pns[\<mapsto>]Ts] \<turnstile> body :: T \<and>
  \<D> body \<lfloor>{this} \<union> set pns\<rfloor>"

lemma wf_C_mdecl[simp]:
  "wf_C_mdecl P C (M,Ts,T,pns,body) \<equiv>
  (length Ts = length pns \<and>
  distinct pns \<and>
  this \<notin> set pns \<and>
  P,[this\<mapsto>Class C,pns[\<mapsto>]Ts] \<turnstile> body :: T \<and>
  \<D> body \<lfloor>{this} \<union> set pns\<rfloor>)"
by(simp add:wf_C_mdecl_def)

abbreviation
  wf_C_prog :: "prog \<Rightarrow> bool" where
  "wf_C_prog ==  wf_prog wf_C_mdecl"

lemma wf_C_prog_wf_C_mdecl:
  "\<lbrakk> wf_C_prog P; (C,Bs,fs,ms) \<in> set P; m \<in> set ms \<rbrakk>
  \<Longrightarrow> wf_C_mdecl P C m"

apply (simp add: wf_prog_def)
apply (simp add: wf_cdecl_def)
apply (erule conjE)+
apply (drule bspec, assumption)
apply simp
apply (erule conjE)+
apply (drule bspec, assumption)
apply (simp add: wf_mdecl_def split_beta)
done

lemma wf_prog_wwf_prog: "wf_C_prog P \<Longrightarrow> wwf_prog P"

apply(simp add:wf_prog_def wf_cdecl_def wf_mdecl_def)
apply(fast intro:wf_mdecl_wwf_mdecl)
done

end