(*  Title:      JinjaDCI/Compiler/Correctness1.thy
    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   TUM 2003, UIUC 2019-20

    Based on the Jinja theory Compiler/Correctness1.thy by Tobias Nipkow
*)

section \<open> Correctness of Stage 1 \<close>

theory Correctness1
imports J1WellForm Compiler1
begin

subsection\<open>Correctness of program compilation \<close>

primrec unmod :: "expr\<^sub>1 \<Rightarrow> nat \<Rightarrow> bool"
  and unmods :: "expr\<^sub>1 list \<Rightarrow> nat \<Rightarrow> bool" where
"unmod (new C) i = True" |
"unmod (Cast C e) i = unmod e i" |
"unmod (Val v) i = True" |
"unmod (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) i = (unmod e\<^sub>1 i \<and> unmod e\<^sub>2 i)" |
"unmod (Var i) j = True" |
"unmod (i:=e) j = (i \<noteq> j \<and> unmod e j)" |
"unmod (e\<bullet>F{D}) i = unmod e i" |
"unmod (C\<bullet>\<^sub>sF{D}) i = True" |
"unmod (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) i = (unmod e\<^sub>1 i \<and> unmod e\<^sub>2 i)" |
"unmod (C\<bullet>\<^sub>sF{D}:=e\<^sub>2) i = unmod e\<^sub>2 i" |
"unmod (e\<bullet>M(es)) i = (unmod e i \<and> unmods es i)" |
"unmod (C\<bullet>\<^sub>sM(es)) i = unmods es i" |
"unmod {j:T; e} i = unmod e i" |
"unmod (e\<^sub>1;;e\<^sub>2) i = (unmod e\<^sub>1 i \<and>  unmod e\<^sub>2 i)" |
"unmod (if (e) e\<^sub>1 else e\<^sub>2) i = (unmod e i \<and> unmod e\<^sub>1 i \<and> unmod e\<^sub>2 i)" |
"unmod (while (e) c) i = (unmod e i \<and> unmod c i)" |
"unmod (throw e) i = unmod e i" |
"unmod (try e\<^sub>1 catch(C i) e\<^sub>2) j = (unmod e\<^sub>1 j \<and> (if i=j then False else unmod e\<^sub>2 j))" |
"unmod (INIT C (Cs,b) \<leftarrow> e) i = unmod e i" |
"unmod (RI(C,e);Cs \<leftarrow> e') i = (unmod e i \<and> unmod e' i)" |

"unmods ([]) i = True" |
"unmods (e#es) i = (unmod e i \<and> unmods es i)"

lemma hidden_unmod: "\<And>Vs. hidden Vs i \<Longrightarrow> unmod (compE\<^sub>1 Vs e) i" and
 "\<And>Vs. hidden Vs i \<Longrightarrow> unmods (compEs\<^sub>1 Vs es) i"
(*<*)
apply(induct e and es rule: compE\<^sub>1.induct compEs\<^sub>1.induct)
apply (simp_all add:hidden_inacc)
apply(auto simp add:hidden_def)
done
(*>*)

lemma eval\<^sub>1_preserves_unmod:
  "\<lbrakk> P \<turnstile>\<^sub>1 \<langle>e,(h,ls,sh)\<rangle> \<Rightarrow> \<langle>e',(h',ls',sh')\<rangle>; unmod e i; i < size ls \<rbrakk>
  \<Longrightarrow> ls ! i = ls' ! i"
and "\<lbrakk> P \<turnstile>\<^sub>1 \<langle>es,(h,ls,sh)\<rangle> [\<Rightarrow>] \<langle>es',(h',ls',sh')\<rangle>; unmods es i; i < size ls \<rbrakk>
      \<Longrightarrow> ls ! i = ls' ! i"
(*<*)
proof(induct rule:eval\<^sub>1_evals\<^sub>1_inducts)
  case (RInitInitFail\<^sub>1 e h l sh a h' l' sh' C sfs i sh'' D Cs e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1)
  have "final (throw a)" using eval\<^sub>1_final[OF RInitInitFail\<^sub>1.hyps(1)] by simp
  then show ?case using RInitInitFail\<^sub>1 by(auto simp: eval\<^sub>1_preserves_len)
qed(auto dest!:eval\<^sub>1_preserves_len evals\<^sub>1_preserves_len split:if_split_asm)
(*>*)

lemma LAss_lem:
  "\<lbrakk>x \<in> set xs; size xs \<le> size ys \<rbrakk>
  \<Longrightarrow> m\<^sub>1 \<subseteq>\<^sub>m m\<^sub>2(xs[\<mapsto>]ys) \<Longrightarrow> m\<^sub>1(x\<mapsto>y) \<subseteq>\<^sub>m m\<^sub>2(xs[\<mapsto>]ys[last_index xs x := y])"
(*<*)
by(simp add:map_le_def fun_upds_apply eq_sym_conv)
(*>*)
lemma Block_lem:
fixes l :: "'a \<rightharpoonup> 'b"
assumes 0: "l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls]"
    and 1: "l' \<subseteq>\<^sub>m [Vs [\<mapsto>] ls', V\<mapsto>v]"
    and hidden: "V \<in> set Vs \<Longrightarrow> ls ! last_index Vs V = ls' ! last_index Vs V"
    and size: "size ls = size ls'"    "size Vs < size ls'"
shows "l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']"
(*<*)
proof -
  have "l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls', V\<mapsto>v](V := l V)"
    using 1 by(rule map_le_upd)
  also have "\<dots> = [Vs [\<mapsto>] ls'](V := l V)" by simp
  also have "\<dots> \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']"
  proof (cases "l V")
    case None thus ?thesis by simp
  next
    case (Some w)
    hence "[Vs [\<mapsto>] ls] V = Some w"
      using 0 by(force simp add: map_le_def split:if_splits)
    hence VinVs: "V \<in> set Vs" and w: "w = ls ! last_index Vs V"
      using size by(auto simp add:fun_upds_apply split:if_splits)
    hence "w = ls' ! last_index Vs V" using hidden[OF VinVs] by simp
    hence "[Vs [\<mapsto>] ls'](V := l V) = [Vs [\<mapsto>] ls']" using Some size VinVs
      by(simp add: map_upds_upd_conv_last_index)
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed
(*>*)

(*<*)
declare fun_upd_apply[simp del]
(*>*)

text\<open>\noindent The main theorem: \<close>

and evals\<^sub>1_evals: "P \<turnstile> \<langle>es,(h,l,sh)\<rangle> [\<Rightarrow>] \<langle>es',(h',l',sh')\<rangle>
    \<Longrightarrow> (\<And>Vs ls. \<lbrakk> fvs es \<subseteq> set Vs;  l \<subseteq>\<^sub>m [Vs[\<mapsto>]ls]; size Vs + max_varss es \<le> size ls \<rbrakk>
         \<Longrightarrow> \<exists>ls'. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compEs\<^sub>1 Vs es,(h,ls,sh)\<rangle> [\<Rightarrow>] \<langle>compEs\<^sub>1 Vs es',(h',ls',sh')\<rangle> \<and>
                      l' \<subseteq>\<^sub>m [Vs[\<mapsto>]ls'])"
(*<*)
  (is "_ \<Longrightarrow> (\<And>Vs ls. PROP ?Ps es h l sh es' h' l' sh' Vs ls)"
   is "_ \<Longrightarrow> (\<And>Vs ls. \<lbrakk> _; _; _\<rbrakk> \<Longrightarrow> \<exists>ls'. ?Posts es h l sh es' h' l' sh' Vs ls ls')")
proof (induct rule:eval_evals_inducts)
  case Nil thus ?case by(fastforce intro!:Nil\<^sub>1)
next
  case (Cons e h l sh v h' l' sh' es es' h\<^sub>2 l\<^sub>2 sh\<^sub>2)
  have "PROP ?P e h l sh (Val v) h' l' sh' Vs ls" by fact
  with Cons.prems
  obtain ls' where 1: "?Post e h l sh (Val v) h' l' sh' Vs ls ls'"
    "size ls = size ls'" by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h' l' sh' es' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls'" by fact
  with 1 Cons.prems
  obtain ls\<^sub>2 where 2: "?Posts es h' l' sh' es' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls' ls\<^sub>2" by(auto)
  from 1 2 Cons show ?case by(auto intro!:Cons\<^sub>1)
next
  case ConsThrow thus ?case
    by(fastforce intro!:ConsThrow\<^sub>1 dest: eval_final)
next
  case (Block e h l V sh e' h' l' sh' T)
  let ?Vs = "Vs @ [V]"
  have IH:
  "\<lbrakk>fv e \<subseteq> set ?Vs; l(V := None) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls];
    size ?Vs + max_vars e \<le> size ls\<rbrakk>
   \<Longrightarrow> \<exists>ls'. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e,(h,ls,sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h', ls',sh')\<rangle> \<and>
             l' \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls']" and
  fv: "fv {V:T; e} \<subseteq> set Vs" and rel: "l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls]" and
  len: "length Vs + max_vars {V:T; e} \<le> length ls" by fact+
  have len': "length Vs < length ls" using len by auto
  have "fv e \<subseteq> set ?Vs" using fv by auto
  moreover have "l(V := None) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls]" using rel len' by simp
  moreover have "size ?Vs + max_vars e \<le> size ls" using len by simp
  ultimately obtain ls' where
   1: "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e,(h,ls,sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h',ls',sh')\<rangle>"
   and rel': "l' \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls']" using IH by blast
  have [simp]: "length ls = length ls'" by(rule eval\<^sub>1_preserves_len[OF 1])
  show "\<exists>ls'. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs {V:T; e},(h,ls,sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h',ls',sh')\<rangle>
              \<and> l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']" (is "\<exists>ls'. ?R ls'")
  proof
    show "?R ls'"
    proof
      show "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs {V:T; e},(h,ls,sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h',ls',sh')\<rangle>"
        using 1 by(simp add:Block\<^sub>1)
    next
      show "l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']"
      proof -
        have "l' \<subseteq>\<^sub>m [Vs [\<mapsto>] ls', V \<mapsto> ls' ! length Vs]"
          using len' rel' by simp
        moreover
        { assume VinVs: "V \<in> set Vs"
          hence "hidden (Vs @ [V]) (last_index Vs V)"
            by(rule hidden_last_index)
          hence "unmod (compE\<^sub>1 (Vs @ [V]) e) (last_index Vs V)"
            by(rule hidden_unmod)
          moreover have "last_index Vs V < length ls"
            using len' VinVs by simp
          ultimately have "ls ! last_index Vs V = ls' ! last_index Vs V"
            by(rule eval\<^sub>1_preserves_unmod[OF 1])
        }
        ultimately show ?thesis using Block_lem[OF rel] len' by auto
      qed
    qed
  qed
next
  case (TryThrow e' h l sh a h' l' sh' D fs C V e\<^sub>2)
  have "PROP ?P e' h l sh (Throw a) h' l' sh' Vs ls" by fact
  with TryThrow.prems
  obtain ls' where 1: "?Post e' h l sh (Throw a) h' l' sh' Vs ls ls'"  by(auto)
  show ?case using 1 TryThrow.hyps by(auto intro!:eval\<^sub>1_evals\<^sub>1.TryThrow\<^sub>1)
