theory Incredible_Correctness
imports
  Abstract_Rules_To_Incredible
  Natural_Deduction
begin

text \<open>
In this theory, we prove that if we have a graph that proves a given abstract task (which is
represented as the context @{term Tasked_Proof_Graph}), then we can prove @{term solved}.
\<close>

context Tasked_Proof_Graph
begin

definition adjacentTo :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex \<times> ('form, 'var) out_port)" where
 "adjacentTo v p = (SOME ps. (ps, (v,p)) \<in> edges)"

fun isReg where
  "isReg v p = (case p of Hyp h c \<Rightarrow> False | Reg  c \<Rightarrow>
      (case nodeOf v of
        Conclusion a \<Rightarrow> False
      | Assumption a \<Rightarrow> False
      | Rule r \<Rightarrow> True
      | Helper \<Rightarrow> True
      ))"

fun toNatRule  where
  "toNatRule v p = (case p of Hyp h c \<Rightarrow> Axiom | Reg  c \<Rightarrow>
      (case nodeOf v of
        Conclusion a \<Rightarrow> Axiom \<comment> \<open>a lie\<close>
      | Assumption a \<Rightarrow> Axiom
      | Rule r \<Rightarrow> NatRule (r,c)
      | Helper \<Rightarrow> Cut
      ))"

inductive_set global_assms' :: "'var itself \<Rightarrow> 'form set" for i  where
  "v |\<in>| vertices \<Longrightarrow> nodeOf v = Assumption p \<Longrightarrow> labelAtOut v (Reg p) \<in> global_assms' i"

lemma finite_global_assms': "finite (global_assms' i)"
proof-
  have "finite (fset vertices)" by (rule finite_fset)
  moreover
  have "global_assms' i \<subseteq> (\<lambda> v. case nodeOf v of Assumption p \<Rightarrow>  labelAtOut v (Reg p)) ` fset vertices"
    by (force simp add: global_assms'.simps fmember.rep_eq image_iff )
  ultimately
  show ?thesis by (rule finite_surj)
qed

context includes fset.lifting
begin
  lift_definition global_assms :: "'var itself \<Rightarrow> 'form fset" is global_assms' by (rule finite_global_assms')
  lemmas global_assmsI = global_assms'.intros[Transfer.transferred]
  lemmas global_assms_simps = global_assms'.simps[Transfer.transferred]
end

fun extra_assms :: "('vertex \<times> ('form, 'var) in_port) \<Rightarrow> 'form fset" where
  "extra_assms (v, p) = (\<lambda> p. labelAtOut v p) |`| hyps_for (nodeOf v) p"

fun hyps_along :: "('vertex, 'form, 'var) edge' list \<Rightarrow> 'form fset" where
  "hyps_along pth = ffUnion (extra_assms |`| snd |`| fset_from_list pth) |\<union>| global_assms TYPE('var)"

lemma hyps_alongE[consumes 1, case_names Hyp Assumption]:
  assumes "f |\<in>| hyps_along pth"
  obtains v p h where "(v,p) \<in> snd ` set pth" and "f = labelAtOut v h " and "h |\<in>| hyps_for (nodeOf v) p"
  | v pf  where "v |\<in>| vertices" and "nodeOf v = Assumption pf" "f = labelAtOut v (Reg pf)"
  using assms
  apply (auto simp add: fmember.rep_eq ffUnion.rep_eq  global_assms_simps[unfolded fmember.rep_eq])
  apply (metis image_iff snd_conv)
  done

text \<open>Here we build the natural deduction tree, by walking the graph.\<close>