next
  case (TryCatch e\<^sub>1 h l sh a h\<^sub>1 l\<^sub>1 sh\<^sub>1 D fs C e\<^sub>2 V e' h\<^sub>2 l\<^sub>2 sh\<^sub>2)
  let ?e = "try e\<^sub>1 catch(C V) e\<^sub>2"
  have IH\<^sub>1: "\<lbrakk>fv e\<^sub>1 \<subseteq> set Vs; l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls];
              size Vs + max_vars e\<^sub>1 \<le> length ls\<rbrakk>
          \<Longrightarrow> \<exists>ls\<^sub>1. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs e\<^sub>1,(h,ls,sh)\<rangle> \<Rightarrow>
                                \<langle>fin\<^sub>1 (Throw a),(h\<^sub>1,ls\<^sub>1,sh\<^sub>1)\<rangle> \<and>
                    l\<^sub>1 \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>1]" and
    fv: "fv ?e \<subseteq> set Vs" and
    rel: "l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls]" and
    len: "length Vs + max_vars ?e \<le> length ls" by fact+
  have "fv e\<^sub>1 \<subseteq> set Vs" using fv by auto
  moreover have "length Vs + max_vars e\<^sub>1 \<le> length ls" using len by(auto)
  ultimately obtain ls\<^sub>1 where
    1: "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs e\<^sub>1,(h,ls,sh)\<rangle> \<Rightarrow> \<langle>Throw a,(h\<^sub>1,ls\<^sub>1,sh\<^sub>1)\<rangle>"
    and rel\<^sub>1: "l\<^sub>1 \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>1]" using IH\<^sub>1 rel by fastforce
  from 1 have [simp]: "size ls = size ls\<^sub>1" by(rule eval\<^sub>1_preserves_len)
  let ?Vs = "Vs @ [V]" let ?ls = "(ls\<^sub>1[size Vs:=Addr a])"
  have IH\<^sub>2: "\<lbrakk>fv e\<^sub>2 \<subseteq> set ?Vs; l\<^sub>1(V \<mapsto> Addr a) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ?ls];
              length ?Vs + max_vars e\<^sub>2 \<le> length ?ls\<rbrakk> \<Longrightarrow> \<exists>ls\<^sub>2.
       compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e\<^sub>2,(h\<^sub>1,?ls,sh\<^sub>1)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2, ls\<^sub>2, sh\<^sub>2)\<rangle> \<and>
       l\<^sub>2 \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls\<^sub>2]" by fact
  have len\<^sub>1: "size Vs < size ls\<^sub>1" using len by(auto)
  have "fv e\<^sub>2 \<subseteq> set ?Vs" using fv by auto
  moreover have "l\<^sub>1(V \<mapsto> Addr a) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ?ls]" using rel\<^sub>1 len\<^sub>1 by simp
  moreover have "length ?Vs + max_vars e\<^sub>2 \<le> length ?ls" using len by(auto)
  ultimately obtain ls\<^sub>2 where
    2: "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e\<^sub>2,(h\<^sub>1,?ls,sh\<^sub>1)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2, ls\<^sub>2, sh\<^sub>2)\<rangle>"
    and rel\<^sub>2: "l\<^sub>2 \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls\<^sub>2]"  using IH\<^sub>2 by blast
  from 2 have [simp]: "size ls\<^sub>1 = size ls\<^sub>2"
    by(fastforce dest: eval\<^sub>1_preserves_len)
  show "\<exists>ls\<^sub>2. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs ?e,(h,ls,sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2,ls\<^sub>2,sh\<^sub>2)\<rangle> \<and>
              l\<^sub>2(V := l\<^sub>1 V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>2]"  (is "\<exists>ls\<^sub>2. ?R ls\<^sub>2")
  proof
    show "?R ls\<^sub>2"
    proof
      have hp: "h\<^sub>1 a = Some (D, fs)" by fact
      have "P \<turnstile> D \<preceq>\<^sup>* C" by fact hence caught: "compP\<^sub>1 P \<turnstile> D \<preceq>\<^sup>* C" by simp
      from TryCatch\<^sub>1[OF 1 _ caught len\<^sub>1 2, OF hp]
      show "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs ?e,(h,ls,sh)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2,ls\<^sub>2,sh\<^sub>2)\<rangle>" by simp
    next
      show "l\<^sub>2(V := l\<^sub>1 V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>2]"
      proof -
        have "l\<^sub>2 \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>2, V \<mapsto> ls\<^sub>2 ! length Vs]"
          using len\<^sub>1 rel\<^sub>2 by simp
        moreover
        { assume VinVs: "V \<in> set Vs"
          hence "hidden (Vs @ [V]) (last_index Vs V)" by(rule hidden_last_index)
          hence "unmod (compE\<^sub>1 (Vs @ [V]) e\<^sub>2) (last_index Vs V)"
            by(rule hidden_unmod)
          moreover have "last_index Vs V < length ?ls"
            using len\<^sub>1 VinVs by simp
          ultimately have "?ls ! last_index Vs V = ls\<^sub>2 ! last_index Vs V"
            by(rule eval\<^sub>1_preserves_unmod[OF 2])
          moreover have "last_index Vs V < size Vs" using VinVs by simp
          ultimately have "ls\<^sub>1 ! last_index Vs V = ls\<^sub>2 ! last_index Vs V"
            using len\<^sub>1 by(simp del:size_last_index_conv)
        }
        ultimately show ?thesis using Block_lem[OF rel\<^sub>1] len\<^sub>1  by simp
      qed
    qed
  qed
next
  case Try thus ?case by(fastforce intro!:Try\<^sub>1)
next
  case Throw thus ?case by(fastforce intro!:Throw\<^sub>1)
next
  case ThrowNull thus ?case by(fastforce intro!:ThrowNull\<^sub>1)
next
  case ThrowThrow thus ?case  by(fastforce intro!:ThrowThrow\<^sub>1)
next
  case (CondT e h l sh h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 e\<^sub>2)
  have "PROP ?P e h l sh true h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with CondT.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh true h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"  by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CondT.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 show ?case by(auto intro!:CondT\<^sub>1)
next
  case (CondF e h l sh h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>2 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 e\<^sub>1 Vs ls)
  have "PROP ?P e h l sh false h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with CondF.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh false h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"  by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CondF.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 show ?case by(auto intro!:CondF\<^sub>1)
next
  case CondThrow thus ?case by(fastforce intro!:CondThrow\<^sub>1)
next
  case (Seq e h l sh v h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2)
  have "PROP ?P e h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with Seq.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"  by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 Seq.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e' h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 Seq show ?case by(auto intro!:Seq\<^sub>1)
next
  case SeqThrow thus ?case by(fastforce intro!:SeqThrow\<^sub>1)