primcorec tree :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex, 'form, 'var) edge' list \<Rightarrow>  (('form entailment), ('rule \<times> 'form) NatRule) dtree" where
 "root (tree v p pth) =
    ((hyps_along ((adjacentTo v p,(v,p))#pth) \<turnstile> labelAtIn v p),
    (case adjacentTo v p of (v', p') \<Rightarrow> toNatRule v' p'
    ))"
 | "cont (tree v p pth) =
    (case adjacentTo v p of (v', p') \<Rightarrow>
    (if isReg v' p' then ((\<lambda> p''. tree v' p'' ((adjacentTo v p,(v,p))#pth)) |`| inPorts (nodeOf v')) else {||}
    ))"

lemma fst_root_tree[simp]: "fst (root (tree v p pth)) = (hyps_along ((adjacentTo v p,(v,p))#pth) \<turnstile> labelAtIn v p)" by simp

lemma out_port_cases[consumes 1, case_names Assumption Hyp Rule Helper]:
  assumes "p |\<in>| outPorts n"
  obtains
    a where "n = Assumption a" and "p = Reg a"
    | r h c where "n = Rule r" and "p = Hyp h c"
    | r f where "n = Rule r" and "p = Reg f"
    | "n = Helper" and "p = Reg anyP"
  using assms by (atomize_elim, cases p; cases n) auto

lemma hyps_for_fimage: "hyps_for (Rule r) x = (if x |\<in>| f_antecedent r then (\<lambda> f. Hyp f x) |`| (a_hyps x) else {||})"
  apply (rule fset_eqI)
  apply (rename_tac p')
  apply (case_tac p')
  apply (auto simp add:  split: if_splits out_port.splits)
  done

text \<open>Now we prove that the thus produced tree is well-formed.\<close>

theorem wf_tree:
  assumes "valid_in_port (v,p)"
  assumes "terminal_path v t pth"
  shows "wf (tree v p pth)"
using assms
proof (coinduction arbitrary: v p pth)
case (wf v p pth)
  let ?t = "tree v p pth"
  from saturated[OF wf(1)]
  obtain v' p'
  where e:"((v',p'),(v,p)) \<in> edges" and [simp]: "adjacentTo v p = (v',p')"
    by (auto simp add: adjacentTo_def, metis (no_types, lifting) eq_fst_iff tfl_some)

  let ?e = "((v',p'),(v,p))"
  let ?pth' = "?e#pth"
  let ?\<Gamma> = "hyps_along ?pth'"
  let ?l = "labelAtIn v p"

  from e valid_edges have "v' |\<in>| vertices" and "p' |\<in>| outPorts (nodeOf v')" by auto
  hence "nodeOf v' \<in> sset nodes" using valid_nodes by (meson image_eqI notin_fset subsetD)

  from \<open>?e \<in> edges\<close>
  have s: "labelAtOut v' p' = labelAtIn v p"  by (rule solved)

  from \<open>p' |\<in>| outPorts (nodeOf v')\<close>
  show ?case
  proof (cases rule: out_port_cases)
    case (Hyp r h c)

    from Hyp \<open>p' |\<in>| outPorts (nodeOf v')\<close>
    have "h |\<in>| a_hyps c" and "c |\<in>| f_antecedent r" by auto
    hence "hyps (nodeOf v') (Hyp h c) = Some c" using Hyp by simp

    from well_scoped[OF \<open> _ \<in> edges\<close>[unfolded Hyp] this]
    have "(v, p) = (v', c) \<or> v \<in> scope (v', c)".
    hence "(v', c) \<in> insert (v, p) (snd ` set pth)"
    proof
      assume "(v, p) = (v', c)"
      thus ?thesis by simp
    next
      assume "v \<in> scope (v', c)"
      from this terminal_path_end_is_terminal[OF wf(2)] terminal_path_is_path[OF wf(2)]
      have "(v', c) \<in> snd ` set pth" by (rule scope_find)
      thus ?thesis by simp
    qed
    moreover

    from \<open>hyps (nodeOf v') (Hyp h c) = Some c\<close>
    have "Hyp h c |\<in>| hyps_for (nodeOf v') c" by simp
    hence "labelAtOut v' (Hyp h c) |\<in>| extra_assms (v',c)" by auto
    ultimately

    have "labelAtOut v' (Hyp h c) |\<in>| ?\<Gamma>"
      by (fastforce simp add: fmember.rep_eq ffUnion.rep_eq)

    hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Hyp fmember.rep_eq)
    thus ?thesis
      using Hyp
      apply (auto intro: exI[where x = ?t] simp add: eff.simps simp del: hyps_along.simps)
      done
  next
    case (Assumption f)

    from \<open>v' |\<in>| vertices\<close> \<open>nodeOf v' = Assumption f\<close>
    have "labelAtOut v' (Reg f) |\<in>| global_assms TYPE('var)"
      by (rule global_assmsI)
    hence "labelAtOut v' (Reg f) |\<in>| ?\<Gamma>" by auto
    hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Assumption fmember.rep_eq)
    thus ?thesis using Assumption
      by (auto intro: exI[where x = ?t] simp add: eff.simps)
  next
    case (Rule r f)
    with \<open>nodeOf v' \<in> sset nodes\<close>
    have "r \<in> sset rules"
      by (auto simp add: nodes_def stream.set_map)

    from Rule
    have "hyps (nodeOf v') p' = None" by simp
    with e \<open>terminal_path v t pth\<close>
    have "terminal_path v' t ?pth'"..

    from Rule  \<open>p' |\<in>| outPorts (nodeOf v')\<close>
    have "f |\<in>| f_consequent r" by simp
    hence "f \<in> set (consequent r)" by (simp add: f_consequent_def)
    with \<open>r \<in> sset rules\<close>
    have "NatRule (r, f) \<in> sset (smap NatRule n_rules)"
      by (auto simp add: stream.set_map n_rules_def no_empty_conclusions)
    moreover

    {
    from \<open>f |\<in>| f_consequent r\<close>
    have "f \<in> set (consequent r)" by (simp add: f_consequent_def)
    hence "natEff_Inst (r, f) f (f_antecedent r)"
      by (rule natEff_Inst.intros)
    hence "eff (NatRule (r, f)) (?\<Gamma> \<turnstile> subst (inst v') (freshen (vidx v') f))
           ((\<lambda>ant. ((\<lambda>p. subst (inst v') (freshen (vidx v') p)) |`| a_hyps ant |\<union>| ?\<Gamma> \<turnstile> subst (inst v') (freshen (vidx v') (a_conc ant)))) |`| f_antecedent r)"
           (is "eff _ _ ?ants")
    proof (rule eff.intros)
      fix ant f
      assume "ant |\<in>| f_antecedent r"
      from  \<open>v' |\<in>| vertices\<close> \<open>ant |\<in>| f_antecedent r\<close>
      have "valid_in_port (v',ant)" by (simp add: Rule)

      assume "f |\<in>| ?\<Gamma>"
      thus "freshenLC (vidx v') ` a_fresh ant \<inter> lconsts f = {}"
      proof(induct rule: hyps_alongE)
        case (Hyp v'' p'' h'')

        from Hyp(1) snd_set_path_verties[OF terminal_path_is_path[OF \<open>terminal_path v' t ?pth'\<close>]]
        have "v'' |\<in>| vertices" by (force simp add: fmember.rep_eq)

        from \<open>terminal_path v' t ?pth'\<close> Hyp(1)
        have "v'' \<notin> scope (v', ant)" by (rule hyps_free_path_not_in_scope)
        with \<open>valid_in_port (v',ant)\<close> \<open>v'' |\<in>| vertices\<close>
        have "freshenLC (vidx v') ` local_vars (nodeOf v') ant \<inter> subst_lconsts (inst v'') = {}"
         by (rule out_of_scope)
        moreover
        from hyps_free_vertices_distinct'[OF \<open>terminal_path v' t ?pth'\<close>] Hyp.hyps(1)
        have "v'' \<noteq> v'" by (metis distinct.simps(2) fst_conv image_eqI list.set_map)
        hence "vidx v'' \<noteq> vidx v'" using \<open>v' |\<in>| vertices\<close> \<open>v'' |\<in>| vertices\<close> by (meson vidx_inj inj_onD notin_fset)
        hence "freshenLC (vidx v') ` a_fresh ant \<inter> freshenLC (vidx v'') ` lconsts (labelsOut (nodeOf v'') h'') = {}"by auto
        moreover
        have "lconsts f \<subseteq> lconsts (freshen (vidx v'') (labelsOut (nodeOf v'') h'')) \<union> subst_lconsts (inst v'') " using \<open>f = _\<close>
          by (simp add: labelAtOut_def fv_subst)
        ultimately
        show ?thesis
          by (fastforce simp add:  lconsts_freshen)
      next
        case (Assumption v pf)
        hence "f = subst (inst v) (freshen (vidx v) pf)" by (simp add: labelAtOut_def)
        moreover
        from Assumption have "Assumption pf \<in> sset nodes" using valid_nodes by (auto simp add: fmember.rep_eq)
        hence "pf \<in> set assumptions" unfolding nodes_def by (auto simp add: stream.set_map)
        hence "closed pf" by (rule assumptions_closed)
        ultimately
        have "lconsts f = {}" by (simp add: closed_no_lconsts lconsts_freshen subst_closed freshen_closed)
        thus ?thesis by simp
      qed
    next
      fix ant
      assume "ant |\<in>| f_antecedent r"
      from  \<open>v' |\<in>| vertices\<close> \<open>ant |\<in>| f_antecedent r\<close>
      have "valid_in_port (v',ant)" by (simp add: Rule)
      moreover
      note \<open>v' |\<in>| vertices\<close>
      moreover
      hence "v' \<notin> scope (v', ant)" by (rule scopes_not_refl)
      ultimately
      have "freshenLC (vidx v') ` local_vars (nodeOf v') ant \<inter> subst_lconsts (inst v') = {}"
        by (rule out_of_scope)
      thus "freshenLC (vidx v') ` a_fresh ant \<inter> subst_lconsts (inst v') = {}" by simp
    qed
    also
    have "subst (inst v') (freshen (vidx v') f) = labelAtOut v' p'" using Rule by (simp add: labelAtOut_def)
    also
    note \<open>labelAtOut v' p' = labelAtIn v p\<close>
    also
    have "?ants = ((\<lambda>x. (extra_assms (v',x) |\<union>| hyps_along ?pth' \<turnstile> labelAtIn  v' x)) |`| f_antecedent r)"
      by (rule fimage_cong[OF refl])
        (auto simp add: labelAtIn_def labelAtOut_def Rule hyps_for_fimage fmember.rep_eq ffUnion.rep_eq)
    finally
    have "eff (NatRule (r, f))
        (?\<Gamma>, labelAtIn v p)
        ((\<lambda>x. extra_assms (v',x) |\<union>| ?\<Gamma> \<turnstile> labelAtIn v' x) |`| f_antecedent r)".
    }
    moreover

    { fix x
      assume "x |\<in>| cont ?t"
      then obtain a where "x = tree v' a ?pth'" and "a |\<in>| f_antecedent r"
        by (auto simp add: Rule)
      note this(1)
      moreover

      from  \<open>v' |\<in>| vertices\<close> \<open>a |\<in>| f_antecedent r\<close>
      have "valid_in_port (v',a)" by (simp add: Rule)
      moreover

      note \<open>terminal_path v' t ?pth'\<close>
      ultimately

      have "\<exists>v p pth. x = tree v p pth \<and> valid_in_port (v,p) \<and>  terminal_path v t pth"
        by blast
    }
    ultimately

    show ?thesis using Rule
      by (auto intro!: exI[where x = ?t]  simp add: comp_def funion_assoc)
  next
    case Helper
    from Helper
    have "hyps (nodeOf v') p' = None" by simp
    with e \<open>terminal_path v t pth\<close>
    have "terminal_path v' t ?pth'"..

    have "labelAtIn v' (plain_ant anyP) = labelAtIn v p"
      unfolding s[symmetric]
      using Helper by (simp add: labelAtIn_def labelAtOut_def)
    moreover
    { fix x
      assume "x |\<in>| cont ?t"

      hence "x = tree v' (plain_ant anyP) ?pth'"
        by (auto simp add: Helper)
      note this(1)
      moreover

      from  \<open>v' |\<in>| vertices\<close>
      have "valid_in_port (v',plain_ant anyP)" by (simp add: Helper)
      moreover

      note \<open>terminal_path v' t ?pth'\<close>
      ultimately

      have "\<exists>v p pth. x = tree v p pth \<and> valid_in_port (v,p) \<and>  terminal_path v t pth"
        by blast
    }
    ultimately

    show ?thesis using Helper
      by (auto intro!: exI[where x = ?t]  simp add: comp_def funion_assoc )
  qed
qed

lemma global_in_ass: "global_assms TYPE('var) |\<subseteq>| ass_forms"
proof
  fix x
  assume "x |\<in>| global_assms TYPE('var)"
  then obtain v pf where "v |\<in>| vertices" and "nodeOf v = Assumption pf" and "x = labelAtOut v (Reg pf)"
    by (auto simp add: global_assms_simps)
  from this (1,2) valid_nodes
  have "Assumption pf \<in> sset nodes" by (auto simp add: fmember.rep_eq)
  hence "pf \<in> set assumptions" by (auto simp add: nodes_def stream.set_map)
  hence "closed pf" by (rule  assumptions_closed)
  with \<open>x = labelAtOut v (Reg pf)\<close>
  have "x = pf" by (auto simp add: labelAtOut_def lconsts_freshen closed_no_lconsts freshen_closed subst_closed)
  thus "x |\<in>| ass_forms" using \<open>pf \<in> set assumptions\<close> by (auto simp add: ass_forms_def)
qed

primcorec edge_tree :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex, 'form, 'var) edge' tree" where
 "root (edge_tree v p) = (adjacentTo v p, (v,p))"
 | "cont (edge_tree v p) =
    (case adjacentTo v p of (v', p') \<Rightarrow>
    (if isReg v' p' then ((\<lambda> p. edge_tree  v' p) |`| inPorts (nodeOf v')) else {||}
    ))"

lemma tfinite_map_tree: "tfinite (map_tree f t) \<longleftrightarrow> tfinite t"
proof
  assume "tfinite (map_tree f t)"
  thus "tfinite t"
    by (induction "map_tree f t" arbitrary: t rule: tfinite.induct)
       (fastforce intro:  tfinite.intros simp add:  tree.map_sel)
next
  assume "tfinite t"
  thus "tfinite (map_tree f t)"
    by (induction t rule: tfinite.induct)
       (fastforce intro:  tfinite.intros simp add:  tree.map_sel)
qed

lemma finite_tree_edge_tree:
  "tfinite (tree v p pth) \<longleftrightarrow> tfinite (edge_tree v p)"
proof-
  have "map_tree (\<lambda> _. ())  (tree v p pth) = map_tree (\<lambda> _. ()) (edge_tree v p)"
   by(coinduction arbitrary: v p pth)
     (fastforce simp add: tree.map_sel rel_fset_def rel_set_def split: prod.split out_port.split graph_node.split option.split)
  thus ?thesis by (metis tfinite_map_tree)
qed

coinductive forbidden_path :: "'vertex \<Rightarrow> ('vertex, 'form, 'var) edge' stream \<Rightarrow> bool"   where
    forbidden_path: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = None \<Longrightarrow> forbidden_path v\<^sub>1 pth \<Longrightarrow> forbidden_path v\<^sub>2 (((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2))##pth)"

lemma path_is_forbidden:
  assumes "valid_in_port (v,p)"
  assumes "ipath (edge_tree v p) es"
  shows "forbidden_path v es"
using assms
proof(coinduction arbitrary: v p es)
  case forbidden_path

  let ?es' = "stl es"

  from forbidden_path(2)
  obtain t' where "root (edge_tree v p) = shd es" and "t' |\<in>| cont (edge_tree v p)" and "ipath t' ?es'"
    by rule blast

  from \<open>root (edge_tree v p) = shd es\<close>
  have [simp]: "shd es = (adjacentTo v p, (v,p))" by simp

  from saturated[OF \<open>valid_in_port (v,p)\<close>]
  obtain v' p'
  where e:"((v',p'),(v,p)) \<in> edges" and [simp]: "adjacentTo v p = (v',p')"
    by (auto simp add: adjacentTo_def, metis (no_types, lifting) eq_fst_iff tfl_some)
  let ?e = "((v',p'),(v,p))"

  from e have "p' |\<in>| outPorts (nodeOf v')" using valid_edges by auto
  thus ?case
  proof(cases rule: out_port_cases)
    case Hyp
    with  \<open>t' |\<in>| cont (edge_tree v p)\<close>
    have False by auto
    thus ?thesis..
  next
    case Assumption
    with  \<open>t' |\<in>| cont (edge_tree v p)\<close>
    have False by auto
    thus ?thesis..
  next
    case (Rule r f)
    from \<open>t' |\<in>| cont (edge_tree v p)\<close> Rule
    obtain a where [simp]: "t' = edge_tree v' a" and "a |\<in>| f_antecedent r"  by auto

    have "es = ?e ## ?es'" by (cases es rule: stream.exhaust_sel) simp
    moreover

    have "?e \<in> edges" using e by simp
    moreover

    from \<open>p' = Reg f\<close> \<open>nodeOf v' = Rule r\<close>
    have "hyps (nodeOf v') p' = None" by simp
    moreover

    from e valid_edges have "v' |\<in>| vertices"  by auto
    with \<open>nodeOf v' = Rule r\<close> \<open>a |\<in>| f_antecedent r\<close>
    have "valid_in_port (v', a)" by simp
    moreover

    have "ipath (edge_tree v' a) ?es'" using \<open>ipath t' _\<close> by simp
    ultimately

    show ?thesis by metis
  next
    case Helper
    from \<open>t' |\<in>| cont (edge_tree v p)\<close> Helper
    have [simp]: "t' = edge_tree v' (plain_ant anyP)" by simp

    have "es = ?e ## ?es'" by (cases es rule: stream.exhaust_sel) simp
    moreover

    have "?e \<in> edges" using e by simp
    moreover

    from \<open>p' = Reg anyP\<close> \<open>nodeOf v' = Helper\<close>
    have "hyps (nodeOf v') p' = None" by simp
    moreover

    from e valid_edges have "v' |\<in>| vertices"  by auto
    with \<open>nodeOf v' = Helper\<close>
    have "valid_in_port (v', plain_ant anyP)" by simp
    moreover

    have "ipath (edge_tree v' (plain_ant anyP)) ?es'" using \<open>ipath t' _\<close> by simp
    ultimately

    show ?thesis by metis
  qed
qed

lemma forbidden_path_prefix_is_path:
  assumes "forbidden_path v es"
  obtains v' where  "path v' v (rev (stake n es))"
  using assms
  apply (atomize_elim)
  apply (induction n arbitrary: v es)
  apply simp
  apply (simp add: path_snoc)
  apply (subst (asm) (2) forbidden_path.simps)
  apply auto
  done

lemma forbidden_path_prefix_is_hyp_free:
  assumes "forbidden_path v es"
  shows "hyps_free (rev (stake n es))"
  using assms
  apply (induction n arbitrary: v es)
  apply (simp add: hyps_free_def)
  apply (subst (asm) (2) forbidden_path.simps)
  apply (force simp add: hyps_free_def)
  done

text \<open>And now we prove that the tree is finite, which requires the above notion of a
@{term forbidden_path}, i.e.\@ an infinite path.\<close>

theorem finite_tree:
  assumes "valid_in_port (v,p)"
  assumes "terminal_vertex v"
  shows "tfinite (tree v p pth)"
proof(rule ccontr)
  let ?n = "Suc (fcard vertices)"
  assume "\<not> tfinite (tree v p pth)"
  hence "\<not> tfinite (edge_tree v p)" unfolding finite_tree_edge_tree.
  then obtain es  :: "('vertex, 'form, 'var) edge' stream"
    where "ipath (edge_tree v p) es" using Konig by blast
  with \<open>valid_in_port (v,p)\<close>
  have "forbidden_path v es" by (rule path_is_forbidden)
  from forbidden_path_prefix_is_path[OF this] forbidden_path_prefix_is_hyp_free[OF this]
  obtain v' where "path v' v (rev (stake ?n es))" and "hyps_free (rev (stake ?n es))"
    by blast
  from this \<open>terminal_vertex v\<close>
  have "terminal_path  v' v (rev (stake ?n es))" by (rule terminal_pathI)
  hence "length (rev (stake ?n es)) \<le> fcard vertices"
    by (rule hyps_free_limited)
  thus False by simp
qed

text \<open>The main result of this theory.\<close>

theorem solved
unfolding solved_def
proof(intro ballI allI conjI impI)
  fix c
  assume "c |\<in>| conc_forms"
  hence "c \<in> set conclusions"  by (auto simp add: conc_forms_def)
  from this(1) conclusions_present
  obtain v where "v |\<in>| vertices" and "nodeOf v = Conclusion c"
    by (auto, metis (no_types, lifting) image_iff image_subset_iff notin_fset)

  have "valid_in_port (v, (plain_ant c))"
    using \<open>v |\<in>| vertices\<close> \<open>nodeOf _ = _ \<close>  by simp

  have "terminal_vertex v" using \<open>v |\<in>| vertices\<close> \<open>nodeOf v = Conclusion c\<close> by auto

  let ?t = "tree v (plain_ant c) []"

  have "fst (root ?t) = (global_assms TYPE('var), c)"
    using \<open>c \<in> set conclusions\<close> \<open>nodeOf _ = _\<close>
    by (auto simp add: labelAtIn_def conclusions_closed closed_no_lconsts  freshen_def rename_closed subst_closed)
  moreover

  have "global_assms TYPE('var) |\<subseteq>| ass_forms" by (rule global_in_ass)
  moreover

  from  \<open>terminal_vertex v\<close>
  have "terminal_path v v []" by (rule terminal_path_empty)
  with \<open>valid_in_port (v, (plain_ant c))\<close>
  have "wf ?t" by (rule wf_tree)
  moreover

  from \<open>valid_in_port (v, plain_ant c)\<close> \<open>terminal_vertex v\<close>
  have "tfinite ?t" by (rule finite_tree)
  ultimately

  show "\<exists>\<Gamma> t. fst (root t) = (\<Gamma> \<turnstile> c) \<and> \<Gamma> |\<subseteq>| ass_forms \<and> wf t \<and> tfinite t" by blast
qed

end

end


(*  Title:      JinjaThreads/J/SmallTypeSafe.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

header {* \isaheader{Type Safety Proof} *}

theory TypeSafe
imports
  Progress
  DefAssPreservation
begin

subsection{*Basic preservation lemmas*}

text{* First two easy preservation lemmas. *}

theorem (in J_conf_read)
  shows red_preserves_hconf:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>; P,E,hp s \<turnstile> e : T; hconf (hp s) \<rbrakk> \<Longrightarrow> hconf (hp s')"
  and reds_preserves_hconf:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle>; P,E,hp s \<turnstile> es [:] Ts; hconf (hp s) \<rbrakk> \<Longrightarrow> hconf (hp s')"
proof (induct arbitrary: T E and Ts E rule: red_reds.inducts)
  case RedNew thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case RedNewFail thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case RedNewArray thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case RedNewArrayFail thus ?case
    by(auto intro: hconf_heap_ops_mono)
next
  case (RedAAss h a U n i v U' h' l)
  from `sint i < int n` `0 <=s i`
  have "nat (sint i) < n" by(metis nat_less_iff sint_0 word_sle_def)
  thus ?case using RedAAss
    by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
  case RedFAss thus ?case
    by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  hence "P,hp s \<turnstile> a\<bullet>M(vs) : T"
    by(fastforce simp add: external_WT'_iff dest: sees_method_fun)
  with RedCallExternal show ?case by(auto dest: external_call_hconf)
qed auto

theorem (in J_heap) red_preserves_lconf:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>; P,E,hp s \<turnstile> e:T; P,hp s \<turnstile> lcl s (:\<le>) E \<rbrakk> \<Longrightarrow> P,hp s' \<turnstile> lcl s' (:\<le>) E"
  and reds_preserves_lconf:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle>; P,E,hp s \<turnstile> es[:]Ts; P,hp s \<turnstile> lcl s (:\<le>) E \<rbrakk> \<Longrightarrow> P,hp s' \<turnstile> lcl s' (:\<le>) E"
proof(induct arbitrary: T E and Ts E rule:red_reds.inducts)
  case RedNew thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedNewFail thus ?case
    by(auto intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedNewArray thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedNewArrayFail thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedLAss thus ?case
    by(fastforce elim: lconf_upd simp add: conf_def simp del: fun_upd_apply )
next
  case RedAAss thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case RedFAss thus ?case
    by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
  case (BlockRed e h x V vo ta e' h' x' T T' E)
  note red = `extTA,P,t \<turnstile> \<langle>e,(h, x(V := vo))\<rangle> -ta\<rightarrow> \<langle>e',(h', x')\<rangle>`
  note IH = `\<And>T E. \<lbrakk>P,E,hp (h, x(V := vo)) \<turnstile> e : T;
               P,hp (h, x(V := vo)) \<turnstile> lcl (h, x(V := vo)) (:\<le>) E\<rbrakk>
              \<Longrightarrow> P,hp (h', x') \<turnstile> lcl (h', x') (:\<le>) E`
  note wt = `P,E,hp (h, x) \<turnstile> {V:T=vo; e} : T'`
  note lconf = `P,hp (h, x) \<turnstile> lcl (h, x) (:\<le>) E`
  from lconf_hext[OF lconf[simplified] red_hext_incr[OF red, simplified]]
  have "P,h' \<turnstile> x (:\<le>) E" .
  moreover from wt have "P,E(V\<mapsto>T),h \<turnstile> e : T'" by(cases vo, auto)
  moreover from lconf wt have "P,h \<turnstile> x(V := vo) (:\<le>) E(V \<mapsto> T)"
    by(cases vo)(simp add: lconf_def,auto intro: lconf_upd2 simp add: conf_def)
  ultimately have "P,h' \<turnstile> x' (:\<le>) E(V\<mapsto>T)"
    by(auto intro: IH[simplified])
  with `P,h' \<turnstile> x (:\<le>) E` show ?case
    by(auto simp add: lconf_def split: split_if_asm)
next
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  from `P,t \<turnstile> \<langle>a\<bullet>M(vs),hp s\<rangle> -ta\<rightarrow>ext \<langle>va,h'\<rangle>` have "hp s \<unlhd> h'" by(rule red_external_hext)
  with `s' = (h', lcl s)` `P,hp s \<turnstile> lcl s (:\<le>) E` show ?case by(auto intro: lconf_hext)
qed auto

text{* Combining conformance of heap and local variables: *}

definition (in J_heap_conf_base) sconf :: "env \<Rightarrow> ('addr, 'heap) Jstate \<Rightarrow> bool" ("_ \<turnstile> _ \<surd>"   [51,51]50)
  where "E \<turnstile> s \<surd>  \<equiv>  let (h,l) = s in hconf h \<and> P,h \<turnstile> l (:\<le>) E \<and> preallocated h"

context J_conf_read begin

lemma red_preserves_sconf:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>e,s\<rangle> -tas\<rightarrow> \<langle>e',s'\<rangle>; P,E,hp s \<turnstile> e : T; E \<turnstile> s \<surd> \<rbrakk> \<Longrightarrow> E \<turnstile> s' \<surd>"
apply(auto dest: red_preserves_hconf red_preserves_lconf simp add:sconf_def)
apply(fastforce dest: red_hext_incr intro: preallocated_hext)
done

lemma reds_preserves_sconf:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle>; P,E,hp s \<turnstile> es [:] Ts; E \<turnstile> s \<surd> \<rbrakk> \<Longrightarrow> E \<turnstile> s' \<surd>"
apply(auto dest: reds_preserves_hconf reds_preserves_lconf simp add: sconf_def)
apply(fastforce dest: reds_hext_incr intro: preallocated_hext)
done

end

lemma (in J_heap_base) wt_external_call:
  "\<lbrakk> conf_extRet P h va T; P,E,h \<turnstile> e : T \<rbrakk> \<Longrightarrow> \<exists>T'. P,E,h \<turnstile> extRet2J e va : T' \<and> P \<turnstile> T' \<le> T"
by(cases va)(auto simp add: conf_def)

subsection "Subject reduction"

theorem (in J_conf_read) assumes wf: "wf_J_prog P"
  shows subject_reduction:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>; E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e:T; P,hp s \<turnstile> t \<surd>t \<rbrakk>
  \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e':T' \<and> P \<turnstile> T' \<le> T"
  and subjects_reduction:
  "\<lbrakk> extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle>; E \<turnstile> s \<surd>; P,E,hp s \<turnstile> es[:]Ts; P,hp s \<turnstile> t \<surd>t \<rbrakk>
  \<Longrightarrow> \<exists>Ts'. P,E,hp s' \<turnstile> es'[:]Ts' \<and> P \<turnstile> Ts' [\<le>] Ts"
proof (induct arbitrary: T E and Ts E rule:red_reds.inducts)
  case RedNew
  thus ?case by(auto dest: allocate_SomeD)
next
  case RedNewFail thus ?case unfolding sconf_def
    by(fastforce intro:typeof_OutOfMemory preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case NewArrayRed
  thus ?case by fastforce
next
  case RedNewArray
  thus ?case by(auto dest: allocate_SomeD)
next
  case RedNewArrayNegative thus ?case unfolding sconf_def
    by(fastforce intro: preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedNewArrayFail thus ?case unfolding sconf_def
    by(fastforce intro:typeof_OutOfMemory preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (CastRed e s ta e' s' C T E)
  have esse: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>"
    and IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T"
    and hconf: "E \<turnstile> s \<surd>"
    and wtc: "P,E,hp s \<turnstile> Cast C e : T" by fact+
  thus ?case
  proof(clarsimp)
    fix T'
    assume wte: "P,E,hp s \<turnstile> e : T'" "is_type P T"
    from wte and hconf and IH and `P,hp s \<turnstile> t \<surd>t` have "\<exists>U. P,E,hp s' \<turnstile> e' : U \<and> P \<turnstile> U \<le> T'" by simp
    then obtain U where wtee: "P,E,hp s' \<turnstile> e' : U" and UsTT: "P \<turnstile> U \<le> T'" by blast
    from wtee `is_type P T` have "P,E,hp s' \<turnstile> Cast T e' : T" by(rule WTrtCast)
    thus "\<exists>T'. P,E,hp s' \<turnstile> Cast T e' : T' \<and> P \<turnstile> T' \<le> T" by blast
  qed
next
  case RedCast thus ?case
    by(clarsimp simp add: is_refT_def)
next
  case RedCastFail thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (InstanceOfRed e s ta e' s' U T E)
  have IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T"
    and hconf: "E \<turnstile> s \<surd>"
    and wtc: "P,E,hp s \<turnstile> e instanceof U : T"
    and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wtc obtain T' where "P,E,hp s \<turnstile> e : T'" by auto
  from IH[OF hconf this tconf] obtain T'' where "P,E,hp s' \<turnstile> e' : T''" by auto
  with wtc show ?case by auto
next
  case RedInstanceOf thus ?case
    by(clarsimp)
next
  case (BinOpRed1 e\<^sub>1 s ta e\<^sub>1' s' bop e\<^sub>2 T E)
  have red: "extTA,P,t \<turnstile> \<langle>e\<^sub>1, s\<rangle> -ta\<rightarrow> \<langle>e\<^sub>1', s'\<rangle>"
   and IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e\<^sub>1:T; P,hp s \<turnstile> t \<surd>t\<rbrakk>
                 \<Longrightarrow> \<exists>U. P,E,hp s' \<turnstile> e\<^sub>1' : U \<and> P \<turnstile> U \<le> T"
   and conf: "E \<turnstile> s \<surd>" and wt: "P,E,hp s \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 : T"
   and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt obtain T1 T2 where wt1: "P,E,hp s \<turnstile> e\<^sub>1 : T1"
    and wt2: "P,E,hp s \<turnstile> e\<^sub>2 : T2" and wtbop: "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T" by auto
  from IH[OF conf wt1 tconf] obtain T1' where wt1': "P,E,hp s' \<turnstile> e\<^sub>1' : T1'"
    and sub: "P \<turnstile> T1' \<le> T1" by blast
  from WTrt_binop_widen_mono[OF wtbop sub widen_refl]
  obtain T' where wtbop': "P \<turnstile> T1'\<guillemotleft>bop\<guillemotright>T2 : T'" and sub': "P \<turnstile> T' \<le> T" by blast
  from wt1' WTrt_hext_mono[OF wt2 red_hext_incr[OF red]] wtbop'
  have "P,E,hp s' \<turnstile> e\<^sub>1' \<guillemotleft>bop\<guillemotright> e\<^sub>2 : T'" by(rule WTrtBinOp)
  with sub' show ?case by blast
next
  case (BinOpRed2 e\<^sub>2 s ta e\<^sub>2' s' v\<^sub>1 bop T E)
  have red: "extTA,P,t \<turnstile> \<langle>e\<^sub>2,s\<rangle> -ta\<rightarrow> \<langle>e\<^sub>2',s'\<rangle>" by fact
  have IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e\<^sub>2:T; P,hp s \<turnstile> t \<surd>t\<rbrakk>
                 \<Longrightarrow> \<exists>U. P,E,hp s' \<turnstile> e\<^sub>2' : U \<and> P \<turnstile> U \<le> T"
    and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  have conf: "E \<turnstile> s \<surd>" and wt: "P,E,hp s \<turnstile> (Val v\<^sub>1) \<guillemotleft>bop\<guillemotright> e\<^sub>2 : T" by fact+
  from wt obtain T1 T2 where wt1: "P,E,hp s \<turnstile> Val v\<^sub>1 : T1"
    and wt2: "P,E,hp s \<turnstile> e\<^sub>2 : T2" and wtbop: "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T" by auto
  from IH[OF conf wt2 tconf] obtain T2' where wt2': "P,E,hp s' \<turnstile> e\<^sub>2' : T2'"
    and sub: "P \<turnstile> T2' \<le> T2" by blast
  from WTrt_binop_widen_mono[OF wtbop widen_refl sub]
  obtain T' where wtbop': "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2' : T'" and sub': "P \<turnstile> T' \<le> T" by blast
  from WTrt_hext_mono[OF wt1 red_hext_incr[OF red]] wt2' wtbop'
  have "P,E,hp s' \<turnstile> Val v\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2' : T'" by(rule WTrtBinOp)
  with sub' show ?case by blast
next
  case (RedBinOp bop v1 v2 v s)
  from `E \<turnstile> s \<surd>` have preh: "preallocated (hp s)" by(cases s)(simp add: sconf_def)
  from `P,E,hp s \<turnstile> Val v1 \<guillemotleft>bop\<guillemotright> Val v2 : T` obtain T1 T2
    where "typeof\<^bsub>hp s\<^esub> v1 = \<lfloor>T1\<rfloor>" "typeof\<^bsub>hp s\<^esub> v2 = \<lfloor>T2\<rfloor>" "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T" by auto
  with wf preh have "P,hp s \<turnstile> v :\<le> T" using `binop bop v1 v2 = \<lfloor>Inl v\<rfloor>`
    by(rule binop_type)
  thus ?case by(auto simp add: conf_def)
next
  case (RedBinOpFail bop v1 v2 a s)
  from `E \<turnstile> s \<surd>` have preh: "preallocated (hp s)" by(cases s)(simp add: sconf_def)
  from `P,E,hp s \<turnstile> Val v1 \<guillemotleft>bop\<guillemotright> Val v2 : T` obtain T1 T2
    where "typeof\<^bsub>hp s\<^esub> v1 = \<lfloor>T1\<rfloor>" "typeof\<^bsub>hp s\<^esub> v2 = \<lfloor>T2\<rfloor>" "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T" by auto
  with wf preh have "P,hp s \<turnstile> Addr a :\<le> Class Throwable" using `binop bop v1 v2 = \<lfloor>Inr a\<rfloor>`
    by(rule binop_type)
  thus ?case by(auto simp add: conf_def)
next
  case RedVar thus ?case by (fastforce simp:sconf_def lconf_def conf_def)
next
  case LAssRed thus ?case by(blast intro:widen_trans)
next
  case RedLAss thus ?case by fastforce
next
  case (AAccRed1 a s ta a' s' i T E)
  have IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> a : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> a' : T' \<and> P \<turnstile> T' \<le> T"
    and assa: "extTA,P,t \<turnstile> \<langle>a,s\<rangle> -ta\<rightarrow> \<langle>a',s'\<rangle>"
    and wt: "P,E,hp s \<turnstile> a\<lfloor>i\<rceil> : T"
    and hconf: "E \<turnstile> s \<surd>"
    and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt have wti: "P,E,hp s \<turnstile> i : Integer" by auto
  from wti red_hext_incr[OF assa] have wti': "P,E,hp s' \<turnstile> i : Integer" by - (rule WTrt_hext_mono)
  { assume wta: "P,E,hp s \<turnstile> a : T\<lfloor>\<rceil>"
    from IH[OF hconf wta tconf]
    obtain U where wta': "P,E,hp s' \<turnstile> a' : U" and UsubT: "P \<turnstile> U \<le> T\<lfloor>\<rceil>" by fastforce
    with wta' wti' have ?case by(cases U, auto simp add: widen_Array) }
  moreover
  { assume wta: "P,E,hp s \<turnstile> a : NT"
    from IH[OF hconf wta tconf] have "P,E,hp s' \<turnstile> a' : NT" by fastforce
    from this wti' have ?case
      by(fastforce intro:WTrtAAccNT) }
  ultimately show ?case using wt by auto
next
  case (AAccRed2 i s ta i' s' a T E)
  have IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> i : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> i' : T' \<and> P \<turnstile> T' \<le> T"
    and issi: "extTA,P,t \<turnstile> \<langle>i,s\<rangle> -ta\<rightarrow> \<langle>i',s'\<rangle>"
    and wt: "P,E,hp s \<turnstile> Val a\<lfloor>i\<rceil> : T"
    and sconf: "E \<turnstile> s \<surd>"
    and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt have wti: "P,E,hp s \<turnstile> i : Integer" by auto
  from wti IH sconf tconf have wti': "P,E,hp s' \<turnstile> i' : Integer" by blast
  from wt show ?case
  proof (rule WTrt_elim_cases)
    assume wta: "P,E,hp s \<turnstile> Val a : T\<lfloor>\<rceil>"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s' \<turnstile> Val a : T\<lfloor>\<rceil>" by (rule WTrt_hext_mono)
    from wta' wti' show ?case by(fastforce)
  next
    assume wta: "P,E,hp s \<turnstile> Val a : NT"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s' \<turnstile> Val a : NT" by (rule WTrt_hext_mono)
    from wta' wti' show ?case
      by(fastforce elim:WTrtAAccNT)
  qed
next
  case RedAAccNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAccBounds thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (RedAAcc h a T n i v l T' E)
  from `E \<turnstile> (h, l) \<surd>` have "hconf h" by(clarsimp simp add: sconf_def)
  from `0 <=s i` `sint i < int n`
  have "nat (sint i) < n" by(metis nat_less_iff sint_0 word_sle_def)
  with `typeof_addr h a = \<lfloor>Array_type T n\<rfloor>` have "P,h \<turnstile> a@ACell (nat (sint i)) : T"
    by(auto intro: addr_loc_type.intros)
  from heap_read_conf[OF `heap_read h a (ACell (nat (sint i))) v` this] `hconf h`
  have "P,h \<turnstile> v :\<le> T" by simp
  thus ?case using RedAAcc by(auto simp add: conf_def)
next
  case (AAssRed1 a s ta a' s' i e T E)
  have IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> a : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> a' : T' \<and> P \<turnstile> T' \<le> T"
    and assa: "extTA,P,t \<turnstile> \<langle>a,s\<rangle> -ta\<rightarrow> \<langle>a',s'\<rangle>"
    and wt: "P,E,hp s \<turnstile> a\<lfloor>i\<rceil> := e : T"
    and sconf: "E \<turnstile> s \<surd>"
    and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt have void: "T = Void" by blast
  from wt have wti: "P,E,hp s \<turnstile> i : Integer" by auto
  from wti red_hext_incr[OF assa] have wti': "P,E,hp s' \<turnstile> i : Integer" by - (rule WTrt_hext_mono)
  { assume wta: "P,E,hp s \<turnstile> a : NT"
    from IH[OF sconf wta tconf] have wta': "P,E,hp s' \<turnstile> a' : NT" by fastforce
    from wt wta obtain V where wte: "P,E,hp s \<turnstile> e : V" by(auto)
    from wte red_hext_incr[OF assa] have wte': "P,E,hp s' \<turnstile> e : V" by - (rule WTrt_hext_mono)
    from wta' wti' wte' void have ?case
      by(fastforce elim: WTrtAAssNT) }
  moreover
  { fix U
    assume wta: "P,E,hp s \<turnstile> a : U\<lfloor>\<rceil>"
    from IH[OF sconf wta tconf]
    obtain U' where wta': "P,E,hp s' \<turnstile> a' : U'" and UsubT: "P \<turnstile> U' \<le> U\<lfloor>\<rceil>" by fastforce
    with wta' have ?case
    proof(cases U')
      case NT
      assume UNT: "U' = NT"
      from UNT wt wta obtain V where wte: "P,E,hp s \<turnstile> e : V" by(auto)
      from wte red_hext_incr[OF assa] have wte': "P,E,hp s' \<turnstile> e : V" by - (rule WTrt_hext_mono)
      from wta' UNT wti' wte' void show ?thesis
        by(fastforce elim: WTrtAAssNT)
    next
      case (Array A)
      have UA: "U' = A\<lfloor>\<rceil>" by fact
      with UA UsubT wt wta obtain V where wte: "P,E,hp s \<turnstile> e : V" by auto
      from wte red_hext_incr[OF assa] have wte': "P,E,hp s' \<turnstile> e : V" by - (rule WTrt_hext_mono)
      with wta' wte' UA wti' void show ?thesis by (fast elim:WTrtAAss)
    qed(simp_all add: widen_Array) }
  ultimately show ?case using wt by blast
next
  case (AAssRed2 i s ta i' s' a e T E)
  have IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> i : T; P,hp s \<turnstile> t \<surd>t \<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> i' : T' \<and> P \<turnstile> T' \<le> T"
    and issi: "extTA,P,t \<turnstile> \<langle>i,s\<rangle> -ta\<rightarrow> \<langle>i',s'\<rangle>"
    and wt: "P,E,hp s \<turnstile> Val a\<lfloor>i\<rceil> := e : T"
    and sconf: "E \<turnstile> s \<surd>" and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt have void: "T = Void" by blast
  from wt have wti: "P,E,hp s \<turnstile> i : Integer" by auto
  from IH[OF sconf wti tconf] have wti': "P,E,hp s' \<turnstile> i' : Integer" by fastforce
  from wt show ?case
  proof(rule WTrt_elim_cases)
    fix U T'
    assume wta: "P,E,hp s \<turnstile> Val a : U\<lfloor>\<rceil>"
      and wte: "P,E,hp s \<turnstile> e : T'"
    from wte red_hext_incr[OF issi] have wte': "P,E,hp s' \<turnstile> e : T'" by - (rule WTrt_hext_mono)
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s' \<turnstile> Val a : U\<lfloor>\<rceil>" by - (rule WTrt_hext_mono)
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  next
    fix T'
    assume wta: "P,E,hp s \<turnstile> Val a : NT"
      and wte: "P,E,hp s \<turnstile> e : T'"
    from wte red_hext_incr[OF issi] have wte': "P,E,hp s' \<turnstile> e : T'" by - (rule WTrt_hext_mono)
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s' \<turnstile> Val a : NT" by - (rule WTrt_hext_mono)
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  qed
next
  case (AAssRed3 e s ta e' s' a i T E)
  have IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T"
    and issi: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>"
    and wt: "P,E,hp s \<turnstile> Val a\<lfloor>Val i\<rceil> := e : T"
    and sconf: "E \<turnstile> s \<surd>" and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt have void: "T = Void" by blast
  from wt have wti: "P,E,hp s \<turnstile> Val i : Integer" by auto
  from wti red_hext_incr[OF issi] have wti': "P,E,hp s' \<turnstile> Val i : Integer" by - (rule WTrt_hext_mono)
  from wt show ?case
  proof(rule WTrt_elim_cases)
    fix U T'
    assume wta: "P,E,hp s \<turnstile> Val a : U\<lfloor>\<rceil>"
      and wte: "P,E,hp s \<turnstile> e : T'"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s' \<turnstile> Val a : U\<lfloor>\<rceil>" by - (rule WTrt_hext_mono)
    from IH[OF sconf wte tconf]
    obtain V where wte': "P,E,hp s' \<turnstile> e' : V" by fastforce
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  next
    fix T'
    assume wta: "P,E,hp s \<turnstile> Val a : NT"
      and wte: "P,E,hp s \<turnstile> e : T'"
    from wta red_hext_incr[OF issi] have wta': "P,E,hp s' \<turnstile> Val a : NT" by - (rule WTrt_hext_mono)
    from IH[OF sconf wte tconf]
    obtain V where wte': "P,E,hp s' \<turnstile> e' : V" by fastforce
    from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
  qed
next
  case RedAAssNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAssBounds thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAssStore thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedAAss thus ?case
    by(auto simp del:fun_upd_apply)
next
  case (ALengthRed a s ta a' s' T E)
  note IH = `\<And>T'. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> a : T'; P,hp s \<turnstile> t \<surd>t\<rbrakk>
      \<Longrightarrow> \<exists>T''. P,E,hp s' \<turnstile> a' : T'' \<and> P \<turnstile> T'' \<le> T'`
  from `P,E,hp s \<turnstile> a\<bullet>length : T`
  show ?case
  proof(rule WTrt_elim_cases)
    fix T'
    assume [simp]: "T = Integer"
      and wta: "P,E,hp s \<turnstile> a : T'\<lfloor>\<rceil>"
    from wta `E \<turnstile> s \<surd>` IH `P,hp s \<turnstile> t \<surd>t`
    obtain T'' where wta': "P,E,hp s' \<turnstile> a' : T''"
      and sub: "P \<turnstile> T'' \<le> T'\<lfloor>\<rceil>" by blast
    from sub have "P,E,hp s' \<turnstile> a'\<bullet>length : Integer"
      unfolding widen_Array
    proof(rule disjE)
      assume "T'' = NT"
      with wta' show ?thesis by(auto)
    next
      assume "\<exists>V. T'' = V\<lfloor>\<rceil> \<and> P \<turnstile> V \<le> T'"
      then obtain V where "T'' = V\<lfloor>\<rceil>" "P \<turnstile> V \<le> T'" by blast
      with wta' show ?thesis by -(rule WTrtALength, simp)
    qed
    thus ?thesis by(simp)
  next
    assume "P,E,hp s \<turnstile> a : NT"
    with `E \<turnstile> s \<surd>` IH `P,hp s \<turnstile> t \<surd>t`
    obtain T'' where wta': "P,E,hp s' \<turnstile> a' : T''"
      and sub: "P \<turnstile> T'' \<le> NT" by blast
    from sub have "T'' = NT" by auto
    with wta' show ?thesis by(auto)
  qed
next
  case (RedALength h a T n l T' E)
  from `P,E,hp (h, l) \<turnstile> addr a\<bullet>length : T'` `typeof_addr h a = \<lfloor>Array_type T n\<rfloor>`
  have [simp]: "T' = Integer" by(auto)
  thus ?case by(auto)
next
  case RedALengthNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (FAccRed e s ta e' s' F D T E)
  have IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk>
                 \<Longrightarrow> \<exists>U. P,E,hp s' \<turnstile> e' : U \<and> P \<turnstile> U \<le> T"
   and conf: "E \<turnstile> s \<surd>" and wt: "P,E,hp s \<turnstile> e\<bullet>F{D} : T"
   and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  -- "Now distinguish the two cases how wt can have arisen."
  { fix T' C fm
    assume wte: "P,E,hp s \<turnstile> e : T'"
      and icto: "class_type_of' T' = \<lfloor>C\<rfloor>"
      and has: "P \<turnstile> C has F:T (fm) in D"
    from IH[OF conf wte tconf]
    obtain U where wte': "P,E,hp s' \<turnstile> e' : U" and UsubC: "P \<turnstile> U \<le> T'" by auto
    -- "Now distinguish what @{term U} can be."
    with UsubC have ?case
    proof(cases "U = NT")
      case True
      thus ?thesis using wte' by(blast intro:WTrtFAccNT widen_refl)
    next
      case False
      with icto UsubC obtain C' where icto': "class_type_of' U = \<lfloor>C'\<rfloor>"
        and C'subC: "P \<turnstile> C' \<preceq>\<^sup>* C"
        by(rule widen_is_class_type_of)
      from has_field_mono[OF has C'subC] wte' icto'
      show ?thesis by(auto intro!:WTrtFAcc)
    qed }
  moreover
  { assume "P,E,hp s \<turnstile> e : NT"
    hence "P,E,hp s' \<turnstile> e' : NT" using IH[OF conf _ tconf] by fastforce
    hence ?case  by(fastforce intro:WTrtFAccNT widen_refl) }
  ultimately show ?case using wt by blast
next
  case RedFAcc thus ?case unfolding sconf_def
    by(fastforce dest: heap_read_conf intro: addr_loc_type.intros simp add: conf_def)
next
  case RedFAccNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (FAssRed1 e s ta e' s' F D e\<^sub>2)
  have red: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>"
   and IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk>
                 \<Longrightarrow> \<exists>U. P,E,hp s' \<turnstile> e' : U \<and> P \<turnstile> U \<le> T"
   and conf: "E \<turnstile> s \<surd>" and wt: "P,E,hp s \<turnstile> e\<bullet>F{D}:=e\<^sub>2 : T"
   and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt have void: "T = Void" by blast
  -- "We distinguish if @{term e} has type @{term NT} or a Class type"
  { assume "P,E,hp s \<turnstile> e : NT"
    hence "P,E,hp s' \<turnstile> e' : NT" using IH[OF conf _ tconf] by fastforce
    moreover obtain T\<^sub>2 where "P,E,hp s \<turnstile> e\<^sub>2 : T\<^sub>2" using wt by auto
    from this red_hext_incr[OF red] have  "P,E,hp s' \<turnstile> e\<^sub>2 : T\<^sub>2"
      by(rule WTrt_hext_mono)
    ultimately have ?case using void by(blast intro!:WTrtFAssNT)
  }
  moreover
  { fix T' C TF T\<^sub>2 fm
    assume wt\<^sub>1: "P,E,hp s \<turnstile> e : T'" and icto: "class_type_of' T' = \<lfloor>C\<rfloor>" and wt\<^sub>2: "P,E,hp s \<turnstile> e\<^sub>2 : T\<^sub>2"
      and has: "P \<turnstile> C has F:TF (fm) in D" and sub: "P \<turnstile> T\<^sub>2 \<le> TF"
    obtain U where wt\<^sub>1': "P,E,hp s' \<turnstile> e' : U" and UsubC: "P \<turnstile> U \<le> T'"
      using IH[OF conf wt\<^sub>1 tconf] by blast
    have wt\<^sub>2': "P,E,hp s' \<turnstile> e\<^sub>2 : T\<^sub>2"
      by(rule WTrt_hext_mono[OF wt\<^sub>2 red_hext_incr[OF red]])
    -- "Is @{term U} the null type or a class type?"
    have ?case
    proof(cases "U = NT")
      case True
      with wt\<^sub>1' wt\<^sub>2' void show ?thesis by(blast intro!:WTrtFAssNT)
    next
      case False
      with icto UsubC obtain C' where icto': "class_type_of' U = \<lfloor>C'\<rfloor>"
        and "subclass": "P \<turnstile> C' \<preceq>\<^sup>* C" by(rule widen_is_class_type_of)
      have "P \<turnstile> C' has F:TF (fm) in D" by(rule has_field_mono[OF has "subclass"])
      with wt\<^sub>1' show ?thesis using wt\<^sub>2' sub void icto' by(blast intro:WTrtFAss)
    qed }
  ultimately show ?case using wt by blast
next
  case (FAssRed2 e\<^sub>2 s ta e\<^sub>2' s' v F D T E)
  have red: "extTA,P,t \<turnstile> \<langle>e\<^sub>2,s\<rangle> -ta\<rightarrow> \<langle>e\<^sub>2',s'\<rangle>"
   and IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e\<^sub>2 : T; P,hp s \<turnstile> t \<surd>t\<rbrakk>
                 \<Longrightarrow> \<exists>U. P,E,hp s' \<turnstile> e\<^sub>2' : U \<and> P \<turnstile> U \<le> T"
   and conf: "E \<turnstile> s \<surd>" and wt: "P,E,hp s \<turnstile> Val v\<bullet>F{D}:=e\<^sub>2 : T"
   and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt have [simp]: "T = Void" by auto
  from wt show ?case
  proof (rule WTrt_elim_cases)
    fix U C TF T\<^sub>2 fm
    assume wt\<^sub>1: "P,E,hp s \<turnstile> Val v : U"
      and icto: "class_type_of' U = \<lfloor>C\<rfloor>"
      and has: "P \<turnstile> C has F:TF (fm) in D"
      and wt\<^sub>2: "P,E,hp s \<turnstile> e\<^sub>2 : T\<^sub>2" and TsubTF: "P \<turnstile> T\<^sub>2 \<le> TF"
    have wt\<^sub>1': "P,E,hp s' \<turnstile> Val v : U"
      by(rule WTrt_hext_mono[OF wt\<^sub>1 red_hext_incr[OF red]])
    obtain T\<^sub>2' where wt\<^sub>2': "P,E,hp s' \<turnstile> e\<^sub>2' : T\<^sub>2'" and T'subT: "P \<turnstile> T\<^sub>2' \<le> T\<^sub>2"
      using IH[OF conf wt\<^sub>2 tconf] by blast
    have "P,E,hp s' \<turnstile> Val v\<bullet>F{D}:=e\<^sub>2' : Void"
      by(rule WTrtFAss[OF wt\<^sub>1' icto has wt\<^sub>2' widen_trans[OF T'subT TsubTF]])
    thus ?case by auto
  next
    fix T\<^sub>2 assume null: "P,E,hp s \<turnstile> Val v : NT" and wt\<^sub>2: "P,E,hp s \<turnstile> e\<^sub>2 : T\<^sub>2"
    from null have "v = Null" by simp
    moreover
    obtain T\<^sub>2' where "P,E,hp s' \<turnstile> e\<^sub>2' : T\<^sub>2' \<and> P \<turnstile> T\<^sub>2' \<le> T\<^sub>2"
      using IH[OF conf wt\<^sub>2 tconf] by blast
    ultimately show ?thesis by(fastforce intro:WTrtFAssNT)
  qed
next
  case RedFAss thus ?case by(auto simp del:fun_upd_apply)
next
  case RedFAssNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (CallObj e s ta e' s' M es T E)
  have red: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>"
   and IH: "\<And>E T. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk>
                 \<Longrightarrow> \<exists>U. P,E,hp s' \<turnstile> e' : U \<and> P \<turnstile> U \<le> T"
   and conf: "E \<turnstile> s \<surd>" and wt: "P,E,hp s \<turnstile> e\<bullet>M(es) : T"
   and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  -- "We distinguish if @{term e} has type @{term NT} or a Class type"
  from wt show ?case
  proof(rule WTrt_elim_cases)
    fix T' C Ts meth D Us
    assume wte: "P,E,hp s \<turnstile> e : T'" and icto: "class_type_of' T' = \<lfloor>C\<rfloor>"
      and method: "P \<turnstile> C sees M:Ts\<rightarrow>T = meth in D"
      and wtes: "P,E,hp s \<turnstile> es [:] Us" and subs: "P \<turnstile> Us [\<le>] Ts"
    obtain U where wte': "P,E,hp s' \<turnstile> e' : U" and UsubC: "P \<turnstile> U \<le> T'"
      using IH[OF conf wte tconf] by blast
    show ?thesis
    proof(cases "U = NT")
      case True
      moreover have "P,E,hp s' \<turnstile> es [:] Us"
        by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
      ultimately show ?thesis using wte' by(blast intro!:WTrtCallNT)
    next
      case False
      with icto UsubC obtain C'
        where icto': "class_type_of' U = \<lfloor>C'\<rfloor>" and "subclass": "P \<turnstile> C' \<preceq>\<^sup>* C"
        by(rule widen_is_class_type_of)

      obtain Ts' T' meth' D'
        where method': "P \<turnstile> C' sees M:Ts'\<rightarrow>T' = meth' in D'"
        and subs': "P \<turnstile> Ts [\<le>] Ts'" and sub': "P \<turnstile> T' \<le> T"
        using Call_lemma[OF method "subclass" wf] by fast
      have wtes': "P,E,hp s' \<turnstile> es [:] Us"
        by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
      show ?thesis using wtes' wte' icto' subs method' subs' sub' by(blast intro:widens_trans)
    qed
  next
    fix Ts
    assume "P,E,hp s \<turnstile> e:NT"
    hence "P,E,hp s' \<turnstile> e' : NT" using IH[OF conf _ tconf] by fastforce
    moreover
    fix Ts assume wtes: "P,E,hp s \<turnstile> es [:] Ts"
    have "P,E,hp s' \<turnstile> es [:] Ts"
      by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
    ultimately show ?thesis by(blast intro!:WTrtCallNT)
  qed
next
  case (CallParams es s ta es' s' v M T E)
  have reds: "extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle>"
   and IH: "\<And>Ts E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> es [:] Ts; P,hp s \<turnstile> t \<surd>t\<rbrakk>
           \<Longrightarrow> \<exists>Ts'. P,E,hp s' \<turnstile> es' [:] Ts' \<and> P \<turnstile> Ts' [\<le>] Ts"
   and conf: "E \<turnstile> s \<surd>" and wt: "P,E,hp s \<turnstile> Val v\<bullet>M(es) : T"
   and tconf: "P,hp s \<turnstile> t \<surd>t" by fact+
  from wt show ?case
  proof (rule WTrt_elim_cases)
    fix U C Ts meth D Us
    assume wte: "P,E,hp s \<turnstile> Val v : U" and icto: "class_type_of' U = \<lfloor>C\<rfloor>"
      and "P \<turnstile> C sees M:Ts\<rightarrow>T = meth in D"
      and wtes: "P,E,hp s \<turnstile> es [:] Us" and "P \<turnstile> Us [\<le>] Ts"
    moreover have "P,E,hp s' \<turnstile> Val v : U"
      by(rule WTrt_hext_mono[OF wte reds_hext_incr[OF reds]])
    moreover obtain Us' where "P,E,hp s' \<turnstile> es' [:] Us'" "P \<turnstile> Us' [\<le>] Us"
      using IH[OF conf wtes tconf] by blast
    ultimately show ?thesis by(fastforce intro:WTrtCall widens_trans)
  next
    fix Us
    assume null: "P,E,hp s \<turnstile> Val v : NT" and wtes: "P,E,hp s \<turnstile> es [:] Us"
    from null have "v = Null" by simp
    moreover
    obtain Us' where "P,E,hp s' \<turnstile> es' [:] Us' \<and> P \<turnstile> Us' [\<le>] Us"
      using IH[OF conf wtes tconf] by blast
    ultimately show ?thesis by(fastforce intro:WTrtCallNT)
  qed
next
  case (RedCall s a U M Ts T pns body D vs T' E)
  have hp: "typeof_addr (hp s) a = \<lfloor>U\<rfloor>"
    and method: "P \<turnstile> class_type_of U sees M: Ts\<rightarrow>T = \<lfloor>(pns,body)\<rfloor> in D"
    and wt: "P,E,hp s \<turnstile> addr a\<bullet>M(map Val vs) : T'" by fact+
  obtain Ts' where wtes: "P,E,hp s \<turnstile> map Val vs [:] Ts'"
    and subs: "P \<turnstile> Ts' [\<le>] Ts" and T'isT: "T' = T"
    using wt method hp wf by(auto 4 3 dest: sees_method_fun)
  from wtes subs have length_vs: "length vs = length Ts"
    by(auto simp add: WTrts_conv_list_all2 dest!: list_all2_lengthD)
  have UsubD: "P \<turnstile> ty_of_htype U \<le> Class (class_type_of U)"
    by(cases U)(simp_all add: widen_array_object)
  from sees_wf_mdecl[OF wf method] obtain T''
    where wtabody: "P,[this#pns [\<mapsto>] Class D#Ts] \<turnstile> body :: T''"
    and T''subT: "P \<turnstile> T'' \<le> T" and length_pns: "length pns = length Ts"
    by(fastforce simp:wf_mdecl_def simp del:map_upds_twist)
  from wtabody have "P,empty(this#pns [\<mapsto>] Class D#Ts),hp s \<turnstile> body : T''"
    by(rule WT_implies_WTrt)
  hence "P,E(this#pns [\<mapsto>] Class D#Ts),hp s \<turnstile> body : T''"
    by(rule WTrt_env_mono) simp
  hence "P,E,hp s \<turnstile> blocks (this#pns) (Class D#Ts) (Addr a#vs) body : T''"
    using wtes subs hp sees_method_decl_above[OF method] length_vs length_pns UsubD
    by(auto simp add:wt_blocks rel_list_all2_Cons2 intro: widen_trans)
  with T''subT T'isT show ?case by blast
next
  case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
  from `P,t \<turnstile> \<langle>a\<bullet>M(vs),hp s\<rangle> -ta\<rightarrow>ext \<langle>va,h'\<rangle>` have "hp s \<unlhd> h'" by(rule red_external_hext)
  with `P,E,hp s \<turnstile> addr a\<bullet>M(map Val vs) : T`
  have "P,E,h' \<turnstile> addr a\<bullet>M(map Val vs) : T" by(rule WTrt_hext_mono)
  moreover from `typeof_addr (hp s) a = \<lfloor>U\<rfloor>` `P \<turnstile> class_type_of U sees M: Ts\<rightarrow>T' = Native in D` `P,E,hp s \<turnstile> addr a\<bullet>M(map Val vs) : T`
  have "P,hp s \<turnstile> a\<bullet>M(vs) : T'"
    by(fastforce simp add: external_WT'_iff dest: sees_method_fun)
  ultimately show ?case using RedCallExternal
    by(auto 4 3 intro: red_external_conf_extRet[OF wf] intro!: wt_external_call simp add: sconf_def dest: sees_method_fun[where C="class_type_of U"])
next
  case RedCallNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (BlockRed e h x V vo ta e' h' x' T T' E)
  note IH = `\<And>T E. \<lbrakk>E \<turnstile> (h, x(V := vo)) \<surd>; P,E,hp (h, x(V := vo)) \<turnstile> e : T; P,hp (h, x(V := vo)) \<turnstile> t \<surd>t\<rbrakk>
             \<Longrightarrow> \<exists>T'. P,E,hp (h', x') \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T`[simplified]
  from `P,E,hp (h, x) \<turnstile> {V:T=vo; e} : T'` have "P,E(V\<mapsto>T),h \<turnstile> e : T'" by(cases vo, auto)
  moreover from `E \<turnstile> (h, x) \<surd>` `P,E,hp (h, x) \<turnstile> {V:T=vo; e} : T'`
  have "(E(V \<mapsto> T)) \<turnstile> (h, x(V := vo)) \<surd>"
    by(cases vo)(simp add: lconf_def sconf_def,auto simp add: sconf_def conf_def intro: lconf_upd2)
  ultimately obtain T'' where wt': "P,E(V\<mapsto>T),h' \<turnstile> e' : T''" "P \<turnstile> T'' \<le> T'" using `P,hp (h, x) \<turnstile> t \<surd>t`
    by(auto dest: IH)
  { fix v
    assume vo: "x' V = \<lfloor>v\<rfloor>"
    from `(E(V \<mapsto> T)) \<turnstile> (h, x(V := vo)) \<surd>` `extTA,P,t \<turnstile> \<langle>e,(h, x(V := vo))\<rangle> -ta\<rightarrow> \<langle>e',(h', x')\<rangle>` `P,E(V\<mapsto>T),h \<turnstile> e : T'`
    have "P,h' \<turnstile> x' (:\<le>) (E(V \<mapsto> T))" by(auto simp add: sconf_def dest: red_preserves_lconf)
    with vo have "\<exists>T'. typeof\<^bsub>h'\<^esub> v = \<lfloor>T'\<rfloor> \<and> P \<turnstile> T' \<le> T" by(fastforce simp add: sconf_def lconf_def conf_def)
    then obtain T' where "typeof\<^bsub>h'\<^esub> v = \<lfloor>T'\<rfloor>" "P \<turnstile> T' \<le> T" by blast
    hence ?case using wt' vo by(auto) }
  moreover
  { assume "x' V = None" with wt' have ?case by(auto) }
  ultimately show ?case by blast
next
  case RedBlock thus ?case by auto
next
  case (SynchronizedRed1 o' s ta o'' s' e T E)
  have red: "extTA,P,t \<turnstile> \<langle>o',s\<rangle> -ta\<rightarrow> \<langle>o'',s'\<rangle>" by fact
  have IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> o' : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> o'' : T' \<and> P \<turnstile> T' \<le> T" by fact
  have conf: "E \<turnstile> s \<surd>" by fact
  have wt: "P,E,hp s \<turnstile> sync(o') e : T" by fact+
  thus ?case
  proof(rule WTrt_elim_cases)
    fix To
    assume wto: "P,E,hp s \<turnstile> o' : To"
      and refT: "is_refT To"
      and wte: "P,E,hp s \<turnstile> e : T"
    from IH[OF conf wto `P,hp s \<turnstile> t \<surd>t`] obtain To' where "P,E,hp s' \<turnstile> o'' : To'" and sub: "P \<turnstile> To' \<le> To" by auto
    moreover have "P,E,hp s' \<turnstile> e : T"
      by(rule WTrt_hext_mono[OF wte red_hext_incr[OF red]])
    moreover have "is_refT To'" using refT sub by(auto intro: widen_refT)
    ultimately show ?thesis by(auto)
  qed
next
  case SynchronizedNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case LockSynchronized thus ?case by(auto)
next
  case (SynchronizedRed2 e s ta e' s' a T E)
  have red: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>" by fact
  have IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T" by fact
  have conf: "E \<turnstile> s \<surd>" by fact
  have wt: "P,E,hp s \<turnstile> insync(a) e : T" by fact
  thus ?case
  proof(rule WTrt_elim_cases)
    fix Ta
    assume "P,E,hp s \<turnstile> e : T"
      and hpa: "typeof_addr (hp s) a = \<lfloor>Ta\<rfloor>"
    from `P,E,hp s \<turnstile> e : T` conf `P,hp s \<turnstile> t \<surd>t` obtain T'
      where "P,E,hp s' \<turnstile> e' : T'" "P \<turnstile> T' \<le> T" by(blast dest: IH)
    moreover from red have hext: "hp s \<unlhd> hp s'" by(auto dest: red_hext_incr)
    with hpa have "P,E,hp s' \<turnstile> addr a : ty_of_htype Ta"
      by(auto intro: typeof_addr_hext_mono)
    ultimately show ?thesis by auto
  qed
next
  case UnlockSynchronized thus ?case by(auto)
next
  case SeqRed thus ?case
    apply(auto)
    apply(drule WTrt_hext_mono[OF _ red_hext_incr], assumption)
    by auto
next
  case (CondRed b s ta b' s' e1 e2 T E)
  have red: "extTA,P,t \<turnstile> \<langle>b,s\<rangle> -ta\<rightarrow> \<langle>b',s'\<rangle>" by fact
  have IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> b : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> b' : T' \<and> P \<turnstile> T' \<le> T" by fact
  have conf: "E \<turnstile> s \<surd>" by fact
  have wt: "P,E,hp s \<turnstile> if (b) e1 else e2 : T" by fact
  thus ?case
  proof(rule WTrt_elim_cases)
    fix T1 T2
    assume wtb: "P,E,hp s \<turnstile> b : Boolean"
      and wte1: "P,E,hp s \<turnstile> e1 : T1"
      and wte2: "P,E,hp s \<turnstile> e2 : T2"
      and lub: "P \<turnstile> lub(T1, T2) = T"
    from IH[OF conf wtb `P,hp s \<turnstile> t \<surd>t`] have "P,E,hp s' \<turnstile> b' : Boolean" by(auto)
    moreover have "P,E,hp s' \<turnstile> e1 : T1"
      by(rule WTrt_hext_mono[OF wte1 red_hext_incr[OF red]])
    moreover have "P,E,hp s' \<turnstile> e2 : T2"
      by(rule WTrt_hext_mono[OF wte2 red_hext_incr[OF red]])
    ultimately show ?thesis using lub by auto
  qed
next
  case (ThrowRed e s ta e' s' T E)
  have IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T" by fact
  have conf: "E \<turnstile> s \<surd>" by fact
  have wt: "P,E,hp s \<turnstile> throw e : T" by fact
  then obtain T'
    where wte: "P,E,hp s \<turnstile> e : T'"
    and nobject: "P \<turnstile> T' \<le> Class Throwable" by auto
  from IH[OF conf wte `P,hp s \<turnstile> t \<surd>t`] obtain T''
    where wte': "P,E,hp s' \<turnstile> e' : T''"
    and PT'T'': "P \<turnstile> T'' \<le> T'" by blast
  from nobject PT'T'' have "P \<turnstile> T'' \<le> Class Throwable"
    by(auto simp add: widen_Class)(erule notE, rule rtranclp_trans)
  hence "P,E,hp s' \<turnstile> throw e' : T" using wte' PT'T''
    by -(erule WTrtThrow)
  thus ?case by(auto)
next
  case RedThrowNull thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case (TryRed e s ta e' s' C V e2 T E)
  have red: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>" by fact
  have IH: "\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T" by fact
  have conf: "E \<turnstile> s \<surd>" by fact
  have wt: "P,E,hp s \<turnstile> try e catch(C V) e2 : T" by fact
  thus ?case
  proof(rule WTrt_elim_cases)
    fix T1
    assume wte: "P,E,hp s \<turnstile> e : T1"
      and wte2: "P,E(V \<mapsto> Class C),hp s \<turnstile> e2 : T"
      and sub: "P \<turnstile> T1 \<le> T"
    from IH[OF conf wte `P,hp s \<turnstile> t \<surd>t`] obtain T1' where "P,E,hp s' \<turnstile> e' : T1'" and "P \<turnstile> T1' \<le> T1" by(auto)
    moreover have "P,E(V \<mapsto> Class C),hp s' \<turnstile> e2 : T"
      by(rule WTrt_hext_mono[OF wte2 red_hext_incr[OF red]])
    ultimately show ?thesis using sub by(auto elim: widen_trans)
  qed
next
  case RedTryFail thus ?case unfolding sconf_def
    by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
  case RedSeq thus ?case by auto
next
  case RedCondT thus ?case by(auto dest: is_lub_upper)
next
  case RedCondF thus ?case by(auto dest: is_lub_upper)
next
  case RedWhile thus ?case by(fastforce)
next
  case RedTry thus ?case by auto
next
  case RedTryCatch thus ?case by(fastforce)
next
  case (ListRed1 e s ta e' s' es Ts E)
  note IH = `\<And>T E. \<lbrakk>E \<turnstile> s \<surd>; P,E,hp s \<turnstile> e : T; P,hp s \<turnstile> t \<surd>t\<rbrakk> \<Longrightarrow> \<exists>T'. P,E,hp s' \<turnstile> e' : T' \<and> P \<turnstile> T' \<le> T`
  from `P,E,hp s \<turnstile> e # es [:] Ts` obtain T Ts' where "Ts = T # Ts'" "P,E,hp s \<turnstile> e : T" "P,E,hp s \<turnstile> es [:] Ts'" by auto
  with IH[of E T] `E \<turnstile> s \<surd>` WTrts_hext_mono[OF `P,E,hp s \<turnstile> es [:] Ts'` red_hext_incr[OF `extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle>`]]
  show ?case using `P,hp s \<turnstile> t \<surd>t` by(auto simp add: list_all2_Cons2 intro: widens_refl)
next
  case ListRed2 thus ?case
    by(fastforce dest: hext_typeof_mono[OF reds_hext_incr])
qed(fastforce)+

end


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

theory GraphLang

imports
  "CLib.TypHeapLib"
  "Lib.SplitRule"
  "CommonOps"

begin

text \<open>Note that machine states here are assumed to be countable and
are thus represented by naturals.\<close>

datatype variable =
    VarNone
  | VarWord8 word8
  | VarWord16 word16
  | VarWord32 word32
  | VarWord64 word64
  | VarMem "machine_word \<Rightarrow> word8"
  | VarDom "machine_word set"
  | VarGhostState "ghost_assertions"
  | VarHTD "heap_typ_desc"
  | VarMS "unit \<times> nat"
  | VarBool bool

text \<open>States are a mapping from names to the variable type, which is
a union of the available names.\<close>

datatype state = State "string \<Rightarrow> variable"

text \<open>Accessors for grabbing variables by name and expected type.\<close>

definition
  "var_acc nm st = (case st of State f \<Rightarrow> f nm)"

definition
  "var_word8 nm st = (case var_acc nm st of
    VarWord8 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_word16 nm st = (case var_acc nm st of
    VarWord16 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_word32 nm st = (case var_acc nm st of
    VarWord32 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_word64 nm st = (case var_acc nm st of
    VarWord64 w \<Rightarrow> w | _ \<Rightarrow> 0)"

definition
  "var_ghoststate nm st = (case var_acc nm st of
    VarGhostState arr \<Rightarrow> arr | _ \<Rightarrow> (\<lambda>_. 0))"

definition
  "var_mem nm st = (case var_acc nm st of
    VarMem m \<Rightarrow> m | _ \<Rightarrow> \<lambda>_. 0)"

definition
  "var_dom nm st = (case var_acc nm st of
    VarDom d \<Rightarrow> d | _ \<Rightarrow> {})"

definition
  "var_htd nm st = (case var_acc nm st of
    VarHTD htd \<Rightarrow> htd | _ \<Rightarrow> empty_htd)"

definition
  "var_ms nm st = (case var_acc nm st of
    VarMS ms \<Rightarrow> ms | _ \<Rightarrow> ((), 0))"

definition
  "var_bool nm st = (case var_acc nm st of
    VarBool bool \<Rightarrow> bool | _ \<Rightarrow> False)"

text \<open>The variable updator.\<close>

definition
  "var_upd nm v st = (case st of State f \<Rightarrow> State (f (nm := v)))"

definition
  "default_state = State (\<lambda>_. VarNone)"

text \<open>The type of nodes.\<close>

datatype next_node =
    NextNode nat | Ret | Err

datatype node =
    Basic next_node "(string \<times> (state \<Rightarrow> variable)) list"
  | Cond next_node next_node "state \<Rightarrow> bool"
  | Call next_node string "(state \<Rightarrow> variable) list" "string list"

definition Skip where
  "Skip nn = Cond nn nn (\<lambda>x. True)"

text \<open>The type for a total graph function, including list of inputs,
  list of outputs, graph, and entry point.\<close>

datatype graph_function
  = GraphFunction "string list" "string list" "nat \<Rightarrow> node option" nat

primrec entry_point where
  "entry_point (GraphFunction inputs outputs graph ep) = ep"

primrec function_graph where
  "function_graph (GraphFunction inputs outputs graph ep) = graph"

primrec function_inputs where
  "function_inputs (GraphFunction inputs outputs graph ep) = inputs"

primrec function_outputs where
  "function_outputs (GraphFunction inputs outputs graph ep) = outputs"

text \<open>The definition of execution, including a stack to allow function calls.\<close>

definition
  save_vals :: "string list \<Rightarrow> variable list \<Rightarrow> state \<Rightarrow> state"
where
 "save_vals vars vals st = fold (\<lambda>(var, val). var_upd var val) (zip vars vals) st"

definition
  init_vars :: "string list \<Rightarrow> (state \<Rightarrow> variable) list \<Rightarrow> state \<Rightarrow> state"
where
  "init_vars vars accs st = save_vals vars (map (\<lambda>i. i st) accs) default_state"

definition
  acc_vars :: "string list \<Rightarrow> state \<Rightarrow> variable list"
where
  "acc_vars vars st = map (\<lambda>v. var_acc v st) vars"

definition
  return_vars :: "string list \<Rightarrow> string list \<Rightarrow> state \<Rightarrow> state \<Rightarrow> state"
where
  "return_vars inner outer inner_st = save_vals outer (acc_vars inner inner_st)"

definition
  upd_vars :: "(string \<times> (state \<Rightarrow> variable)) list \<Rightarrow> state \<Rightarrow> state"
where
  "upd_vars upds st = save_vals (map fst upds) (map (\<lambda>(nm, vf). vf st) upds) st"

type_synonym stack = "(next_node \<times> state \<times> string) list"

primrec
  upd_stack :: "next_node \<Rightarrow> (state \<Rightarrow> state) \<Rightarrow> stack \<Rightarrow> stack"
where
    "upd_stack nn stf (x # xs) = (nn, stf (fst (snd x)), snd (snd x)) # xs"
  | "upd_stack nn stf [] = []"

primrec
  exec_node :: "(string \<Rightarrow> graph_function option)
        \<Rightarrow> state \<Rightarrow> node \<Rightarrow> stack \<Rightarrow> stack set"
where
    "exec_node Gamma st (Basic cont upds) stack
        = {upd_stack cont (K (upd_vars upds st)) stack}"
  | "exec_node Gamma st (Cond left right cond) stack
        = {upd_stack (if cond st then left else right) id stack}"
  | "exec_node Gamma st (Call cont fname inputs outputs) stack
        = (case Gamma fname of None \<Rightarrow> {upd_stack Err id stack}
            | Some (GraphFunction inps outps graph ep)
                \<Rightarrow> {(NextNode ep, init_vars inps inputs st, fname)
                        # stack})"

primrec
  exec_node_return :: "(string \<Rightarrow> graph_function option)
        \<Rightarrow> state \<Rightarrow> node \<Rightarrow> stack \<Rightarrow> stack set"
where
    "exec_node_return _ _ (Basic _ _) stack = {}"
  | "exec_node_return _ _ (Cond _ _ _) stack = {}"
  | "exec_node_return Gamma st (Call cont fname inputs outputs) stack
        = (case Gamma fname of None \<Rightarrow> {}
            | Some (GraphFunction inps outps graph ep)
                \<Rightarrow> {upd_stack cont (return_vars outps outputs st) stack})"

text \<open>The single-step relation on graph states.\<close>

definition
  exec_graph_step :: "(string \<Rightarrow> graph_function option)
        \<Rightarrow> (stack \<times> stack) set"
where
    "exec_graph_step Gamma = {(stack, stack'). case stack of
            (NextNode nn, st, fname) # _ \<Rightarrow>
                (case Gamma fname of None \<Rightarrow> False
                    | Some (GraphFunction _ _ graph _) \<Rightarrow>
                        (case graph nn of None \<Rightarrow> stack' = upd_stack Err id stack
                            | Some node \<Rightarrow> stack' \<in> exec_node Gamma st node stack))
          | (Ret, st, _) # (NextNode nn, _, fname) # _ \<Rightarrow>
                (case Gamma fname of None \<Rightarrow> False
                    | Some (GraphFunction _ _ graph _) \<Rightarrow>
                        (case graph nn of None \<Rightarrow> stack' = upd_stack Err id (tl stack)
                            | Some node \<Rightarrow> stack' \<in> exec_node_return Gamma st node (tl stack)))
          | [] \<Rightarrow> False
          | [_] \<Rightarrow> False \<comment> \<open>note NextNode case is handled\<close>
          | _ \<Rightarrow> stack' = upd_stack Err id (tl stack)
      }"

text \<open>Multi-step relations.\<close>

definition exec_graph
where "exec_graph Gamma = rtrancl (exec_graph_step Gamma)"

definition exec_graph_n
where "exec_graph_n Gamma n = exec_graph_step Gamma ^^ n"

lemma relpow_Suc_simp2:
  "R ^^ Suc n = R O R ^^ n"
  apply safe
   apply (erule relpow_Suc_E2, blast)
  apply (blast intro: relpow_Suc_I2)
  done

lemma exec_graph_n_take_step:
  "\<lbrakk> (stack, stack') \<in> exec_graph_n GGamma n;
    \<lbrakk> n = 0; stack' = stack \<rbrakk> \<Longrightarrow> P;
    \<And>stack''. \<lbrakk> n > 0; (stack, stack'') \<in> exec_graph_step GGamma;
            (stack'', stack') \<in> exec_graph_n GGamma (n - 1) \<rbrakk>
        \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (cases n, simp_all only: exec_graph_n_def relpow_Suc_simp2)
   apply simp
  apply clarsimp
  done

lemma exec_graph_take_step:
  "\<lbrakk> ((NextNode m, gst, fname) # stack, stack') \<in> exec_graph_n GGamma n;
            GGamma fname = Some gf; function_graph gf m = Some node \<rbrakk>
    \<Longrightarrow> (n = 0 \<and> stack' = (NextNode m, gst, fname) # stack)
    \<or> (\<exists>stack''. n \<ge> 1
            \<and> stack'' \<in> exec_node GGamma gst node
                    ((NextNode m, gst, fname) # stack)
            \<and> (stack'', stack') \<in> exec_graph_n GGamma (n - 1))"
  apply (erule exec_graph_n_take_step)
   apply simp
  apply (clarsimp simp: exec_graph_step_def split: graph_function.split_asm)
  apply blast
  done

definition
  continuing :: "stack \<Rightarrow> bool"
where
  "continuing st = (case st of [] \<Rightarrow> False
    | [(NextNode _, _, _)] \<Rightarrow> True | [_] \<Rightarrow> False | _ \<Rightarrow> True)"

lemma continuing_simps[simp]:
  "\<not> continuing []"
  "continuing [(unn, st, g)] = (unn \<noteq> Ret \<and> unn \<noteq> Err)"
  "continuing ((Ret, st, g) # stk) = (stk \<noteq> [])"
  "continuing (stf # stf' # stk)"
  "continuing ((NextNode nn, st, g) # stk)"
  "continuing ((Err, st, g) # stk) = (stk \<noteq> [])"
  by (simp_all add: continuing_def split: next_node.split list.split)

lemma consume_Not_eq:
  "(\<not> P) = Q \<Longrightarrow> P = (\<not> Q)"
  by clarsimp

lemma exec_node_case_helper:
  "(stk' \<in> exec_node Gamma st node stk)
    = (case node of Basic _ _ \<Rightarrow> stk' \<in> id (exec_node Gamma) st node stk
        | _ \<Rightarrow> stk' \<in> id (exec_node Gamma) st node stk)"
  "(stk' \<in> exec_node_return Gamma st node stk)
    = (case node of Basic _ _ \<Rightarrow> stk' \<in> id (exec_node_return Gamma) st node stk
        | _ \<Rightarrow> stk' \<in> id (exec_node_return Gamma) st node stk)"
  by (simp_all split: node.split)

lemmas splits_raw = prod.split list.split option.split
    next_node.split graph_function.split node.split
lemmas splits_cooked = splits_raw[where P=Not, THEN consume_Not_eq]
    option.split[where P="\<lambda>S. x \<notin> S", THEN consume_Not_eq]
    graph_function.split[where P="\<lambda>S. x \<notin> S", THEN consume_Not_eq] for x

lemmas all_exec_graph_step_cases = exec_graph_step_def[THEN eqset_imp_iff,
    simplified, unfolded exec_node_case_helper splits_cooked, simplified,
    unfolded splits_cooked, simplified]

lemma exec_node_stack_extend:
  "continuing stack \<Longrightarrow>
    (stack' \<in> exec_node Gamma st node (stack @ xs))
        = (\<exists>stack''. stack' = stack'' @ xs
                \<and> stack'' \<in> exec_node Gamma st node stack)"
  apply (cases node, simp_all)
  apply (simp_all add: continuing_def
                split: list.split_asm prod.split_asm next_node.split_asm)
  apply (auto split: option.split graph_function.split)
  done

lemma exec_node_return_stack_extend:
  "continuing stack \<Longrightarrow>
    (stack' \<in> exec_node_return Gamma st node (stack @ xs))
        = (\<exists>stack''. stack' = stack'' @ xs
                \<and> stack'' \<in> exec_node_return Gamma st node stack)"
  apply (cases node, simp_all)
  apply (simp_all add: continuing_def
                split: list.split_asm prod.split_asm next_node.split_asm)
  apply (auto split: option.split graph_function.split)
  done

lemma exec_graph_step_stack_extend:
  "continuing stack \<Longrightarrow>
    ((stack @ xs, stack') \<in> exec_graph_step Gamma)
    = (\<exists>stack''. stack' = stack'' @ xs
        \<and> (stack, stack'') \<in> exec_graph_step Gamma)"
  using exec_node_stack_extend[where stack'=stack' and stack=stack
            and Gamma=Gamma and xs=xs]
        exec_node_return_stack_extend[where stack'=stack' and stack="tl stack"
            and Gamma=Gamma and xs=xs]
  apply (simp add: exec_graph_step_def)
  apply (cases stack, simp_all)
  apply clarsimp
  apply (case_tac a, simp_all)
    apply (clarsimp split: option.split graph_function.split)
   apply (clarsimp simp: neq_Nil_conv split: list.split)
   apply (clarsimp split: next_node.split option.split graph_function.split)
  apply (clarsimp simp: neq_Nil_conv split: list.split)
  done

lemma exec_graph_n_stack_extend:
  "continuing stack \<Longrightarrow>
    ((stack @ xs, stack') \<in> exec_graph_n Gamma n)
    = (\<exists>stack'' n'. (stack, stack'') \<in> (exec_graph_step Gamma
                \<inter> {(st, _). continuing st}) ^^ n'
        \<and> ((n' < n \<and> \<not> continuing stack''
                \<and> (stack'' @ xs, stack') \<in> exec_graph_n Gamma (n - n'))
            \<or> (stack' = stack'' @ xs \<and> n' = n)))"
  unfolding exec_graph_n_def
proof (induct n arbitrary: stack)
  case 0
  show ?case
    by auto[1]
next
  case (Suc n stack)
  show ?case
    apply (simp only: relpow_Suc_simp2)
    apply (rule iffI)
     apply (clarsimp simp: exec_graph_step_stack_extend Suc.prems)
     apply (case_tac "continuing stack''")
      apply (frule Suc.hyps, clarsimp)
      apply (rule_tac x="stack''a" in exI, rule_tac x="Suc n'" in exI)
      apply (simp only: relpow_Suc_simp2, clarsimp)
      apply (blast intro: Suc.prems)
     apply (rule_tac x="stack''" in exI, rule_tac x=1 in exI)
     apply (auto simp: Suc.prems)[1]
    apply (clarsimp)
    apply (case_tac n', simp_all only: minus_nat.diff_0 relpow_Suc_simp2)
     apply auto[1]
    apply clarsimp
    apply (rule_tac b="y @ xs" in relcompI)
     apply (simp add: exec_graph_step_stack_extend Suc.prems)
    apply (case_tac "nat = 0")
     apply auto[1]
    apply (subst Suc.hyps)
     apply (case_tac nat, simp_all only: relpow_Suc_simp2, auto)[1]
    apply auto[1]
    done
qed

definition
  "init_state fname gfun xs =
    (NextNode (entry_point gfun), save_vals (function_inputs gfun) xs default_state, fname)"

lemma exec_graph_step_nonempty:
  "\<lbrakk> (stack, stack') \<in> exec_graph_step Gamma ^^ n; stack \<noteq> [] \<rbrakk>
    \<Longrightarrow> stack' \<noteq> []"
  by (cases n, auto simp: all_exec_graph_step_cases
                   split: graph_function.split_asm)

lemma relpow_mono:
  "\<lbrakk> R \<subseteq> (S :: ('a \<times> 'a) set) \<rbrakk> \<Longrightarrow> R ^^ n \<subseteq> S ^^ n"
  by (induct n, auto)

lemma drop_eq_Cons:
  "(drop n xs = x # ys) = (\<exists>zs. length zs = n \<and> xs = zs @ x # ys)"
  apply (induct n arbitrary: xs)
   apply simp
  apply (case_tac xs, auto simp add: length_Suc_conv)
  done

lemma exec_graph_step_n_Err:
  "(((Err, st, graph) # stack, stack') \<in> exec_graph_n Gamma n)
    \<Longrightarrow> stack' = upd_stack Err id (drop n ((Err, st, graph) # stack))
        \<and> drop n ((Err, st, graph) # stack) \<noteq> []"
proof (induct n arbitrary: stack')
  case 0
  show ?case using 0
    by (auto simp add: exec_graph_n_def)
next
  case (Suc n)
  show ?case using Suc.prems
    apply (clarsimp simp: exec_graph_n_def relcomp_unfold linorder_not_le)
    apply (drule exec_graph_step_def[THEN eqset_imp_iff, THEN iffD1])
    apply (case_tac y, simp_all)
    apply (drule Suc.hyps[rotated, unfolded exec_graph_n_def])
    apply (simp only: neq_Nil_conv)
    apply (clarsimp simp: linorder_not_le drop_eq_Cons)
    apply (clarsimp split: list.split_asm)
    apply (case_tac zs, simp_all)
    done
qed

text \<open>Possibly infinite traces.\<close>

definition nat_trace_rel
  where "nat_trace_rel cont r = {tr. (\<forall>n. (tr n = None \<longrightarrow> tr (Suc n) = None)
    \<and> (tr (Suc n) \<noteq> None \<longrightarrow> (the (tr n), the (tr (Suc n))) \<in> r)
    \<and> (tr n \<noteq> None \<and> cont (the (tr n)) \<longrightarrow> tr (Suc n) \<noteq> None))}"

type_synonym trace = "(nat \<Rightarrow> stack option)"

definition
  trace_end :: "(nat \<Rightarrow> 'a option) \<Rightarrow> 'a option"
where
  "trace_end tr = (if \<exists>n. tr n = None then tr (Max (dom tr)) else None)"

lemma nat_trace_rel_Some_range:
  "tr \<in> nat_trace_rel cont r \<Longrightarrow> tr n = Some v
    \<Longrightarrow> \<forall>i \<le> n. \<exists>v'. tr i = Some v'"
  apply (induct n arbitrary: v, simp_all)
  apply (simp add: nat_trace_rel_def le_Suc_eq)
  apply (drule_tac x=n in spec, clarsimp)
  done

lemma trace_None_dom_subset:
  "tr n = None \<Longrightarrow> tr \<in> nat_trace_rel cont R
    \<Longrightarrow> dom tr \<subseteq> {..< n}"
  apply clarsimp
  apply (drule_tac n=x in nat_trace_rel_Some_range, simp+)
  apply (drule_tac x="n" in spec)
  apply simp
  done

lemma nat_trace_Max_dom_None:
  "tr \<in> nat_trace_rel cont R \<Longrightarrow> tr n \<noteq> None \<Longrightarrow> (tr (Max (dom tr)) \<noteq> None)"
  apply (rule notI)
  apply (frule(1) trace_None_dom_subset)
  apply (cases "dom tr = {}")
   apply clarsimp
  apply (drule Max_in[rotated])
   apply (simp add: finite_subset)
  apply clarsimp
  done

lemma trace_end_NoneD:
  "trace_end tr = None \<Longrightarrow> tr \<in> nat_trace_rel cont r
    \<Longrightarrow> tr = (\<lambda>_. None) \<or> (\<exists>f. tr = Some o f)"
  apply (subst disj_commute, rule disjCI)
  apply (clarsimp simp: fun_eq_iff)
  apply (simp add: trace_end_def split: if_split_asm)
   apply (metis nat_trace_Max_dom_None not_None_eq)
  apply (rule_tac x="the o tr" in exI, simp)
  done

lemma trace_end_SomeD:
  "trace_end tr = Some v \<Longrightarrow> tr \<in> nat_trace_rel cont r
    \<Longrightarrow> \<exists>n. tr n = Some v \<and> tr (Suc n) = None \<and> \<not> cont v"
  apply (clarsimp simp: trace_end_def split: if_split_asm)
  apply (rule exI, rule conjI, assumption)
  apply (case_tac "tr (Suc (Max (dom tr)))")
   apply (simp add: nat_trace_rel_def)
   apply (metis option.sel option.simps(3))
  apply (cut_tac x="Suc y" for y in Max_ge[OF finite_subset domI])
     apply (erule(1) trace_None_dom_subset[rotated])
    apply simp+
  done

definition
  exec_trace :: "(string \<Rightarrow> graph_function option) \<Rightarrow> string \<Rightarrow> trace set"
where
  "exec_trace Gamma fname
    = {trace. \<exists>gf. Gamma fname = Some gf
        \<and> (\<exists>st. trace 0 = Some [(NextNode (entry_point gf), st, fname)])
        \<and> trace \<in> nat_trace_rel continuing (exec_graph_step Gamma)}"

lemma relpow_nat_trace:
  "((s, s') \<in> r ^^ n) = (\<exists>tr \<in> nat_trace_rel (\<lambda>x. False) r. tr 0 = Some s
    \<and> tr n = Some s' \<and> tr (Suc n) = None)"
  apply (simp add: relpow_fun_conv, safe)
   apply (rule_tac x="\<lambda>x. if x < Suc n then Some (f x) else None" in bexI)
    apply simp
   apply (simp add: nat_trace_rel_def)
  apply (rule_tac x="the o tr" in exI)
  apply (frule(1) nat_trace_rel_Some_range[where n=n])
  apply (clarsimp simp: nat_trace_rel_def)
  done

text \<open>Parsing code for the graph language.\<close>

ML \<open>

structure ParseGraph = struct

exception PARSEGRAPH of string list

val debug = ref false

fun trace s = if (! debug) then writeln s else ()

fun parse_int str = if String.isPrefix "-" str
  then ~ (parse_int (unprefix "-" str))
  else case read_int (raw_explode str)
  of (n, []) => n
    | _ => raise PARSEGRAPH ["read_int:", str]

val s = @{term "s :: state"}

fun parse_n p (n :: ss) = let
    val n = parse_int n
  in funpow_yield n p ss end
  | parse_n _ [] = raise PARSEGRAPH ["parse_n: empty"]

fun mk_binT sz = Word_Lib.mk_wordT sz |> dest_Type |> snd |> hd

val ptr_size_str =
    case @{typ machine_word} of
      @{typ word32} => "32"
    | @{typ word64} => "64"

fun parse_typ ("Word" :: n :: ss) = let
    val n = parse_int n
  in (Word_Lib.mk_wordT n, ss) end
  | parse_typ ("Bool" :: ss) = (@{typ bool}, ss)
  | parse_typ ("Mem" :: ss) = (@{typ "machine_word \<Rightarrow> word8"}, ss)
  | parse_typ ("Dom" :: ss) = (@{typ "machine_word set"}, ss)
  | parse_typ ("HTD" :: ss) = (@{typ heap_typ_desc}, ss)
  | parse_typ ("PMS" :: ss) = (@{typ nat}, ss)
  | parse_typ ("UNIT" :: ss) = (@{typ unit}, ss)
  | parse_typ ("Array" :: ss) = let
    val (el_typ, ss) = parse_typ ss
    val (n, ss) = case ss of (n :: ss) => (parse_int n, ss)
        | [] => raise PARSEGRAPH ["parse_typ: array index"]
  in (Type (@{type_name array}, [el_typ, mk_binT n]), ss) end
  | parse_typ (bad as ("WordArray" :: "50" :: element_size :: ss)) =
      (if element_size = ptr_size_str
      then (@{typ "ghost_assertions"}, ss)
      else raise PARSEGRAPH ("parse_typ: bad ghost assertion codomain" :: bad))
  | parse_typ ("Struct" :: nm :: ss) = (Type (nm, []), ss)
  | parse_typ ("Ptr" :: ss) = let
    val (obj_typ, ss) = parse_typ ss
  in (Type (@{type_name ptr}, [obj_typ]), ss) end
  | parse_typ ss = raise PARSEGRAPH ("parse_typ: malformed" :: ss)

fun parse_lval ("VarUpdate" :: nm :: ss) = let
    val (_, ss) = parse_typ ss (* FIXME: check typ? *)
  in (nm, ss) end
  | parse_lval ss = raise PARSEGRAPH ("parse_lval" :: ss)

fun parse_var ss = parse_lval ("VarUpdate" :: ss)

val opers = Symtab.make [
      ("Plus", @{const_name "plus"}),
      ("Minus", @{const_name "minus"}),
      ("Times", @{const_name "times"}),
      ("Modulus", @{const_name "modulo_class.modulo"}),
      ("DividedBy", @{const_name "divide_class.divide"}),
      ("BWAnd", @{const_name "bitAND"}),
      ("BWOr", @{const_name "bitOR"}),
      ("BWXOR", @{const_name "bitXOR"}),
      ("And", @{const_name "conj"}),
      ("Or", @{const_name "disj"}),
      ("Implies", @{const_name "implies"}),
      ("Equals", @{const_name "HOL.eq"}),
      ("Less", @{const_name "less"}),
      ("LessEquals", @{const_name "less_eq"}),
      ("SignedLess", @{const_name "word_sless"}),
      ("SignedLessEquals", @{const_name "word_sle"}),
      ("Not", @{const_name "Not"}),
      ("BWNot", @{const_name "bitNOT"}),
      ("WordCast", @{const_name "ucast"}),
      ("WordCastSigned", @{const_name "scast"}),
      ("WordArrayAccess", @{const_name "fun_app"}),
      ("WordArrayUpdate", @{const_name "fun_upd"}),
      ("CountLeadingZeroes", @{const_name "bv_clz"}),
      ("CountTrailingZeroes", @{const_name "bv_ctz"}),
      ("True", @{const_name "True"}),
      ("False", @{const_name "False"}),
      ("IfThenElse", @{const_name "If"}),
      ("MemAcc", @{const_name "mem_acc"}),
      ("MemUpdate", @{const_name "mem_upd"}),
      ("MemDom", @{const_name "Set.member"}),
      ("ShiftLeft", @{const_name "bvshl"}),
      ("ShiftRight", @{const_name "bvlshr"}),
      ("SignedShiftRight", @{const_name "bvashr"}),
      ("PValid", @{const_name pvalid}),
      ("PArrayValid", @{const_name parray_valid}),
      ("PAlignValid", @{const_name palign_valid}),
      ("PGlobalValid", @{const_name pglobal_valid}),
      ("PWeakValid", @{const_name pweak_valid}),
      ("HTDUpdate", @{const_name all_htd_updates})
  ]

fun mk_acc nm typ st = (case typ of
        @{typ word8} => @{term var_word8}
      | @{typ word16} => @{term var_word16}
      | @{typ word32} => @{term var_word32}
      | @{typ word64} => @{term var_word64}
      | @{typ "machine_word \<Rightarrow> word8"} => @{term var_mem}
      | @{typ "machine_word set"} => @{term var_dom}
      | @{typ "ghost_assertions"} => @{term var_ghoststate}
      | @{typ "heap_typ_desc"} => @{term var_htd}
      | @{typ "nat"} => @{term var_ms}
      | @{typ bool} => @{term var_bool}
      | Type (@{type_name ptr}, [_]) =>
          (case @{typ "machine_word"} of
            @{typ word32} => @{term var_word32}
          | @{typ word64} => @{term var_word64})
      | _ => raise PARSEGRAPH ["mk_acc", nm, fst (dest_Type typ)])
    $ HOLogic.mk_string nm $ st

fun parse_val ("Num" :: ss) = let
    val (n, ss) = case ss of n :: ss => (n, ss)
        | [] => raise PARSEGRAPH ["parse_val: parsing num, no numeral"]
    val (typ, ss) = parse_typ ss
    val n = parse_int n
  in (HOLogic.mk_number typ n, ss) end
  | parse_val ("Op" :: nm :: ss) = let
    val const = case Symtab.lookup opers nm
      of SOME c => c
      | NONE => raise PARSEGRAPH ["parse_val: unexpected op", nm]
    val (typ, ss) = parse_typ ss
    val (args, ss) = parse_n parse_val ss
    val oper = Const (const, map fastype_of args ---> typ)
  in trace ("parsed oper " ^ nm ^ " and args");
    (list_comb (oper, args), ss) end
  | parse_val ("Var" :: nm :: ss) = let
    val (typ, ss) = parse_typ ss
  in (mk_acc nm typ s, ss) end
  | parse_val ("Type" :: ss) = let
    val (typ, ss) = parse_typ ss
  in (Logic.mk_type typ, ss) end
  | parse_val ("Symbol" :: nm :: ss) = let
    val (_, ss) = parse_typ ss
  in (TermsTypes.symbol_table $ HOLogic.mk_string nm, ss) end
  | parse_val ss = raise PARSEGRAPH ("parse_val: malformed" :: ss)

val parse_lvals = parse_n parse_lval

val parse_vars = parse_n parse_var

fun mk_var_typ T = (case T of
        @{typ word8} => @{term VarWord8}
      | @{typ word16} => @{term VarWord16}
      | @{typ word32} => @{term VarWord32}
      | @{typ word64} => @{term VarWord64}
      | Type (@{type_name word}, [Type (@{type_name signed}, [T2])])
        => let val uT = Type (@{type_name word}, [T2])
        in Abs ("t", T, mk_var_typ uT $ (Const (@{const_name ucast}, T --> uT) $ Bound 0)) end
      | @{typ "machine_word \<Rightarrow> word8"} => @{term VarMem}
      | @{typ "ghost_assertions"} => @{term VarGhostState}
      | @{typ "machine_word set"} => @{term VarDom}
      | @{typ "heap_typ_desc"} => @{term VarHTD}
      | @{typ "unit \<times> nat"} => @{term VarMS}
      | @{typ bool} => @{term VarBool}
      | _ => raise TYPE ("mk_var_typ: unexpected var typ", [T], []))

fun mk_var_term t = betapply (mk_var_typ (fastype_of t), t)

fun parse_val_acc ss = let
    val (t, ss) = parse_val ss
  in (Term.lambda_name ("s", s) (mk_var_term t), ss) end

fun parse_cond ss = let
    val (t, ss) = parse_val ss
  in (Term.lambda_name ("s", s) t, ss) end

val parse_vals = parse_n parse_val_acc

fun mk_NextNode n = @{term NextNode} $ HOLogic.mk_number @{typ nat} n

fun parse_nn "Err" = @{term Err}
  | parse_nn "Ret" = @{term Ret}
  | parse_nn n = mk_NextNode (parse_int n)

fun parse_fun_decl ("Function" :: nm :: ss) = let
    val (xs, ss) = parse_vars ss
    val (ys, ss) = parse_vars ss
  in
    ss = [] orelse raise PARSEGRAPH ("parse_fun_decl: trailing" :: ss);
    (nm, xs, ys)
  end
  | parse_fun_decl ss = raise PARSEGRAPH ("parse_fun_decl: malformed" :: ss)

fun parse_var_and_val_acc ss = let
    val (var, ss) = parse_var ss
    val (v, ss) = parse_val_acc ss
  in (HOLogic.mk_prod (HOLogic.mk_string var, v), ss) end

val mk_stringlist = map HOLogic.mk_string #> HOLogic.mk_list @{typ string}

fun parse_node (n :: ss) = let
    val n = parse_int n
    val (t, ss) = case ss of
      "Cond" :: l :: r :: ss => let
        val l = parse_nn l
        val r = parse_nn r
        val (c, ss) = parse_cond ss
      in (@{term Cond} $ l $ r $ c, ss) end
      | "Basic" :: c :: ss => let
        val c = parse_nn c
        val (upds, ss) = parse_n parse_var_and_val_acc ss
      in (@{term Basic} $ c $ HOLogic.mk_list
            @{typ "string \<times> (state \<Rightarrow> variable)"} upds, ss) end
      | "Call" :: c :: fname :: ss => let
        val c = parse_nn c
        val (args, ss) = parse_vals ss
        val (rets, ss) = parse_vars ss
      in (@{term Call} $ c $ HOLogic.mk_string fname
            $ HOLogic.mk_list @{typ "state \<Rightarrow> variable"} args
            $ mk_stringlist rets, ss) end
      | _ => raise PARSEGRAPH ("parse_node: malformed" :: ss)
  in
    ss = [] orelse raise PARSEGRAPH ("parse_node: trailing" :: ss);
    (n, t)
  end
  | parse_node [] = raise PARSEGRAPH (["parse_node: empty"])

fun parse_fun (["Function" :: ss]) = let
    val (nm, xs, ys) = parse_fun_decl ("Function" :: ss)
  in SOME (nm, (xs, ys, NONE)) end
  | parse_fun (("Function" :: ss) :: sss) = let
    val (nm, xs, ys) = parse_fun_decl ("Function" :: ss)
    val _ = tracing ("Parsing " ^ nm)
    val (node_sss, sss) = chop_prefix
        (fn ss => not (is_prefix (op =) ["EntryPoint"] ss)) sss
    val (ep, _) = case sss of (ep :: sss) => (ep, sss)
        | [] => raise PARSEGRAPH [
        "parse_fun: EntryPoint not found"]
    val ep = case ep of [_, n] => parse_int n
        | _ => raise PARSEGRAPH (
        "parse_fun: EntryPoint line malformed" :: ep)
  in
    SOME (nm, (xs, ys, SOME (ep, map parse_node node_sss,
        Abs ("g", @{typ "nat \<Rightarrow> node option"}, @{term GraphFunction}
            $ mk_stringlist xs $ mk_stringlist ys
            $ Bound 0 $ HOLogic.mk_number @{typ nat} ep))))
  end
  | parse_fun [] = raise PARSEGRAPH ["parse_fun: empty"]
  | parse_fun (ss :: _) = (warning ("parse_fun: ignoring: "
    ^ space_implode " " ss); NONE)

fun fun_groups gp ((fs as ("Function" :: _)) :: sss) =
    (if null gp then [] else [rev gp]) @ fun_groups [fs] sss
  | fun_groups gp ([] :: sss) = fun_groups gp sss
  | fun_groups gp (ss :: sss) = fun_groups (ss :: gp) sss
  | fun_groups gp [] = [rev gp]

fun filename_relative thy name =
    Path.append (Resources.master_directory thy) (Path.explode name)
    |> File.standard_path

fun mkdir_relative thy name =
    Path.append (Resources.master_directory thy) (Path.explode name)
    |> Isabelle_System.mkdirs

fun openIn_relative thy = filename_relative thy #> TextIO.openIn

fun get_funs thy file = let
    val f = openIn_relative thy file
    fun get () = case TextIO.inputLine f
      of NONE => []
      | SOME s => unsuffix "\n" s :: get ()
    val lines = get ()
      |> map (Library.space_explode " " #> filter (fn s => s <> ""))
      |> filter_out null
      |> filter_out (fn (s :: _) => String.isPrefix "#" s | _ => false)
  in fun_groups [] lines end

type funs = (string list * string list * (int * (int * term) list * term) option) Symtab.table

fun funs thy file : funs = get_funs thy file
  |> map_filter parse_fun
  |> Symtab.make

fun define_graph s nodes = let
    val nodes = sort (int_ord o apply2 fst) nodes
  in StaticFun.define_tree_and_save_thms (Binding.name s)
    (map (fst #> Int.toString #> prefix (s ^ "_")) nodes)
    (map (apfst (HOLogic.mk_number @{typ nat})) nodes)
    @{term "id :: nat => nat"} []
  end

fun define_graph_fun (funs : funs) b1 b2 nm ctxt =
        case (Symtab.lookup funs nm) of
    SOME (_, _, SOME (_, g, gf))
    => let
    val (graph_term, ctxt) = define_graph b1 g ctxt
    val (_, ctxt) = Local_Theory.define ((b2, NoSyn), ((Thm.def_binding b2, []),
        betapply (gf, graph_term))) ctxt
  in ctxt end
  | _ => error ("define_graph_fun: " ^ nm ^ " not in funs")

end

\<close>

end