next
  case WhileF thus ?case by(fastforce intro!:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (WhileT e h l sh h\<^sub>1 l\<^sub>1 sh\<^sub>1 c v h\<^sub>2 l\<^sub>2 sh\<^sub>2 e' h\<^sub>3 l\<^sub>3 sh\<^sub>3)
  have "PROP ?P e h l sh true h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with WhileT.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh true h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"   by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P c h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 WhileT.prems
  obtain ls\<^sub>2 where 2: "?Post c h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"
    "size ls\<^sub>1 = size ls\<^sub>2"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P (While (e) c) h\<^sub>2 l\<^sub>2 sh\<^sub>2 e' h\<^sub>3 l\<^sub>3 sh\<^sub>3 Vs ls\<^sub>2" by fact
  with 1 2 WhileT.prems
  obtain ls\<^sub>3 where 3: "?Post (While (e) c) h\<^sub>2 l\<^sub>2 sh\<^sub>2 e' h\<^sub>3 l\<^sub>3 sh\<^sub>3 Vs ls\<^sub>2 ls\<^sub>3" by(auto)
  from 1 2 3 show ?case by(auto intro!:WhileT\<^sub>1)
next
  case (WhileBodyThrow e h l sh h\<^sub>1 l\<^sub>1 sh\<^sub>1 c e' h\<^sub>2 l\<^sub>2 sh\<^sub>2)
  have "PROP ?P e h l sh true h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with WhileBodyThrow.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh true h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P c h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw e') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 WhileBodyThrow.prems
  obtain ls\<^sub>2 where 2: "?Post c h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw e') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by auto
  from 1 2 show ?case by(auto intro!:WhileBodyThrow\<^sub>1)
next
  case WhileCondThrow thus ?case by(fastforce intro!:WhileCondThrow\<^sub>1)
next
  case New thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case NewFail thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case NewInit then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case NewInitOOM then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case NewInitThrow then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case Cast thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case CastNull thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case CastThrow thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (CastFail e h l sh a h\<^sub>1 l\<^sub>1 sh\<^sub>1 D fs C)
  have "PROP ?P e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with CastFail.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1" by auto
  show ?case using 1 CastFail.hyps
    by(auto intro!:CastFail\<^sub>1[where D=D])
next
  case Val thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (BinOp e h l sh v\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>1 v\<^sub>2 h\<^sub>2 l\<^sub>2 sh\<^sub>2 bop v)
  have "PROP ?P e h l sh (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with BinOp.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v\<^sub>2) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 BinOp.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v\<^sub>2) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 BinOp show ?case by(auto intro!:BinOp\<^sub>1)
next
  case (BinOpThrow2 e\<^sub>0 h l sh v\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>1 e h\<^sub>2 l\<^sub>2 sh\<^sub>2 bop)
  have "PROP ?P e\<^sub>0 h l sh (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with BinOpThrow2.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>0 h l sh (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 BinOpThrow2.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 BinOpThrow2 show ?case by(auto intro!:BinOpThrow\<^sub>2\<^sub>1)
next
  case BinOpThrow1 thus ?case  by(fastforce intro!:eval\<^sub>1_evals\<^sub>1.intros)
next
  case Var thus ?case
    by(force intro!:Var\<^sub>1 simp add: map_le_def fun_upds_apply)
next
  case LAss thus ?case
    by(fastforce simp add: LAss_lem intro:eval\<^sub>1_evals\<^sub>1.intros
                dest:eval\<^sub>1_preserves_len)
next
  case LAssThrow thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case FAcc thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case FAccNull thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case FAccThrow thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (FAccNone e h l sh a h' l' sh' C fs F D)
  have "PROP ?P e h l sh (addr a) h' l' sh' Vs ls" by fact
  with FAccNone.prems
  obtain ls\<^sub>2 where 2: "?Post e h l sh (addr a) h' l' sh' Vs ls ls\<^sub>2" by(auto)
  from 2 FAccNone show ?case by(rule_tac x = ls\<^sub>2 in exI, auto elim!: FAccNone\<^sub>1)
next
  case (FAccStatic e h l sh a h' l' sh' C fs F t D)
  have "PROP ?P e h l sh (addr a) h' l' sh' Vs ls" by fact
  with FAccStatic.prems
  obtain ls\<^sub>2 where 2: "?Post e h l sh (addr a) h' l' sh' Vs ls ls\<^sub>2" by(auto)
  from 2 FAccStatic show ?case by(rule_tac x = ls\<^sub>2 in exI, auto elim!: FAccStatic\<^sub>1)
next
  case SFAcc then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (SFAccInit C F t D sh h l v' h' l' sh' sfs i v)
  have "PROP ?P (INIT D ([D],False) \<leftarrow> unit) h l sh (Val v') h' l' sh' Vs ls" by fact
  with SFAccInit.prems
  obtain ls\<^sub>2 where 1: "?Post (INIT D ([D],False) \<leftarrow> unit) h l sh (Val v') h' l' sh' Vs ls ls\<^sub>2" by(auto)
  from 1 SFAccInit show ?case by(rule_tac x = ls\<^sub>2 in exI, auto intro: SFAccInit\<^sub>1)
next
  case (SFAccInitThrow C F t D sh h l a h' l' sh')
  have "PROP ?P (INIT D ([D],False) \<leftarrow> unit) h l sh (throw a) h' l' sh' Vs ls" by fact
  with SFAccInitThrow.prems
  obtain ls\<^sub>2 where 1: "?Post (INIT D ([D],False) \<leftarrow> unit) h l sh (throw a) h' l' sh' Vs ls ls\<^sub>2" by(auto)
  from 1 SFAccInitThrow show ?case by(rule_tac x = ls\<^sub>2 in exI, auto intro: SFAccInitThrow\<^sub>1)
next
  case SFAccNone then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case SFAccNonStatic then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (FAss e\<^sub>1 h l sh a h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>2 v h\<^sub>2 l\<^sub>2 sh\<^sub>2 C fs fs' F D h\<^sub>2')
  have "PROP ?P e\<^sub>1 h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with FAss.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAss.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 FAss show ?case by(auto intro!:FAss\<^sub>1)
next
  case (FAssNull e\<^sub>1 h l sh h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>2 v h\<^sub>2 l\<^sub>2 sh\<^sub>2 F D)
  have "PROP ?P e\<^sub>1 h l sh null h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with FAssNull.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l sh null h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAssNull.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 FAssNull show ?case by(auto intro!:FAssNull\<^sub>1)
next
  case FAssThrow1 thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (FAssThrow2 e\<^sub>1 h l sh v h\<^sub>1 l\<^sub>1 sh\<^sub>1 e\<^sub>2 e h\<^sub>2 l\<^sub>2 sh\<^sub>2 F D)
  have "PROP ?P e\<^sub>1 h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with FAssThrow2.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"   by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAssThrow2.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 FAssThrow2 show ?case by(auto intro!:FAssThrow\<^sub>2\<^sub>1)
next
  case (FAssNone e\<^sub>1 h l sh a h' l' sh' e\<^sub>2 v h\<^sub>2 l\<^sub>2 sh\<^sub>2 C fs F D)
  have "PROP ?P e\<^sub>1 h l sh (addr a) h' l' sh' Vs ls" by fact
  with FAssNone.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l sh (addr a) h' l' sh' Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"   by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h' l' sh' (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAssNone.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h' l' sh' (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 FAssNone show ?case by(auto intro!:FAssNone\<^sub>1)
next
  case (FAssStatic e\<^sub>1 h l sh a h' l' sh' e\<^sub>2 v h\<^sub>2 l\<^sub>2 sh\<^sub>2 C fs F t D)
  have "PROP ?P e\<^sub>1 h l sh (addr a) h' l' sh' Vs ls" by fact
  with FAssStatic.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l sh (addr a) h' l' sh' Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"   by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h' l' sh' (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAssStatic.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h' l' sh' (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 FAssStatic show ?case by(auto intro!:FAssStatic\<^sub>1)
next
  case SFAss then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (SFAssInit e\<^sub>2 h l sh v h\<^sub>1 l\<^sub>1 sh\<^sub>1 C F t D v' h' l' sh' sfs i sfs' sh'')
  have "PROP ?P e\<^sub>2 h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with SFAssInit.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>2 h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1" "length ls = length ls\<^sub>1"
    by(auto intro!:eval\<^sub>1_preserves_len)
  then have Init_size: "length Vs \<le> length ls\<^sub>1" using SFAssInit.prems(3) by linarith
  have "PROP ?P (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v') h' l' sh' Vs ls\<^sub>1" by fact
  with 1 Init_size SFAssInit.prems
  obtain ls\<^sub>2 where 2: "?Post (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v') h' l' sh' Vs ls\<^sub>1 ls\<^sub>2"
    by auto
  from 1 2 SFAssInit show ?case
    by(auto simp add: comp_def
                intro!: SFAssInit\<^sub>1 dest!:evals_final)
next
  case (SFAssInitThrow e\<^sub>2 h l sh v h\<^sub>1 l\<^sub>1 sh\<^sub>1 C F t D a h\<^sub>2 l\<^sub>2 sh\<^sub>2)
  have "PROP ?P e\<^sub>2 h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with SFAssInitThrow.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>2 h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1" "length ls = length ls\<^sub>1"
    by(auto intro!:eval\<^sub>1_preserves_len)
  then have Init_size: "length Vs \<le> length ls\<^sub>1" using SFAssInitThrow.prems(3) by linarith
  have "PROP ?P (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw a) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 Init_size SFAssInitThrow.prems
  obtain ls\<^sub>2 where 2: "?Post (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw a) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"
    by auto
  from 1 2 SFAssInitThrow show ?case
    by(auto simp add: comp_def
                intro!: SFAssInitThrow\<^sub>1 dest!:evals_final)
next
  case SFAssThrow then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (SFAssNone e\<^sub>2 h l sh v h\<^sub>2 l\<^sub>2 sh\<^sub>2 C F D)
  have "PROP ?P e\<^sub>2 h l sh (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls" by fact
  with SFAssNone.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h l sh (Val v) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls ls\<^sub>2" by(auto)
  from 2 SFAssNone show ?case by(rule_tac x = ls\<^sub>2 in exI, auto elim!: SFAssNone\<^sub>1)
next
  case SFAssNonStatic then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (CallNull e h l sh h\<^sub>1 l\<^sub>1 sh\<^sub>1 es vs h\<^sub>2 l\<^sub>2 sh\<^sub>2 M)
  have "PROP ?P e h l sh null h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with CallNull.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh null h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CallNull.prems
  obtain ls\<^sub>2 where 2: "?Posts es h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 CallNull show ?case
    by (auto simp add: comp_def elim!: CallNull\<^sub>1)
next
  case CallObjThrow thus ?case  by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (CallParamsThrow e h l sh v h\<^sub>1 l\<^sub>1 sh\<^sub>1 es vs ex es' h\<^sub>2 l\<^sub>2 sh\<^sub>2 M)
  have "PROP ?P e h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with CallParamsThrow.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (Val v) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs @ throw ex # es') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CallParamsThrow.prems
  obtain ls\<^sub>2 where 2: "?Posts es h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs @ throw ex # es') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 CallParamsThrow show ?case
    by (auto simp add: comp_def
             elim!: CallParamsThrow\<^sub>1 dest!:evals_final)
next
  case (CallNone e h l sh a h\<^sub>1 l\<^sub>1 sh\<^sub>1 ps vs h\<^sub>2 l\<^sub>2 sh\<^sub>2 C fs M)
  have "PROP ?P e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with CallNone.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps ps h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CallNone.prems
  obtain ls\<^sub>2 where 2: "?Posts ps h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 CallNone show ?case
    by (auto simp add: comp_def
             elim!: CallNone\<^sub>1 dest!:evals_final sees_method_compPD)
next
  case (CallStatic e h l sh a h\<^sub>1 l\<^sub>1 sh\<^sub>1 ps vs h\<^sub>2 l\<^sub>2 sh\<^sub>2 C fs M Ts T pns body D)
  have "PROP ?P e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with CallStatic.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  let ?Vs = pns
  have mdecl: "P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (pns, body) in D" by fact
  have mdecl\<^sub>1: "compP\<^sub>1 P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (compE\<^sub>1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  have "PROP ?Ps ps h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CallStatic.prems
  obtain ls\<^sub>2 where 2: "?Posts ps h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 mdecl\<^sub>1 CallStatic show ?case
    by (auto simp add: comp_def
             elim!: CallStatic\<^sub>1 dest!:evals_final)
next
  case (Call e h l sh a h\<^sub>1 l\<^sub>1 sh\<^sub>1 es vs h\<^sub>2 l\<^sub>2 sh\<^sub>2 C fs M Ts T pns body D l\<^sub>2' b' h\<^sub>3 l\<^sub>3 sh\<^sub>3)
  have "PROP ?P e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with Call.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (addr a) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 Call.prems
  obtain ls\<^sub>2 where 2: "?Posts es h\<^sub>1 l\<^sub>1 sh\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"
    "size ls\<^sub>1 = size ls\<^sub>2"    by(auto intro!:evals\<^sub>1_preserves_len)
  let ?Vs = "this#pns"
  let ?ls = "Addr a # vs @ replicate (max_vars body) undefined"
  have mdecl: "P \<turnstile> C sees M,NonStatic: Ts\<rightarrow>T = (pns, body) in D" by fact
  have fv_body: "fv body \<subseteq> set ?Vs" and wf_size: "size Ts = size pns"
    using wf mdecl by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have mdecl\<^sub>1: "compP\<^sub>1 P \<turnstile> C sees M,NonStatic: Ts\<rightarrow>T = (compE\<^sub>1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  have [simp]: "l\<^sub>2' = [this \<mapsto> Addr a, pns [\<mapsto>] vs]" by fact
  have Call_size: "size vs = size pns" by fact
  have "PROP ?P body h\<^sub>2 l\<^sub>2' sh\<^sub>2 b' h\<^sub>3 l\<^sub>3 sh\<^sub>3 ?Vs ?ls" by fact
  with 1 2 fv_body Call_size Call.prems
  obtain ls\<^sub>3 where 3: "?Post body h\<^sub>2 l\<^sub>2' sh\<^sub>2 b' h\<^sub>3 l\<^sub>3 sh\<^sub>3 ?Vs ?ls ls\<^sub>3"  by(auto)
  have hp: "h\<^sub>2 a = Some (C, fs)" by fact
  from 1 2 3 hp mdecl\<^sub>1 wf_size Call_size show ?case
    by(fastforce simp add: comp_def
                intro!: Call\<^sub>1 dest!:evals_final)
next
  case (SCallParamsThrow es h l sh vs ex es' h\<^sub>2 l\<^sub>2 sh\<^sub>2 C M)
  have "PROP ?Ps es h l sh (map Val vs @ throw ex # es') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls" by fact
  with SCallParamsThrow.prems
  obtain ls\<^sub>2 where 2: "?Posts es h l sh (map Val vs @ throw ex # es') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls ls\<^sub>2" by(auto)
  from 2 SCallParamsThrow show ?case
    by (fastforce simp add: comp_def
             elim!: SCallParamsThrow\<^sub>1 dest!:evals_final)
next
  case (SCall ps h l sh vs h\<^sub>2 l\<^sub>2 sh\<^sub>2 C M Ts T pns body D sfs l\<^sub>2' e' h\<^sub>3 l\<^sub>3 sh\<^sub>3)
  have "PROP ?Ps ps h l sh (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls" by fact
  with SCall.prems
  obtain ls\<^sub>2 where 2: "?Posts ps h l sh (map Val vs) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls ls\<^sub>2"
    "size ls = size ls\<^sub>2"    by(auto intro!:evals\<^sub>1_preserves_len)
  let ?Vs = "pns"
  let ?ls = "vs @ replicate (max_vars body) undefined"
  have mdecl: "P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (pns, body) in D" by fact
  have fv_body: "fv body \<subseteq> set ?Vs" and wf_size: "size Ts = size pns"
    using wf mdecl by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have mdecl\<^sub>1: "compP\<^sub>1 P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (compE\<^sub>1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  have [simp]: "l\<^sub>2' = [pns [\<mapsto>] vs]" by fact
  have SCall_size: "size vs = size pns" by fact
  have "PROP ?P body h\<^sub>2 l\<^sub>2' sh\<^sub>2 e' h\<^sub>3 l\<^sub>3 sh\<^sub>3 ?Vs ?ls" by fact
  with 2 fv_body SCall_size SCall.prems
  obtain ls\<^sub>3 where 3: "?Post body h\<^sub>2 l\<^sub>2' sh\<^sub>2 e' h\<^sub>3 l\<^sub>3 sh\<^sub>3 ?Vs ?ls ls\<^sub>3"  by(auto)
  have shp: "sh\<^sub>2 D = \<lfloor>(sfs, Done)\<rfloor> \<or> M = clinit \<and> sh\<^sub>2 D = \<lfloor>(sfs, Processing)\<rfloor>" by fact
  from 2 3 shp mdecl\<^sub>1 wf_size SCall_size show ?case
    by(fastforce simp add: comp_def
                intro!: SCall\<^sub>1 dest!:evals_final)
next
  case (SCallNone ps h l sh vs h' l' sh' C M)
  have "PROP ?Ps ps h l sh (map Val vs) h' l' sh' Vs ls" by fact
  with SCallNone.prems
  obtain ls\<^sub>2 where 2: "?Posts ps h l sh (map Val vs) h' l' sh' Vs ls ls\<^sub>2" by(auto)
  from 2 SCallNone show ?case
    by(rule_tac x = ls\<^sub>2 in exI,
       auto simp add: comp_def elim!: SCallNone\<^sub>1 dest!:evals_final sees_method_compPD)
next
  case (SCallNonStatic ps h l sh vs h' l' sh' C M Ts T pns body D)
  let ?Vs = "this#pns"
  have mdecl: "P \<turnstile> C sees M,NonStatic: Ts\<rightarrow>T = (pns, body) in D" by fact
  have mdecl\<^sub>1: "compP\<^sub>1 P \<turnstile> C sees M,NonStatic: Ts\<rightarrow>T = (compE\<^sub>1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  have "PROP ?Ps ps h l sh (map Val vs) h' l' sh' Vs ls" by fact
  with SCallNonStatic.prems
  obtain ls\<^sub>2 where 2: "?Posts ps h l sh (map Val vs) h' l' sh' Vs ls ls\<^sub>2" by(auto)
  from 2 mdecl\<^sub>1 SCallNonStatic show ?case
    by (auto simp add: comp_def
             elim!: SCallNonStatic\<^sub>1 dest!:evals_final)
next
  case (SCallInitThrow ps h l sh vs h\<^sub>1 l\<^sub>1 sh\<^sub>1 C M Ts T pns body D a h\<^sub>2 l\<^sub>2 sh\<^sub>2)
  have "PROP ?Ps ps h l sh (map Val vs) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with SCallInitThrow.prems
  obtain ls\<^sub>1 where 1: "?Posts ps h l sh (map Val vs) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1" "length ls = length ls\<^sub>1"
    by(auto intro!:evals\<^sub>1_preserves_len)
  then have Init_size: "length Vs \<le> length ls\<^sub>1" using SCallInitThrow.prems(3) by linarith
  have "PROP ?P (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw a) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 Init_size SCallInitThrow.prems
  obtain ls\<^sub>2 where 2: "?Post (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (throw a) h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"
    by auto
  let ?Vs = "pns"
  have mdecl: "P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (pns, body) in D" by fact
  have mdecl\<^sub>1: "compP\<^sub>1 P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (compE\<^sub>1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  from 1 2 mdecl\<^sub>1 SCallInitThrow show ?case
    by(auto simp add: comp_def
                intro!: SCallInitThrow\<^sub>1 dest!:evals_final)
next
  case (SCallInit ps h l sh vs h\<^sub>1 l\<^sub>1 sh\<^sub>1 C M Ts T pns body D v' h\<^sub>2 l\<^sub>2 sh\<^sub>2 l\<^sub>2' e' h\<^sub>3 l\<^sub>3 sh\<^sub>3)
  have "PROP ?Ps ps h l sh (map Val vs) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls" by fact
  with SCallInit.prems
  obtain ls\<^sub>1 where 1: "?Posts ps h l sh (map Val vs) h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls ls\<^sub>1" "length ls = length ls\<^sub>1"
    by(auto intro!:evals\<^sub>1_preserves_len)
  then have Init_size: "length Vs \<le> length ls\<^sub>1" using SCallInit.prems(3) by linarith
  have "PROP ?P (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 Init_size SCallInit.prems
  obtain ls\<^sub>2 where 2: "?Post (INIT D ([D],False) \<leftarrow> unit) h\<^sub>1 l\<^sub>1 sh\<^sub>1 (Val v') h\<^sub>2 l\<^sub>2 sh\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"
    by auto
  let ?Vs = "pns"
  let ?ls = "vs @ replicate (max_vars body) undefined"
  have mdecl: "P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (pns, body) in D" by fact
  have fv_body: "fv body \<subseteq> set ?Vs" and wf_size: "size Ts = size pns"
    using wf mdecl by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have mdecl\<^sub>1: "compP\<^sub>1 P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (compE\<^sub>1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "\<lambda>b (pns,e). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) e"]
    by(simp)
  have [simp]: "l\<^sub>2' = [pns [\<mapsto>] vs]" by fact
  have SCall_size: "size vs = size pns" by fact
  have nclinit: "M \<noteq> clinit" by fact
  have "PROP ?P body h\<^sub>2 l\<^sub>2' sh\<^sub>2 e' h\<^sub>3 l\<^sub>3 sh\<^sub>3 ?Vs ?ls" by fact
  with 2 fv_body SCall_size SCallInit.prems
  obtain ls\<^sub>3 where 3: "?Post body h\<^sub>2 l\<^sub>2' sh\<^sub>2 e' h\<^sub>3 l\<^sub>3 sh\<^sub>3 ?Vs ?ls ls\<^sub>3"  by(auto)
  have shp: "\<nexists>sfs. sh\<^sub>1 D = \<lfloor>(sfs, Done)\<rfloor>" by fact
  from 1 2 3 shp mdecl\<^sub>1 wf_size SCall_size nclinit show ?case
    by(auto simp add: comp_def
                intro!: SCallInit\<^sub>1 dest!:evals_final)
next
\<comment> \<open> init cases \<close>
  case InitFinal then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (InitNone sh C C' Cs e h l e' h' l' sh')
  let ?sh1 = "sh(C \<mapsto> (sblank P C, Prepared))"
  have "PROP ?P (INIT C' (C # Cs,False) \<leftarrow> e) h l ?sh1 e' h' l' sh' Vs ls" by fact
  with InitNone.prems
  obtain ls\<^sub>2 where 2: "?Post (INIT C' (C # Cs,False) \<leftarrow> e) h l ?sh1 e' h' l' sh' Vs ls ls\<^sub>2" by(auto)
  from 2 InitNone show ?case by (auto elim!: InitNone\<^sub>1)
next
  case InitDone then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case InitProcessing then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case InitError then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case InitObject then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (InitNonObject sh C sfs D fs ms sh' C' Cs e h l e' h1 l1 sh1)
  let ?f = "(\<lambda>b (pns,body). compE\<^sub>1 (case b of NonStatic \<Rightarrow> this#pns | Static \<Rightarrow> pns) body)"
  have cls: "class (compP ?f P) C = \<lfloor>(D,fs,map (compM ?f) ms)\<rfloor>"
    by(rule class_compP[OF InitNonObject.hyps(3)])
  have "PROP ?P (INIT C' (D # C # Cs,False) \<leftarrow> e) h l sh' e' h1 l1 sh1 Vs ls" by fact
  with InitNonObject.prems
  obtain ls\<^sub>2 where 2: "?Post (INIT C' (D # C # Cs,False) \<leftarrow> e) h l sh' e' h1 l1 sh1 Vs ls ls\<^sub>2" by(auto)
  from 2 cls InitNonObject show ?case by (auto elim!: InitNonObject\<^sub>1)
next
  case InitRInit then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (RInit e h l sh v h' l' sh' C sfs i sh'' C' Cs e' e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1)
  have "PROP ?P e h l sh (Val v) h' l' sh' Vs ls" by fact
  with RInit.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (Val v) h' l' sh' Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P (INIT C' (Cs,True) \<leftarrow> e') h' l' sh'' e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls\<^sub>1" by fact
  with 1 RInit.prems
  obtain ls\<^sub>2 where 2: "?Post (INIT C' (Cs,True) \<leftarrow> e') h' l' sh'' e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 RInit show ?case by (auto elim!: RInit\<^sub>1)
next
  case (RInitInitFail e h l sh a h' l' sh' C sfs i sh'' D Cs e' e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1)
  have "PROP ?P e h l sh (throw a) h' l' sh' Vs ls" by fact
  with RInitInitFail.prems
  obtain ls\<^sub>1 where 1: "?Post e h l sh (throw a) h' l' sh' Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have fv: "fv (RI (D,throw a) ; Cs \<leftarrow> e') \<subseteq> set Vs"
    using RInitInitFail.hyps(1) eval_final RInitInitFail.prems(1) subset_eq by fastforce
  have l': "l' \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>1]" by (simp add: "1"(1))
  have "PROP ?P (RI (D,throw a) ; Cs \<leftarrow> e') h' l' sh'' e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls\<^sub>1" by fact
  with 1 eval_final[OF RInitInitFail.hyps(1)] RInitInitFail.prems
  obtain ls\<^sub>2 where 2: "?Post (RI (D,throw a) ; Cs \<leftarrow> e') h' l' sh'' e\<^sub>1 h\<^sub>1 l\<^sub>1 sh\<^sub>1 Vs ls\<^sub>1 ls\<^sub>2"
    by fastforce
  from 1 2 RInitInitFail show ?case
    by(fastforce simp add: comp_def
                intro!: RInitInitFail\<^sub>1 dest!:eval_final)
next
  case RInitFailFinal then show ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
qed
(*>*)

subsection\<open>Preservation of well-formedness\<close>

text\<open> The compiler preserves well-formedness. Is less trivial than it
may appear. We start with two simple properties: preservation of
well-typedness \<close>

lemma compE\<^sub>1_pres_wt: "\<And>Vs Ts U.
  \<lbrakk> P,[Vs[\<mapsto>]Ts] \<turnstile> e :: U; size Ts = size Vs \<rbrakk>
  \<Longrightarrow> compP f P,Ts \<turnstile>\<^sub>1 compE\<^sub>1 Vs e :: U"
and  "\<And>Vs Ts Us.
  \<lbrakk> P,[Vs[\<mapsto>]Ts] \<turnstile> es [::] Us; size Ts = size Vs \<rbrakk>
  \<Longrightarrow> compP f P,Ts \<turnstile>\<^sub>1 compEs\<^sub>1 Vs es [::] Us"
(*<*)
apply(induct e and es rule: compE\<^sub>1.induct compEs\<^sub>1.induct)
apply clarsimp
apply(fastforce)
apply clarsimp
apply(fastforce split:bop.splits)
apply (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
apply (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply (fastforce dest!: sees_method_compP[where f = f])
apply (fastforce dest!: sees_method_compP[where f = f])
apply (fastforce simp:nth_append)
apply (fastforce)
apply (fastforce)
apply (fastforce)
apply (fastforce)
apply (fastforce simp:nth_append)
apply simp
apply simp
apply simp
apply (fastforce)
done
(*>*)

text\<open>\noindent and the correct block numbering: \<close>

lemma \<B>: "\<And>Vs n. size Vs = n \<Longrightarrow> \<B> (compE\<^sub>1 Vs e) n"
and \<B>s: "\<And>Vs n. size Vs = n \<Longrightarrow> \<B>s (compEs\<^sub>1 Vs es) n"
(*<*)by(induct e and es rule: \<B>.induct \<B>s.induct) simp_all(*>*)

text\<open> The main complication is preservation of definite assignment
@{term"\<D>"}. \<close>

lemma image_last_index: "A \<subseteq> set(xs@[x]) \<Longrightarrow> last_index (xs @ [x]) ` A =
  (if x \<in> A then insert (size xs) (last_index xs ` (A-{x})) else last_index xs ` A)"
(*<*)
by(auto simp:image_def)
(*>*)

lemma A_compE\<^sub>1_None[simp]:
      "\<And>Vs. \<A> e = None \<Longrightarrow> \<A> (compE\<^sub>1 Vs e) = None"
and "\<And>Vs. \<A>s es = None \<Longrightarrow> \<A>s (compEs\<^sub>1 Vs es) = None"
(*<*)by(induct e and es rule: compE\<^sub>1.induct compEs\<^sub>1.induct)(auto simp:hyperset_defs)(*>*)

lemma A_compE\<^sub>1:
      "\<And>A Vs. \<lbrakk> \<A> e = \<lfloor>A\<rfloor>; fv e \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \<A> (compE\<^sub>1 Vs e) = \<lfloor>last_index Vs ` A\<rfloor>"
and "\<And>A Vs. \<lbrakk> \<A>s es = \<lfloor>A\<rfloor>; fvs es \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \<A>s (compEs\<^sub>1 Vs es) = \<lfloor>last_index Vs ` A\<rfloor>"
(*<*)
proof(induct e and es rule: fv.induct fvs.induct)
  case (Block V' T e)
  hence "fv e \<subseteq> set (Vs@[V'])" by fastforce
  moreover obtain B where "\<A> e = \<lfloor>B\<rfloor>"
    using Block.prems by(simp add: hyperset_defs)
  moreover from calculation have "B \<subseteq> set (Vs@[V'])" by(auto dest!:A_fv)
  ultimately show ?case using Block
    by(auto simp add: hyperset_defs image_last_index last_index_size_conv)
next
  case (TryCatch e\<^sub>1 C V' e\<^sub>2)
  hence fve\<^sub>2: "fv e\<^sub>2 \<subseteq> set (Vs@[V'])" by auto
  show ?case
  proof (cases "\<A> e\<^sub>1")
    assume A\<^sub>1: "\<A> e\<^sub>1 = None"
    then obtain A\<^sub>2 where A\<^sub>2: "\<A> e\<^sub>2 = \<lfloor>A\<^sub>2\<rfloor>" using TryCatch
      by(simp add:hyperset_defs)
    hence "A\<^sub>2 \<subseteq> set (Vs@[V'])" using TryCatch.prems A_fv[OF A\<^sub>2] by simp blast
    thus ?thesis using TryCatch fve\<^sub>2 A\<^sub>1 A\<^sub>2
      by(auto simp add:hyperset_defs image_last_index last_index_size_conv)
  next
    fix A\<^sub>1 assume A\<^sub>1: "\<A> e\<^sub>1 =  \<lfloor>A\<^sub>1\<rfloor>"
    show ?thesis
    proof (cases  "\<A> e\<^sub>2")
      assume A\<^sub>2: "\<A> e\<^sub>2 = None"
      then show ?case using TryCatch A\<^sub>1 by(simp add:hyperset_defs)
    next
      fix A\<^sub>2 assume A\<^sub>2: "\<A> e\<^sub>2 = \<lfloor>A\<^sub>2\<rfloor>"
      have "A\<^sub>1 \<subseteq> set Vs" using TryCatch.prems A_fv[OF A\<^sub>1] by simp blast
      moreover
      have "A\<^sub>2 \<subseteq> set (Vs@[V'])" using TryCatch.prems A_fv[OF A\<^sub>2] by simp blast
      ultimately show ?thesis using TryCatch A\<^sub>1 A\<^sub>2
        by (auto simp add: Diff_subset_conv last_index_size_conv subsetD hyperset_defs
                 dest!: sym [of _ A])
    qed
  qed
next
  case (Cond e e\<^sub>1 e\<^sub>2)
  { assume "\<A> e = None \<or> \<A> e\<^sub>1 = None \<or> \<A> e\<^sub>2 = None"
    hence ?case using Cond by(auto simp add:hyperset_defs image_Un)
  }
  moreover
  { fix A A\<^sub>1 A\<^sub>2
    assume "\<A> e = \<lfloor>A\<rfloor>" and A\<^sub>1: "\<A> e\<^sub>1 = \<lfloor>A\<^sub>1\<rfloor>" and A\<^sub>2: "\<A> e\<^sub>2 = \<lfloor>A\<^sub>2\<rfloor>"
    moreover
    have "A\<^sub>1 \<subseteq> set Vs" using Cond.prems A_fv[OF A\<^sub>1] by simp blast
    moreover
    have "A\<^sub>2 \<subseteq> set Vs" using Cond.prems A_fv[OF A\<^sub>2] by simp blast
    ultimately have ?case using Cond
      by(auto simp add:hyperset_defs image_Un
          inj_on_image_Int[OF inj_on_last_index])
  }
  ultimately show ?case by fastforce
qed (auto simp add:hyperset_defs)
(*>*)

lemma D_None[iff]: "\<D> (e::'a exp) None" and [iff]: "\<D>s (es::'a exp list) None"
(*<*)by(induct e and es rule: \<D>.induct \<D>s.induct)(simp_all)(*>*)

lemma last_index_image_set: "distinct xs \<Longrightarrow> last_index xs ` set xs = {..<size xs}"
(*<*)by(induct xs rule:rev_induct) (auto simp add: image_last_index)(*>*)

lemma D_compE\<^sub>1:
  "\<lbrakk> \<D> e \<lfloor>set Vs\<rfloor>; fv e \<subseteq> set Vs; distinct Vs \<rbrakk> \<Longrightarrow> \<D> (compE\<^sub>1 Vs e) \<lfloor>{..<length Vs}\<rfloor>"
(*<*)by(fastforce dest!: D_last_index_compE\<^sub>1[OF subset_refl] simp add:last_index_image_set)(*>*)

lemma D_compE\<^sub>1':
assumes "\<D> e \<lfloor>set(V#Vs)\<rfloor>" and "fv e \<subseteq> set(V#Vs)" and "distinct(V#Vs)"
shows "\<D> (compE\<^sub>1 (V#Vs) e) \<lfloor>{..length Vs}\<rfloor>"
(*<*)
proof -
  have "{..size Vs} = {..<size(V#Vs)}" by auto
  thus ?thesis using assms by (simp only:)(rule D_compE\<^sub>1)
qed
(*>*)

lemma compP\<^sub>1_pres_wf: "wf_J_prog P \<Longrightarrow> wf_J\<^sub>1_prog (compP\<^sub>1 P)"
(*<*)
apply simp
apply(rule wf_prog_compPI)
 prefer 2 apply assumption
apply(case_tac m)
apply(simp add:wf_mdecl_def wf_J\<^sub>1_mdecl_def)
apply(clarify) apply(rename_tac C M b Ts T x1 x2 pns body)
apply(case_tac b)
 apply clarsimp
 apply(frule WT_fv)
 apply(auto intro!: compE\<^sub>1_pres_wt D_compE\<^sub>1 \<B>)[1]
apply clarsimp
apply(frule WT_fv)
apply(fastforce intro!: compE\<^sub>1_pres_wt D_compE\<^sub>1' \<B>)
done
(*>*)

end


(*  Title:      HOL/Bali/Table.thy
    Author:     David von Oheimb
*)
subsection \<open>Abstract tables and their implementation as lists\<close>

theory Table imports Basis begin

text \<open>
design issues:
\begin{itemize}
\item definition of table: infinite map vs. list vs. finite set
      list chosen, because:
  \begin{itemize}
  \item[+]  a priori finite
  \item[+]  lookup is more operational than for finite set
  \item[-]  not very abstract, but function table converts it to abstract
            mapping
  \end{itemize}
\item coding of lookup result: Some/None vs. value/arbitrary
   Some/None chosen, because:
  \begin{itemize}
  \item[++] makes definedness check possible (applies also to finite set),
     which is important for the type standard, hiding/overriding, etc.
     (though it may perhaps be possible at least for the operational semantics
      to treat programs as infinite, i.e. where classes, fields, methods etc.
      of any name are considered to be defined)
  \item[-]  sometimes awkward case distinctions, alleviated by operator 'the'
  \end{itemize}
\end{itemize}
\<close>

type_synonym ('a, 'b) table    \<comment>\<open>table with key type 'a and contents type 'b\<close>
      = "'a \<rightharpoonup> 'b"
type_synonym ('a, 'b) tables   \<comment>\<open>non-unique table with key 'a and contents 'b\<close>
      = "'a \<Rightarrow> 'b set"

subsubsection "map of / table of"

abbreviation
  table_of :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) table"   \<comment>\<open>concrete table\<close>
  where "table_of \<equiv> map_of"

translations
  (type) "('a, 'b) table" <= (type) "'a \<rightharpoonup> 'b"

(* ### To map *)
lemma map_add_find_left[simp]: "n k = None \<Longrightarrow> (m ++ n) k = m k"
  by (simp add: map_add_def)

subsubsection \<open>Conditional Override\<close>

definition cond_override :: "('b \<Rightarrow>'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b)table \<Rightarrow> ('a, 'b)table \<Rightarrow> ('a, 'b) table" where

\<comment>\<open>when merging tables old and new, only override an entry of table old when
   the condition cond holds\<close>
"cond_override cond old new =
 (\<lambda>k.
  (case new k of
     None         \<Rightarrow> old k
   | Some new_val \<Rightarrow> (case old k of
                        None         \<Rightarrow> Some new_val
                      | Some old_val \<Rightarrow> (if cond new_val old_val
                                         then Some new_val
                                         else Some old_val))))"

lemma cond_override_empty1[simp]: "cond_override c empty t = t"
  by (simp add: cond_override_def fun_eq_iff)

lemma cond_override_empty2[simp]: "cond_override c t empty = t"
  by (simp add: cond_override_def fun_eq_iff)

lemma cond_override_None[simp]:
  "old k = None \<Longrightarrow> (cond_override c old new) k = new k"
  by (simp add: cond_override_def)

lemma cond_override_override:
  "\<lbrakk>old k = Some ov;new k = Some nv; C nv ov\<rbrakk>
    \<Longrightarrow> (cond_override C old new) k = Some nv"
  by (auto simp add: cond_override_def)

lemma cond_override_noOverride:
  "\<lbrakk>old k = Some ov;new k = Some nv; \<not> (C nv ov)\<rbrakk>
    \<Longrightarrow> (cond_override C old new) k = Some ov"
  by (auto simp add: cond_override_def)

lemma dom_cond_override: "dom (cond_override C s t) \<subseteq> dom s \<union> dom t"
  by (auto simp add: cond_override_def dom_def)

lemma finite_dom_cond_override:
 "\<lbrakk> finite (dom s); finite (dom t) \<rbrakk> \<Longrightarrow> finite (dom (cond_override C s t))"
apply (rule_tac B="dom s \<union> dom t" in finite_subset)
apply (rule dom_cond_override)
by (rule finite_UnI)

subsubsection \<open>Filter on Tables\<close>

definition filter_tab :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) table \<Rightarrow> ('a, 'b) table"
  where
    "filter_tab c t = (\<lambda>k. (case t k of
                             None   \<Rightarrow> None
                           | Some x \<Rightarrow> if c k x then Some x else None))"

lemma filter_tab_empty[simp]: "filter_tab c empty = empty"
by (simp add: filter_tab_def empty_def)

lemma filter_tab_True[simp]: "filter_tab (\<lambda>x y. True) t = t"
by (simp add: fun_eq_iff filter_tab_def)

lemma filter_tab_False[simp]: "filter_tab (\<lambda>x y. False) t = empty"
by (simp add: fun_eq_iff filter_tab_def empty_def)

lemma filter_tab_ran_subset: "ran (filter_tab c t) \<subseteq> ran t"
by (auto simp add: filter_tab_def ran_def)

lemma filter_tab_range_subset: "range (filter_tab c t) \<subseteq> range t \<union> {None}"
apply (auto simp add: filter_tab_def)
apply (drule sym, blast)
done

lemma finite_range_filter_tab:
  "finite (range t) \<Longrightarrow> finite (range (filter_tab c t))"
apply (rule_tac B="range t \<union> {None} " in finite_subset)
apply (rule filter_tab_range_subset)
apply (auto intro: finite_UnI)
done

lemma filter_tab_SomeD[dest!]:
"filter_tab c t k = Some x \<Longrightarrow> (t k = Some x) \<and> c k x"
by (auto simp add: filter_tab_def)

lemma filter_tab_SomeI: "\<lbrakk>t k = Some x;C k x\<rbrakk> \<Longrightarrow>filter_tab C t k = Some x"
by (simp add: filter_tab_def)

lemma filter_tab_all_True:
 "\<forall> k y. t k = Some y \<longrightarrow> p k y \<Longrightarrow>filter_tab p t = t"
apply (auto simp add: filter_tab_def fun_eq_iff)
done

lemma filter_tab_all_True_Some:
 "\<lbrakk>\<forall> k y. t k = Some y \<longrightarrow> p k y; t k = Some v\<rbrakk> \<Longrightarrow> filter_tab p t k = Some v"
by (auto simp add: filter_tab_def fun_eq_iff)

lemma filter_tab_all_False:
 "\<forall> k y. t k = Some y \<longrightarrow> \<not> p k y \<Longrightarrow>filter_tab p t = empty"
by (auto simp add: filter_tab_def fun_eq_iff)

lemma filter_tab_None: "t k = None \<Longrightarrow> filter_tab p t k = None"
apply (simp add: filter_tab_def fun_eq_iff)
done

lemma filter_tab_dom_subset: "dom (filter_tab C t) \<subseteq> dom t"
by (auto simp add: filter_tab_def dom_def)

lemma filter_tab_eq: "\<lbrakk>a=b\<rbrakk> \<Longrightarrow> filter_tab C a = filter_tab C b"
by (auto simp add: fun_eq_iff filter_tab_def)

lemma finite_dom_filter_tab:
"finite (dom t) \<Longrightarrow> finite (dom (filter_tab C t))"
apply (rule_tac B="dom t" in finite_subset)
by (rule filter_tab_dom_subset)

lemma filter_tab_weaken:
"\<lbrakk>\<forall> a \<in> t k: \<exists> b \<in> s k: P a b;
  \<And> k x y. \<lbrakk>t k = Some x;s k = Some y\<rbrakk> \<Longrightarrow> cond k x \<longrightarrow> cond k y
 \<rbrakk> \<Longrightarrow> \<forall> a \<in> filter_tab cond t k: \<exists> b \<in> filter_tab cond s k: P a b"
by (force simp add: filter_tab_def)

lemma cond_override_filter:
  "\<lbrakk>\<And> k old new. \<lbrakk>s k = Some new; t k = Some old\<rbrakk>
    \<Longrightarrow> (\<not> overC new old \<longrightarrow>  \<not> filterC k new) \<and>
        (overC new old \<longrightarrow> filterC k old \<longrightarrow> filterC k new)
   \<rbrakk> \<Longrightarrow>
    cond_override overC (filter_tab filterC t) (filter_tab filterC s)
    = filter_tab filterC (cond_override overC t s)"
by (auto simp add: fun_eq_iff cond_override_def filter_tab_def )

subsubsection \<open>Misc\<close>

lemma Ball_set_table: "(\<forall> (x,y)\<in> set l. P x y) \<Longrightarrow> \<forall> x. \<forall> y\<in> map_of l x: P x y"
apply (erule rev_mp)
apply (induct l)
apply simp
apply (simp (no_asm))
apply auto
done

lemma Ball_set_tableD:
  "\<lbrakk>(\<forall> (x,y)\<in> set l. P x y); x \<in> set_option (table_of l xa)\<rbrakk> \<Longrightarrow> P xa x"
apply (frule Ball_set_table)
by auto

declare map_of_SomeD [elim]

lemma table_of_Some_in_set:
"table_of l k = Some x \<Longrightarrow> (k,x) \<in> set l"
by auto

lemma set_get_eq:
  "unique l \<Longrightarrow> (k, the (table_of l k)) \<in> set l = (table_of l k \<noteq> None)"
by (auto dest!: weak_map_of_SomeI)

lemma inj_Pair_const2: "inj (\<lambda>k. (k, C))"
apply (rule inj_onI)
apply auto
done

lemma table_of_mapconst_SomeI:
  "\<lbrakk>table_of t k = Some y'; snd y=y'; fst y=c\<rbrakk> \<Longrightarrow>
    table_of (map (\<lambda>(k,x). (k,c,x)) t) k = Some y"
  by (induct t) auto

lemma table_of_mapconst_NoneI:
  "\<lbrakk>table_of t k = None\<rbrakk> \<Longrightarrow>
    table_of (map (\<lambda>(k,x). (k,c,x)) t) k = None"
  by (induct t) auto

lemmas table_of_map2_SomeI = inj_Pair_const2 [THEN map_of_mapk_SomeI]

lemma table_of_map_SomeI: "table_of t k = Some x \<Longrightarrow>
   table_of (map (\<lambda>(k,x). (k, f x)) t) k = Some (f x)"
  by (induct t) auto

lemma table_of_remap_SomeD:
  "table_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) \<Longrightarrow>
    table_of t (k, k') = Some x"
  by (induct t) auto

lemma table_of_mapf_Some:
  "\<forall>x y. f x = f y \<longrightarrow> x = y \<Longrightarrow>
    table_of (map (\<lambda>(k,x). (k,f x)) t) k = Some (f x) \<Longrightarrow> table_of t k = Some x"
  by (induct t) auto

lemma table_of_mapf_SomeD [dest!]:
  "table_of (map (\<lambda>(k,x). (k, f x)) t) k = Some z \<Longrightarrow> (\<exists>y\<in>table_of t k: z=f y)"
  by (induct t) auto

lemma table_of_mapf_NoneD [dest!]:
  "table_of (map (\<lambda>(k,x). (k, f x)) t) k = None \<Longrightarrow> (table_of t k = None)"
  by (induct t) auto

lemma table_of_mapkey_SomeD [dest!]:
  "table_of (map (\<lambda>(k,x). ((k,C),x)) t) (k,D) = Some x \<Longrightarrow> C = D \<and> table_of t k = Some x"
  by (induct t) auto

lemma table_of_mapkey_SomeD2 [dest!]:
  "table_of (map (\<lambda>(k,x). ((k,C),x)) t) ek = Some x \<Longrightarrow>
    C = snd ek \<and> table_of t (fst ek) = Some x"
  by (induct t) auto

lemma table_append_Some_iff: "table_of (xs@ys) k = Some z =
 (table_of xs k = Some z \<or> (table_of xs k = None \<and> table_of ys k = Some z))"
apply (simp)
apply (rule map_add_Some_iff)
done

lemma table_of_filter_unique_SomeD [rule_format (no_asm)]:
  "table_of (filter P xs) k = Some z \<Longrightarrow> unique xs \<longrightarrow> table_of xs k = Some z"
  by (induct xs) (auto del: map_of_SomeD intro!: map_of_SomeD)

definition Un_tables :: "('a, 'b) tables set \<Rightarrow> ('a, 'b) tables"
  where "Un_tables ts = (\<lambda>k. \<Union>t\<in>ts. t k)"

definition overrides_t :: "('a, 'b) tables \<Rightarrow> ('a, 'b) tables \<Rightarrow> ('a, 'b) tables"
    (infixl "\<oplus>\<oplus>" 100)
  where "s \<oplus>\<oplus> t = (\<lambda>k. if t k = {} then s k else t k)"

definition
  hidings_entails :: "('a, 'b) tables \<Rightarrow> ('a, 'c) tables \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
    ("_ hidings _ entails _" 20)
  where "(t hidings s entails R) = (\<forall>k. \<forall>x\<in>t k. \<forall>y\<in>s k. R x y)"

definition
  \<comment>\<open>variant for unique table:\<close>
  hiding_entails :: "('a, 'b) table  \<Rightarrow> ('a, 'c) table  \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
    ("_ hiding _ entails _"  20)
  where "(t hiding  s entails R) = (\<forall>k. \<forall>x\<in>t k: \<forall>y\<in>s k: R x y)"

definition
  \<comment>\<open>variant for a unique table and conditional overriding:\<close>
  cond_hiding_entails :: "('a, 'b) table  \<Rightarrow> ('a, 'c) table
                          \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
                          ("_ hiding _ under _ entails _"  20)
  where "(t hiding  s under C entails R) = (\<forall>k. \<forall>x\<in>t k: \<forall>y\<in>s k: C x y \<longrightarrow> R x y)"

subsubsection "Untables"

lemma Un_tablesI [intro]:  "t \<in> ts \<Longrightarrow> x \<in> t k \<Longrightarrow> x \<in> Un_tables ts k"
  by (auto simp add: Un_tables_def)

lemma Un_tablesD [dest!]: "x \<in> Un_tables ts k \<Longrightarrow> \<exists>t. t \<in> ts \<and> x \<in> t k"
  by (auto simp add: Un_tables_def)

lemma Un_tables_empty [simp]: "Un_tables {} = (\<lambda>k. {})"
  by (simp add: Un_tables_def)

subsubsection "overrides"

lemma empty_overrides_t [simp]: "(\<lambda>k. {}) \<oplus>\<oplus> m = m"
  by (simp add: overrides_t_def)

lemma overrides_empty_t [simp]: "m \<oplus>\<oplus> (\<lambda>k. {}) = m"
  by (simp add: overrides_t_def)

lemma overrides_t_Some_iff:
  "(x \<in> (s \<oplus>\<oplus> t) k) = (x \<in> t k \<or> t k = {} \<and> x \<in> s k)"
  by (simp add: overrides_t_def)

lemmas overrides_t_SomeD = overrides_t_Some_iff [THEN iffD1, dest!]

lemma overrides_t_right_empty [simp]: "n k = {} \<Longrightarrow> (m \<oplus>\<oplus> n) k = m k"
  by (simp add: overrides_t_def)

lemma overrides_t_find_right [simp]: "n k \<noteq> {} \<Longrightarrow> (m \<oplus>\<oplus> n) k = n k"
  by (simp add: overrides_t_def)

subsubsection "hiding entails"

lemma hiding_entailsD:
  "t hiding s entails R \<Longrightarrow> t k = Some x \<Longrightarrow> s k = Some y \<Longrightarrow> R x y"
  by (simp add: hiding_entails_def)

lemma empty_hiding_entails [simp]: "empty hiding s entails R"
  by (simp add: hiding_entails_def)

lemma hiding_empty_entails [simp]: "t hiding empty entails R"
  by (simp add: hiding_entails_def)

subsubsection "cond hiding entails"

lemma cond_hiding_entailsD:
"\<lbrakk>t hiding s under C entails R; t k = Some x; s k = Some y; C x y\<rbrakk> \<Longrightarrow> R x y"
by (simp add: cond_hiding_entails_def)

lemma empty_cond_hiding_entails[simp]: "empty hiding s under C entails R"
by (simp add: cond_hiding_entails_def)

lemma cond_hiding_empty_entails[simp]: "t hiding empty under C entails R"
by (simp add: cond_hiding_entails_def)

lemma hidings_entailsD: "\<lbrakk>t hidings s entails R; x \<in> t k; y \<in> s k\<rbrakk> \<Longrightarrow> R x y"
by (simp add: hidings_entails_def)

lemma hidings_empty_entails [intro!]: "t hidings (\<lambda>k. {}) entails R"
apply (unfold hidings_entails_def)
apply (simp (no_asm))
done

lemma empty_hidings_entails [intro!]:
  "(\<lambda>k. {}) hidings s entails R"apply (unfold hidings_entails_def)
by (simp (no_asm))

(*###TO Map?*)
primrec atleast_free :: "('a \<rightharpoonup> 'b) => nat => bool"
where
  "atleast_free m 0 = True"
| atleast_free_Suc: "atleast_free m (Suc n) = (\<exists>a. m a = None & (!b. atleast_free (m(a|->b)) n))"

lemma atleast_free_weaken [rule_format (no_asm)]:
  "!m. atleast_free m (Suc n) \<longrightarrow> atleast_free m n"
apply (induct_tac "n")
apply (simp (no_asm))
apply clarify
apply (simp (no_asm))
apply (drule atleast_free_Suc [THEN iffD1])
apply fast
done

lemma atleast_free_SucI:
"[| h a = None; !obj. atleast_free (h(a|->obj)) n |] ==> atleast_free h (Suc n)"
by force

declare fun_upd_apply [simp del]
lemma atleast_free_SucD_lemma [rule_format (no_asm)]:
" !m a. m a = None --> (!c. atleast_free (m(a|->c)) n) -->
  (!b d. a ~= b --> atleast_free (m(b|->d)) n)"
apply (induct_tac "n")
apply  auto
apply (rule_tac x = "a" in exI)
apply  (rule conjI)
apply  (force simp add: fun_upd_apply)
apply (erule_tac V = "m a = None" in thin_rl)
apply clarify
apply (subst fun_upd_twist)
apply  (erule not_sym)
apply (rename_tac "ba")
apply (drule_tac x = "ba" in spec)
apply clarify
apply (tactic "smp_tac @{context} 2 1")
apply (erule (1) notE impE)
apply (case_tac "aa = b")
apply fast+
done
declare fun_upd_apply [simp]

lemma atleast_free_SucD: "atleast_free h (Suc n) ==> atleast_free (h(a|->b)) n"
apply auto
apply (case_tac "aa = a")
apply auto
apply (erule atleast_free_SucD_lemma)
apply auto
done

declare atleast_free_Suc [simp del]

end


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

section "Lemmas for Word Length 64"

theory Word_Lemmas_64
imports
  Word_Lemmas
  Word_Setup_64
begin

lemma ucast_8_64_inj:
  "inj (ucast ::  8 word \<Rightarrow> 64 word)"
  by (rule down_ucast_inj) (clarsimp simp: is_down_def target_size source_size)

lemma upto_2_helper:
  "{0..<2 :: 64 word} = {0, 1}"
  by (safe; simp) unat_arith

lemmas upper_bits_unset_is_l2p_64 = upper_bits_unset_is_l2p [where 'a=64, folded word_bits_def]
lemmas le_2p_upper_bits_64 = le_2p_upper_bits [where 'a=64, folded word_bits_def]
lemmas le2p_bits_unset_64 = le2p_bits_unset[where 'a=64, folded word_bits_def]

lemma word_bits_len_of:
  "len_of TYPE (64) = word_bits"
  by (simp add: word_bits_conv)

lemmas unat_power_lower64' = unat_power_lower[where 'a=64]
lemmas unat_power_lower64 [simp] = unat_power_lower64'[unfolded word_bits_len_of]

lemmas word64_less_sub_le' = word_less_sub_le[where 'a = 64]
lemmas word64_less_sub_le[simp] = word64_less_sub_le' [folded word_bits_def]

lemma word_bits_size:
  "size (w::word64) = word_bits"
  by (simp add: word_bits_def word_size)

lemmas word64_power_less_1' = word_power_less_1[where 'a = 64]
lemmas word64_power_less_1[simp] = word64_power_less_1'[folded word_bits_def]

lemma of_nat64_0:
  "\<lbrakk>of_nat n = (0::word64); n < 2 ^ word_bits\<rbrakk> \<Longrightarrow> n = 0"
  by (erule of_nat_0, simp add: word_bits_def)

lemma unat_mask_2_less_4:
  "unat (p && mask 2 :: word64) < 4"
  apply (rule unat_less_helper)
  apply (rule order_le_less_trans, rule word_and_le1)
  apply (simp add: mask_def)
  done

lemmas unat_of_nat64' = unat_of_nat_eq[where 'a=64]
lemmas unat_of_nat64 = unat_of_nat64'[unfolded word_bits_len_of]

lemmas word_power_nonzero_64 = word_power_nonzero [where 'a=64, folded word_bits_def]

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [where 'a = 64, unfolded word_bits_len_of]]

lemmas div_power_helper_64 = div_power_helper [where 'a=64, folded word_bits_def]

lemma n_less_word_bits:
  "(n < word_bits) = (n < 64)"
  by (simp add: word_bits_def)

lemmas of_nat_less_pow_64 = of_nat_power [where 'a=64, folded word_bits_def]

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma unat_less_word_bits:
  fixes y :: word64
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemmas unat_mask_word64' = unat_mask[where 'a=64]
lemmas unat_mask_word64 = unat_mask_word64'[folded word_bits_def]

lemmas word64_minus_one_le' = word_minus_one_le[where 'a=64]
lemmas word64_minus_one_le = word64_minus_one_le'[simplified]

lemma ucast_not_helper:
  fixes a::word8
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::word64)"
proof
  assume "ucast a = (0xFF::word64)"
  also
  have "(0xFF::word64) = ucast (0xFF::word8)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma less_4_cases:
  "(x::word64) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

lemma unat_ucast_8_64:
  fixes x :: "word8"
  shows "unat (ucast x :: word64) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: word64)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: word64)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma ucast_le_ucast_8_64:
  "(ucast x \<le> (ucast y :: word64)) = (x \<le> (y :: word8))"
  by (simp add: word_le_nat_alt unat_ucast_8_64)

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: word64)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: word64. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma eq_2_64_0:
  "(2 ^ 64 :: word64) = 0"
  by simp

lemma x_less_2_0_1:
  fixes x :: word64 shows
  "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemmas mask_64_max_word  = max_word_mask [symmetric, where 'a=64, simplified]

lemma of_nat64_n_less_equal_power_2:
 "n < 64 \<Longrightarrow> ((of_nat n)::64 word) < 2 ^ n"
  by (rule of_nat_n_less_equal_power_2, clarsimp simp: word_size)

lemma word_rsplit_0:
  "word_rsplit (0 :: word64) = [0, 0, 0, 0, 0, 0, 0, 0 :: word8]"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma unat_ucast_10_64 :
  fixes x :: "10 word"
  shows "unat (ucast x :: word64) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma bool_mask [simp]:
  fixes x :: word64
  shows "(0 < x && 1) = (x && 1 = 1)"
  by (rule bool_mask') auto

lemma word64_bounds:
  "- (2 ^ (size (x :: word64) - 1)) = (-9223372036854775808 :: int)"
  "((2 ^ (size (x :: word64) - 1)) - 1) = (9223372036854775807 :: int)"
  "- (2 ^ (size (y :: 64 signed word) - 1)) = (-9223372036854775808 :: int)"
  "((2 ^ (size (y :: 64 signed word) - 1)) - 1) = (9223372036854775807 :: int)"
  by (simp_all add: word_size)

lemma word_ge_min:"sint (x::64 word) \<ge> -9223372036854775808"
  by (metis sint_ge word64_bounds(1) word_size)

lemmas signed_arith_ineq_checks_to_eq_word64'
    = signed_arith_ineq_checks_to_eq[where 'a=64]
      signed_arith_ineq_checks_to_eq[where 'a="64 signed"]

lemmas signed_arith_ineq_checks_to_eq_word64
    = signed_arith_ineq_checks_to_eq_word64' [unfolded word64_bounds]

lemmas signed_mult_eq_checks64_to_64'
    = signed_mult_eq_checks_double_size[where 'a=64 and 'b=64]
      signed_mult_eq_checks_double_size[where 'a="64 signed" and 'b=64]

lemmas signed_mult_eq_checks64_to_64 = signed_mult_eq_checks64_to_64'[simplified]

lemmas sdiv_word64_max' = sdiv_word_max [where 'a=64] sdiv_word_max [where 'a="64 signed"]
lemmas sdiv_word64_max = sdiv_word64_max'[simplified word_size, simplified]

lemmas sdiv_word64_min' = sdiv_word_min [where 'a=64] sdiv_word_min [where 'a="64 signed"]
lemmas sdiv_word64_min = sdiv_word64_min' [simplified word_size, simplified]

lemmas sint64_of_int_eq' = sint_of_int_eq [where 'a=64]
lemmas sint64_of_int_eq = sint64_of_int_eq' [simplified]

lemma ucast_of_nats [simp]:
  "(ucast (of_nat x :: word64) :: sword64) = (of_nat x)"
  "(ucast (of_nat x :: word64) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word64) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word8) :: sword8) = (of_nat x)"
  by (auto simp: ucast_of_nat is_down)

lemmas signed_shift_guard_simpler_64'
    = power_strict_increasing_iff[where b="2 :: nat" and y=31]
lemmas signed_shift_guard_simpler_64 = signed_shift_guard_simpler_64'[simplified]

lemma word64_31_less:
  "31 < len_of TYPE (64 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (64)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_64
    = signed_shift_guard_to_word[OF word64_31_less(1-2)]
    signed_shift_guard_to_word[OF word64_31_less(3-4)]

lemma le_step_down_word_3:
  fixes x :: "64 word"
  shows "\<lbrakk>x \<le>  y; x \<noteq> y; y < 2 ^ 64 - 1\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (rule le_step_down_word_2, assumption+)

lemma shiftr_1:
  "(x::word64) >> 1 = 0 \<Longrightarrow> x < 2"
  by word_bitwise clarsimp

lemma mask_step_down_64:
  "(b::64word) && 0x1 = (1::64word) \<Longrightarrow> (\<exists>x. x < 64 \<and> mask x = b >> 1) \<Longrightarrow> (\<exists>x. mask x = b)"
  apply clarsimp
  apply (rule_tac x="x + 1" in exI)
  apply (subgoal_tac "x \<le> 63")
   apply (erule le_step_down_nat, clarsimp simp:mask_def, word_bitwise, clarsimp+)+
   apply (clarsimp simp:mask_def, word_bitwise, clarsimp)
  apply clarsimp
  done

lemma unat_of_int_64:
  "\<lbrakk>i \<ge> 0; i \<le> 2 ^ 63\<rbrakk> \<Longrightarrow> (unat ((of_int i)::sword64)) = nat i"
  unfolding unat_def
  apply (subst eq_nat_nat_iff, clarsimp+)
  apply (simp add: word_of_int uint_word_of_int int_mod_eq')
  done

(* Helper for packing then unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64[simp]:
  "(((ucast ((ucast (x::64 word))::32 word))::64 word) || (((ucast ((ucast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_assemble_id)

(* Another variant of packing and unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64'[simp]:
  "(((ucast ((scast (x::64 word))::32 word))::64 word) || (((ucast ((scast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_scast_assemble_id)

(* Specialiasations of down_cast_same for adding to local simpsets. *)
lemma cast_down_u64: "(scast::64 word \<Rightarrow> 32 word) = (ucast::64 word \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

lemma cast_down_s64: "(scast::64 sword \<Rightarrow> 32 word) = (ucast::64 sword \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Bisim_Subst
  imports Weak_Late_Bisim Strong_Late_Bisim_Subst
begin

consts weakBisimSubst :: "(pi \<times> pi) set"
abbreviation
  weakBisimSubstJudge (infixr "\<approx>\<^sup>s" 65) where "P \<approx>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed weakBisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "P \<approx> Q"
proof -
  from assms substClosedSubset show ?thesis
    by blast
qed

lemma strongBisimWeakBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<approx>\<^sup>s Q"
using assms
by(auto simp add: substClosed_def intro: strongBisimWeakBisim)

lemma eqvt:
  shows "eqvt (substClosed weakBisim)"
by(rule eqvtSubstClosed[OF Weak_Late_Bisim.eqvt])

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<approx>\<^sup>s Q"

  shows "(perm \<bullet> P) \<approx>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule_tac eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<approx>\<^sup>s P"
by(force simp add: substClosed_def intro: Weak_Late_Bisim.reflexive)

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "Q \<approx>\<^sup>s P"
using assms
by(force simp add: substClosed_def intro: Weak_Late_Bisim.symmetric)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<approx>\<^sup>s Q"

  shows "P[<s>] \<approx>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: substClosed_def)
  fix s'
  assume "\<forall>s. P[<s>] \<approx> Q[<s>]"
  hence "P[<(s@s')>] \<approx> Q[<(s@s')>]" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "(P[<s>])[<s'>] \<approx> (Q[<s>])[<s'>]"
    by simp
qed

end


(*<*)
theory Example_Verification
imports "HOL-SPARK-Examples.Greatest_Common_Divisor" Simple_Greatest_Common_Divisor
begin
(*>*)

chapter \<open>Verifying an Example Program\<close>

text \<open>
\label{sec:example-verification}
\begin{figure}
\lstinputlisting{Gcd.ads}
\lstinputlisting{Gcd.adb}
\caption{\SPARK{} program for computing the greatest common divisor}
\label{fig:gcd-prog}
\end{figure}

\begin{figure}
\input{Greatest_Common_Divisor}
\caption{Correctness proof for the greatest common divisor program}
\label{fig:gcd-proof}
\end{figure}
We will now explain the usage of the \SPARK{} verification environment by proving
the correctness of an example program. As an example, we use a program for computing
the \emph{greatest common divisor} of two natural numbers shown in \figref{fig:gcd-prog},
which has been taken from the book about \SPARK{} by Barnes \<^cite>\<open>\<open>\S 11.6\<close> in Barnes\<close>.
\<close>

section \<open>Importing \SPARK{} VCs into Isabelle\<close>

text \<open>
In order to specify that the \SPARK{} procedure \texttt{G\_C\_D} behaves like its
mathematical counterpart, Barnes introduces a \emph{proof function} \texttt{Gcd}
in the package specification. Invoking the \SPARK{} Examiner and Simplifier on
this program yields a file \texttt{g\_c\_d.siv} containing the simplified VCs,
as well as files \texttt{g\_c\_d.fdl} and \texttt{g\_c\_d.rls}, containing FDL
declarations and rules, respectively. The files generated by \SPARK{} are assumed to reside in the
subdirectory \texttt{greatest\_common\_divisor}. For \texttt{G\_C\_D} the
Examiner generates ten VCs, eight of which are proved automatically by
the Simplifier. We now show how to prove the remaining two VCs
interactively using HOL-\SPARK{}. For this purpose, we create a \emph{theory}
\texttt{Greatest\_Common\_Divisor}, which is shown in \figref{fig:gcd-proof}.
A theory file always starts with the keyword \isa{\isacommand{theory}} followed
by the name of the theory, which must be the same as the file name. The theory
name is followed by the keyword \isa{\isacommand{imports}} and a list of theories
imported by the current theory. All theories using the HOL-\SPARK{} verification
environment must import the theory \texttt{SPARK}. In addition, we also include
the \texttt{GCD} theory. The list of imported theories is followed by the
\isa{\isacommand{begin}} keyword. In order to interactively process the theory
shown in \figref{fig:gcd-proof}, we start Isabelle with the command
\begin{verbatim}
  isabelle jedit -l HOL-SPARK Greatest_Common_Divisor.thy
\end{verbatim}
The option ``\texttt{-l HOL-SPARK}'' instructs Isabelle to load the right
object logic image containing the verification environment. Each proof function
occurring in the specification of a \SPARK{} program must be linked with a
corresponding Isabelle function. This is accomplished by the command
\isa{\isacommand{spark\_proof\_functions}}, which expects a list of equations
of the form \emph{name}\texttt{\ =\ }\emph{term}, where \emph{name} is the
name of the proof function and \emph{term} is the corresponding Isabelle term.
In the case of \texttt{gcd}, both the \SPARK{} proof function and its Isabelle
counterpart happen to have the same name. Isabelle checks that the type of the
term linked with a proof function agrees with the type of the function declared
in the \texttt{*.fdl} file.
It is worth noting that the
\isa{\isacommand{spark\_proof\_functions}} command can be invoked both outside,
i.e.\ before \isa{\isacommand{spark\_open}}, and inside the environment, i.e.\ after
\isa{\isacommand{spark\_open}}, but before any \isa{\isacommand{spark\_vc}} command. The
former variant is useful when having to declare proof functions that are shared by several
procedures, whereas the latter has the advantage that the type of the proof function
can be checked immediately, since the VCs, and hence also the declarations of proof
functions in the \texttt{*.fdl} file have already been loaded.
\begin{figure}
\begin{flushleft}
\tt
Context: \\
\ \\
\begin{tabular}{ll}
fixes & \<open>m ::\<close>\ "\<open>int\<close>" \\
and   & \<open>n ::\<close>\ "\<open>int\<close>" \\
and   & \<open>c ::\<close>\ "\<open>int\<close>" \\
and   & \<open>d ::\<close>\ "\<open>int\<close>" \\
assumes & \<open>g_c_d_rules1:\<close>\ "\<open>0 \<le> integer__size\<close>" \\
and     & \<open>g_c_d_rules6:\<close>\ "\<open>0 \<le> natural__size\<close>" \\
\multicolumn{2}{l}{notes definition} \\
\multicolumn{2}{l}{\hspace{2ex}\<open>defns =\<close>\ `\<open>integer__first = - 2147483648\<close>`} \\
\multicolumn{2}{l}{\hspace{4ex}`\<open>integer__last = 2147483647\<close>`} \\
\multicolumn{2}{l}{\hspace{4ex}\dots}
\end{tabular}\ \\[1.5ex]
\ \\
Definitions: \\
\ \\
\begin{tabular}{ll}
\<open>g_c_d_rules2:\<close> & \<open>integer__first = - 2147483648\<close> \\
\<open>g_c_d_rules3:\<close> & \<open>integer__last = 2147483647\<close> \\
\dots
\end{tabular}\ \\[1.5ex]
\ \\
Verification conditions: \\
\ \\
path(s) from assertion of line 10 to assertion of line 10 \\
\ \\
\<open>procedure_g_c_d_4\<close>\ (unproved) \\
\ \ \begin{tabular}{ll}
assumes & \<open>H1:\<close>\ "\<open>0 \<le> c\<close>" \\
and     & \<open>H2:\<close>\ "\<open>0 < d\<close>" \\
and     & \<open>H3:\<close>\ "\<open>gcd c d = gcd m n\<close>" \\
\dots \\
shows & "\<open>0 < c - c sdiv d * d\<close>" \\
and   & "\<open>gcd d (c - c sdiv d * d) = gcd m n\<close>
\end{tabular}\ \\[1.5ex]
\ \\
path(s) from assertion of line 10 to finish \\
\ \\
\<open>procedure_g_c_d_11\<close>\ (unproved) \\
\ \ \begin{tabular}{ll}
assumes & \<open>H1:\<close>\ "\<open>0 \<le> c\<close>" \\
and     & \<open>H2:\<close>\ "\<open>0 < d\<close>" \\
and     & \<open>H3:\<close>\ "\<open>gcd c d = gcd m n\<close>" \\
\dots \\
shows & "\<open>d = gcd m n\<close>"
\end{tabular}
\end{flushleft}
\caption{Output of \isa{\isacommand{spark\_status}} for \texttt{g\_c\_d.siv}}
\label{fig:gcd-status}
\end{figure}
We now instruct Isabelle to open
a new verification environment and load a set of VCs. This is done using the
command \isa{\isacommand{spark\_open}}, which must be given the name of a
\texttt{*.siv} file as an argument. Behind the scenes, Isabelle
parses this file and the corresponding \texttt{*.fdl} and \texttt{*.rls} files,
and converts the VCs to Isabelle terms. Using the command \isa{\isacommand{spark\_status}},
the user can display the current VCs together with their status (proved, unproved).
The variants \isa{\isacommand{spark\_status}\ (proved)}
and \isa{\isacommand{spark\_status}\ (unproved)} show only proved and unproved
VCs, respectively. For \texttt{g\_c\_d.siv}, the output of
\isa{\isacommand{spark\_status}} is shown in \figref{fig:gcd-status}.
To minimize the number of assumptions, and hence the size of the VCs,
FDL rules of the form ``\dots\ \texttt{may\_be\_replaced\_by}\ \dots'' are
turned into native Isabelle definitions, whereas other rules are modelled
as assumptions.
\<close>

section \<open>Proving the VCs\<close>

text \<open>
\label{sec:proving-vcs}
The two open VCs are \<open>procedure_g_c_d_4\<close> and \<open>procedure_g_c_d_11\<close>,
both of which contain the \<open>gcd\<close> proof function that the \SPARK{} Simplifier
does not know anything about. The proof of a particular VC can be started with
the \isa{\isacommand{spark\_vc}} command, which is similar to the standard
\isa{\isacommand{lemma}} and \isa{\isacommand{theorem}} commands, with the
difference that it only takes a name of a VC but no formula as an argument.
A VC can have several conclusions that can be referenced by the identifiers
\<open>?C1\<close>, \<open>?C2\<close>, etc. If there is just one conclusion, it can
also be referenced by \<open>?thesis\<close>. It is important to note that the
\texttt{div} operator of FDL behaves differently from the \<open>div\<close> operator
of Isabelle/HOL on negative numbers. The former always truncates towards zero,
whereas the latter truncates towards minus infinity. This is why the FDL
\texttt{div} operator is mapped to the \<open>sdiv\<close> operator in Isabelle/HOL,
which is defined as
@{thm [display] sdiv_def}
For example, we have that
@{lemma "-5 sdiv 4 = -1" by (simp add: sdiv_neg_pos)}, but
@{lemma "(-5::int) div 4 = -2" by simp}.
For non-negative dividend and divisor, \<open>sdiv\<close> is equivalent to \<open>div\<close>,
as witnessed by theorem \<open>sdiv_pos_pos\<close>:
@{thm [display,mode=no_brackets] sdiv_pos_pos}
In contrast, the behaviour of the FDL \texttt{mod} operator is equivalent to
the one of Isabelle/HOL. Moreover, since FDL has no counterpart of the \SPARK{}
operator \textbf{rem}, the \SPARK{} expression \texttt{c}\ \textbf{rem}\ \texttt{d}
just becomes \<open>c - c sdiv d * d\<close> in Isabelle. The first conclusion of
\<open>procedure_g_c_d_4\<close> requires us to prove that the remainder of \<open>c\<close>
and \<open>d\<close> is greater than \<open>0\<close>. To do this, we use the theorem
\<open>minus_div_mult_eq_mod [symmetric]\<close> describing the correspondence between \<open>div\<close>
and \<open>mod\<close>
@{thm [display] minus_div_mult_eq_mod [symmetric]}
together with the theorem \<open>pos_mod_sign\<close> saying that the result of the
\<open>mod\<close> operator is non-negative when applied to a non-negative divisor:
@{thm [display] pos_mod_sign}
We will also need the aforementioned theorem \<open>sdiv_pos_pos\<close> in order for
the standard Isabelle/HOL theorems about \<open>div\<close> to be applicable
to the VC, which is formulated using \<open>sdiv\<close> rather that \<open>div\<close>.
Note that the proof uses \texttt{`\<open>0 \<le> c\<close>`} and \texttt{`\<open>0 < d\<close>`}
rather than \<open>H1\<close> and \<open>H2\<close> to refer to the hypotheses of the current
VC. While the latter variant seems more compact, it is not particularly robust,
since the numbering of hypotheses can easily change if the corresponding
program is modified, making the proof script hard to adjust when there are many hypotheses.
Moreover, proof scripts using abbreviations like \<open>H1\<close> and \<open>H2\<close>
are hard to read without assistance from Isabelle.
The second conclusion of \<open>procedure_g_c_d_4\<close> requires us to prove that
the \<open>gcd\<close> of \<open>d\<close> and the remainder of \<open>c\<close> and \<open>d\<close>
is equal to the \<open>gcd\<close> of the original input values \<open>m\<close> and \<open>n\<close>,
which is the actual \emph{invariant} of the procedure. This is a consequence
of theorem \<open>gcd_non_0_int\<close>
@{thm [display] gcd_non_0_int}
Again, we also need theorems \<open>minus_div_mult_eq_mod [symmetric]\<close> and \<open>sdiv_pos_pos\<close>
to justify that \SPARK{}'s \textbf{rem} operator is equivalent to Isabelle's
\<open>mod\<close> operator for non-negative operands.
The VC \<open>procedure_g_c_d_11\<close> says that if the loop invariant holds before
the last iteration of the loop, the postcondition of the procedure will hold
after execution of the loop body. To prove this, we observe that the remainder
of \<open>c\<close> and \<open>d\<close>, and hence \<open>c mod d\<close> is \<open>0\<close> when exiting
the loop. This implies that \<open>gcd c d = d\<close>, since \<open>c\<close> is divisible
by \<open>d\<close>, so the conclusion follows using the assumption \<open>gcd c d = gcd m n\<close>.
This concludes the proofs of the open VCs, and hence the \SPARK{} verification
environment can be closed using the command \isa{\isacommand{spark\_end}}.
This command checks that all VCs have been proved and issues an error message
if there are remaining unproved VCs. Moreover, Isabelle checks that there is
no open \SPARK{} verification environment when the final \isa{\isacommand{end}}
command of a theory is encountered.
\<close>

section \<open>Optimizing the proof\<close>

text \<open>
\begin{figure}
\lstinputlisting{Simple_Gcd.adb}
\input{Simple_Greatest_Common_Divisor}
\caption{Simplified greatest common divisor program and proof}
\label{fig:simple-gcd-proof}
\end{figure}
When looking at the program from \figref{fig:gcd-prog} once again, several
optimizations come to mind. First of all, like the input parameters of the
procedure, the local variables \texttt{C}, \texttt{D}, and \texttt{R} can
be declared as \texttt{Natural} rather than \texttt{Integer}. Since natural
numbers are non-negative by construction, the values computed by the algorithm
are trivially proved to be non-negative. Since we are working with non-negative
numbers, we can also just use \SPARK{}'s \textbf{mod} operator instead of
\textbf{rem}, which spares us an application of theorems \<open>minus_div_mult_eq_mod [symmetric]\<close>
and \<open>sdiv_pos_pos\<close>. Finally, as noted by Barnes \<^cite>\<open>\<open>\S 11.5\<close> in Barnes\<close>,
we can simplify matters by placing the \textbf{assert} statement between
\textbf{while} and \textbf{loop} rather than directly after the \textbf{loop}.
In the former case, the loop invariant has to be proved only once, whereas in
the latter case, it has to be proved twice: since the \textbf{assert} occurs after
the check of the exit condition, the invariant has to be proved for the path
from the \textbf{assert} statement to the \textbf{assert} statement, and for
the path from the \textbf{assert} statement to the postcondition. In the case
of the \texttt{G\_C\_D} procedure, this might not seem particularly problematic,
since the proof of the invariant is very simple, but it can unnecessarily
complicate matters if the proof of the invariant is non-trivial. The simplified
program for computing the greatest common divisor, together with its correctness
proof, is shown in \figref{fig:simple-gcd-proof}. Since the package specification
has not changed, we only show the body of the packages. The two VCs can now be
proved by a single application of Isabelle's proof method \<open>simp\<close>.
\<close>

(*<*)
end
(*>*)