theory Short_Theory_8_3_2
  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
begin
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

(* TODO *)

subsection "List setup"

fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
  "(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))" |
  "[] !! i = undefined"

lemma inth_append [simp]: "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induct xs arbitrary: i) (auto simp: algebra_simps)

abbreviation (output) "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

type_synonym addr = int

datatype instr =
  LOADI int | LOAD addr |
  ADD |
  STORE addr |
  JMP int | JMPLESS int | JMPGE int

type_synonym stack = "val list"
type_synonym mem_state = "addr \<Rightarrow> val"
type_synonym mmap = "vname \<Rightarrow> addr"
type_synonym config = "int \<times> mem_state \<times> stack"

abbreviation "hd2 xs == hd (tl xs)"
abbreviation "tl2 xs == tl (tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
  "iexec (LOAD a) (i, s, stk) = (i + 1, s, s a # stk)" |
  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
  "iexec (STORE a) (i, s, stk) = (i + 1, s(a := hd stk), tl stk)" |
  "iexec (JMP n) (i, s, stk) = (i + 1 + n, s, stk)" |
  "iexec (JMPLESS n) (i, s, stk) = (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk)" |
  "iexec (JMPGE n) (i, s, stk) = (if hd2 stk >= hd stk then i + 1 + n else i + 1, s, tl2 stk)"

definition exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)  where
  "P \<turnstile> c \<rightarrow> c' \<longleftrightarrow>
  (\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P !! i) (i, s, stk) \<Longrightarrow>
  0 \<le> i \<Longrightarrow> i < size P \<Longrightarrow>
  P \<turnstile> (i, s, stk) \<rightarrow> c'"
  by (simp add: exec1_def)
code_pred exec1 by (metis exec1_def)

lemma exec1D [dest!]: "P \<turnstile> (i, s, stk) \<rightarrow> c' \<Longrightarrow> c' = iexec (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P"
  using exec1_def by auto

abbreviation exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50) where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

(* proof by case analysis on instructions, and that each case changes the PC relative to its
  initial value
*)
lemma iexec_shift [simp]:
  "(n + i', s') = iexec x (n + i, s) \<longleftrightarrow>
  (i', s') = iexec x (i, s)"
proof -
  {
    fix fs' ss' fs ss
    have "(n + i', fs', ss') = iexec x (n + i, fs, ss) \<longleftrightarrow>
    (i', fs', ss') = iexec x (i, fs, ss)"
      by (cases x, auto)
  }
  then have "(n + i', fst s', snd s') = iexec x (n + i, fst s, snd s) \<longleftrightarrow>
  (i', fst s', snd s') = iexec x (i, fst s, snd s)" .
  then show "(n + i', s') = iexec x (n + i, s) \<longleftrightarrow>
  (i', s') = iexec x (i, s)" by simp
qed

(* trivial: iexec (P !! i) depends only on first i elements of P, and 0 \<le> i < size P *)
lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow> c'"
  by (auto simp add: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow>* c'"
  by (induct rule: star.induct) (blast intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow> (i', s', stk') \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow> (size P' + i', s', stk')"
  by (auto simp add: exec1_def)

lemma exec_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')  \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow>* (size P' + i', s', stk')"
  by (induct rule: exec_induct) (blast intro: star.step exec1_appendL)+

(* specialize append lemmas to discuss execution through concrete instructions
  while assuming the execution of preceding and following code.
*)
lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0, s, stk) \<rightarrow>* (j, t, stk') \<Longrightarrow>
  instr # P \<turnstile> (1, s, stk) \<rightarrow>* (1 + j, t, stk')"
  by (drule exec_appendL [where P'="[instr]"]) simp

(* as exec_appendL, with (i := i - size P'), precondition necessary to satisfy exec1 precondition *)
lemma exec_appendL_if [intro]:
  fixes i i' j :: int
  shows "size P' \<le> i \<Longrightarrow>
    P \<turnstile> (i - size P', s, stk) \<rightarrow>* (j, s', stk') \<Longrightarrow>
    i' = size P' + j \<Longrightarrow>
    P' @ P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')"
  by (drule exec_appendL [where P'=P']) simp

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk') \<Longrightarrow>
    size P \<le> i' \<Longrightarrow>
    P' \<turnstile>  (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'') \<Longrightarrow>
    j'' = size P + i'' \<Longrightarrow>
    P @ P' \<turnstile> (0, s, stk) \<rightarrow>* (j'', s'', stk'')"
  by(metis star_trans [OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "mmap existence"

lemma remdups_subset: "set a \<subseteq> set b \<Longrightarrow> set a \<subseteq> set (remdups b)" by simp

fun vars_in_aexp :: "aexp \<Rightarrow> vname list" where
  "vars_in_aexp (N _) = []" |
  "vars_in_aexp (V x) = [x]" |
  "vars_in_aexp (Plus a\<^sub>1 a\<^sub>2) = vars_in_aexp a\<^sub>1 @ vars_in_aexp a\<^sub>2"

fun vars_in_bexp :: "bexp \<Rightarrow> vname list" where
  "vars_in_bexp (Bc _) = []" |
  "vars_in_bexp (Not b) = vars_in_bexp b" |
  "vars_in_bexp (And b\<^sub>1 b\<^sub>2) = vars_in_bexp b\<^sub>1 @ vars_in_bexp b\<^sub>2" |
  "vars_in_bexp (Less a\<^sub>1 a\<^sub>2) = vars_in_aexp a\<^sub>1 @ vars_in_aexp a\<^sub>2"

fun vars_in_com :: "com \<Rightarrow> vname list" where
  "vars_in_com SKIP = []" |
  "vars_in_com (x ::= a) = x # vars_in_aexp a" |
  "vars_in_com (c\<^sub>1;; c\<^sub>2) = vars_in_com c\<^sub>1 @ vars_in_com c\<^sub>2" |
  "vars_in_com (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = vars_in_bexp b @ vars_in_com c\<^sub>1 @ vars_in_com c\<^sub>2" |
  "vars_in_com (WHILE b DO c) = vars_in_bexp b @ vars_in_com c"

abbreviation vars_in :: "com \<Rightarrow> vname list" where
  "vars_in c \<equiv> remdups (vars_in_com c)"

abbreviation svars_in :: "com \<Rightarrow> vname set" where
  "svars_in c \<equiv> set (vars_in c)"

abbreviation addrs_in :: "com \<Rightarrow> int set" where
  "addrs_in c \<equiv> int ` {..<length (vars_in c)}"

lemma vars_in_distinct: "distinct (vars_in c)" by auto

fun nth_inv_c :: "com \<Rightarrow> vname \<Rightarrow> nat" where
  "nth_inv_c c = the_inv_into {..<length (vars_in c)} ((!) (vars_in c))"

fun addr_of :: "com \<Rightarrow> vname \<Rightarrow> int" where
  "addr_of c v = (if v \<in> svars_in c
    then (int \<circ> nth_inv_c c) v
    else -1)"

lemma bij_addr_of: "bij_betw (addr_of c) (svars_in c) (addrs_in c)"
proof -
  have "bij_betw ((!) (vars_in c)) {..<length (vars_in c)} (svars_in c)"
    by (rule bij_betw_nth, auto simp add: vars_in_distinct)
  then have 0: "bij_betw (nth_inv_c c) (svars_in c) {..<length (vars_in c)}" (is ?P0)
    by (simp add: bij_betw_the_inv_into)
  have 1: "bij_betw int {..<length (vars_in c)} (addrs_in c)" (is ?P1) by simp
  have "?P1 \<longleftrightarrow>
    bij_betw (int \<circ> nth_inv_c c) (svars_in c) (addrs_in c)" (is "?P1 \<longleftrightarrow> ?P2")
    by (rule bij_betw_comp_iff [OF 0])
  with 1 have 2: ?P2 by blast
  have "bij_betw (addr_of c) (svars_in c) (addrs_in c) \<longleftrightarrow> ?P2"
    by (rule bij_betw_cong, simp)
  with 2 show ?thesis by blast
qed

corollary inj_on_addr_of: "inj_on (addr_of c) (svars_in c)" using bij_betw_def by (blast intro: bij_addr_of)

subsection "mmap setup"

lemma inj_on_cancel_r: "\<lbrakk>inj_on b A; f \<circ> b = g \<circ> b\<rbrakk> \<Longrightarrow> \<forall> x \<in> b ` A. f x = g x" using comp_eq_dest by fastforce

lemma inj_on_comp_update: "inj_on b A \<Longrightarrow> \<forall> x \<in> A. \<forall> z \<in> A. ((f \<circ> b) (x := y)) z = (f (b x := y) \<circ> b) z"
proof
  fix x
  assume H1: "x \<in> A"
  assume H2: "inj_on b A"
  {
    fix z
    assume H3: "z \<in> A"
    have "((f \<circ> b) (x := y)) z = (f (b x := y) \<circ> b) z"
    proof (cases "z = x")
      case False
      then have "((f \<circ> b) (x := y)) z = f (b z)" by simp
      also from H1 H2 H3 have "b z \<noteq> b x" by (meson False inj_on_def)
      then have "f (b z) = (f(b x := y) \<circ> b) z" by simp
      finally show ?thesis .
    qed simp
  }
  then show "\<forall>z\<in>A. ((f \<circ> b)(x := y)) z = (f(b x := y) \<circ> b) z" by blast
qed

lemma inj_on_cancel_r2: "inj_on b A \<Longrightarrow> \<exists> g. \<forall> x \<in> A. f x = (g \<circ> b) x"
proof -
  assume "inj_on b A"
  then have "bij_betw b A (b ` A)" using bij_betw_def by blast
  then show ?thesis by (metis bij_betw_inv_into_left comp_apply comp_def)
qed

subsection "Compilation"

fun acomp :: "mmap \<Rightarrow> aexp \<Rightarrow> instr list" where
  "acomp m (N n) = [LOADI n]" |
  "acomp m (V x) = [LOAD (m x)]" |
  "acomp m (Plus a1 a2) = acomp m a1 @ acomp m a2 @ [ADD]"

lemma acomp_correct[intro]:
  "(\<forall> v \<in> set (vars_in_aexp a). s v = s' (m v)) \<Longrightarrow> (acomp m a \<turnstile> (0, s', stk) \<rightarrow>* (size (acomp m a), s', aval a s # stk))"
proof (induct a arbitrary: stk s')
  case (Plus a1 a2)
  from Plus(1, 3) have "acomp m a1 \<turnstile> (0, s', stk) \<rightarrow>* (size (acomp m a1), s', aval a1 s # stk)" by simp
  moreover from Plus(2, 3) have "acomp m a2 \<turnstile> (0, s', aval a1 s # stk) \<rightarrow>* (size (acomp m a2), s', aval a2 s # aval a1 s # stk)" by simp
  ultimately show ?case by fastforce
qed fastforce+

fun bcomp :: "mmap \<Rightarrow> bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
  "bcomp m (Bc v) f n = (if v = f then [JMP n] else [])" |
  "bcomp m (Not b) f n = bcomp m b (\<not>f) n" |
  "bcomp m (And b1 b2) f n = (let
    cb2 = bcomp m b2 f n;
    n' = if f
      then size cb2
      else size cb2 + n;
    cb1 = bcomp m b1 False n' in
    cb1 @ cb2)" |
  "bcomp m (Less a1 a2) f n =
    acomp m a1 @ acomp m a2 @ (if f then [JMPLESS n] else [JMPGE n])"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  (\<forall> v \<in> set (vars_in_bexp b). (s v = s' (m v))) \<Longrightarrow>
  bcomp m b f n \<turnstile>
 (0, s', stk) \<rightarrow>* (size (bcomp m b f n) + (if f = bval b s then n else 0), s', stk)"
proof (induct b arbitrary: f n)
  case (Not b)
  then have "bcomp m b (\<not> f) n \<turnstile> (0, s', stk) \<rightarrow>* (size (bcomp m b (\<not> f) n) + (if (\<not> f) = bval b s then n else 0), s', stk)" by simp
  then show ?case by fastforce
next
  case (And b1 b2)
  let ?bc2 = "bcomp m b2 f n" and ?bv2 = "bval b2 s"
  let ?sizeb2 = "size ?bc2"

  let ?n' = "if f then ?sizeb2 else ?sizeb2 + n"
  let ?bc1 = "bcomp m b1 False ?n'" and ?bv1 = "bval b1 s"
  let ?sizeb1 = "size ?bc1"

  let ?bcAnd = "bcomp m (And b1 b2) f n"
    and ?bvAnd = "bval (And b1 b2) s"
  let ?sizeAnd = "size ?bcAnd"

  from And(2-4) have H2: "?bc2 \<turnstile> (0, s', stk) \<rightarrow>* (?sizeb2 + (if f = ?bv2 then n else 0), s', stk)" by simp
  from And(1) [of ?n' "False"] And(3, 4) have H1: "?bc1 \<turnstile>
    (0, s', stk) \<rightarrow>* (?sizeb1 + (if False = ?bv1 then ?n' else 0), s', stk)" by fastforce
  show "?bcAnd \<turnstile> (0, s', stk) \<rightarrow>* (?sizeAnd + (if f = ?bvAnd then n else 0), s', stk)" (is ?P)
  proof (cases ?bv1)
    case True
    with H1 H2 show ?thesis by auto
  next
    case Hbv1: False
    show ?thesis
    proof (cases f)
      case Hf: True
      with Hbv1 Hf H1 show ?thesis by auto
    next
      case Hf: False
      from Hf Hbv1 H1 have H1': "?bc1 \<turnstile> (0, s', stk) \<rightarrow>* (?sizeAnd + n, s', stk)" by (simp add: add.assoc)
      then have "?bcAnd \<turnstile> (0, s', stk) \<rightarrow>* (?sizeAnd + n, s', stk)" using exec_appendR by auto
      with Hbv1 Hf H1 show ?thesis by auto
    qed
  qed
next
  case (Less x1a x2a)
  from Less(2) have "(acomp m x1a \<turnstile> (0, s', stk) \<rightarrow>* (size (acomp m x1a), s', aval x1a s # stk))" by auto
  moreover from Less(2) have "(acomp m x2a \<turnstile>
    (0, s', aval x1a s # stk) \<rightarrow>* (size (acomp m x2a), s', aval x2a s # aval x1a s # stk))" by auto
  moreover have "(if f then [JMPLESS n] else [JMPGE n]) \<turnstile>
    (0, s', aval x2a s # aval x1a s # stk) \<rightarrow>* (1 + (if f = bval (Less x1a x2a) s then n else 0), s', stk)" by fastforce
  ultimately show ?case by fastforce
qed fastforce

fun ccomp :: "mmap \<Rightarrow> com \<Rightarrow> instr list" where
  "ccomp m SKIP = []" |
  "ccomp m (x ::= a) = acomp m a @ [STORE (m x)]" |
  "ccomp m (c\<^sub>1;; c\<^sub>2) = ccomp m c\<^sub>1 @ ccomp m c\<^sub>2" |
  "ccomp m (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
    cc\<^sub>1 = ccomp m c\<^sub>1;
    cc\<^sub>2 = ccomp m c\<^sub>2;
    cb = bcomp m b False (size cc\<^sub>1 + 1) in
    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
  "ccomp m (WHILE b DO c) = (let
    cc = ccomp m c;
    cb = bcomp m b False (size cc + 1) in
    cb @ cc @ [JMP (-(size cb + size cc + 1))])"

(* to each big-step that brings a var-val map A to a var-val map B,
  our compiled program non-deterministically brings every addr-val A' state that agrees with A on the variables appearing in the program
  to an addr-val B' state that agrees with B on the variables appearing in the program that yet agrees with A
  on the variables not appearing in the program
*)

(* The notion of the var-val map, on vars not appearing in the commands being preserved is significant here,
  but is not important in the results proven in Big Step. Hence we prove that here.
*)

lemma bigstep_state_invariance: "(c, s) \<Rightarrow> t \<Longrightarrow> (\<forall> v. v \<notin> svars_in c \<longrightarrow> s v = t v)"
  by (induct rule: big_step_induct) simp+

lemma map_invariance: "\<lbrakk>
  inj_on m (svars_in c);
  (c\<^sub>1, s) \<Rightarrow> t;
  svars_in c\<^sub>1 \<subseteq> svars_in c;
  \<forall> v \<in> svars_in c. s v = s' (m v);
  \<forall> v \<in> svars_in c\<^sub>1. t v = t' (m v);
  \<forall> a. (\<nexists> v. v \<in> svars_in c\<^sub>1 \<and> a = m v) \<longrightarrow> s' a = t' a
\<rbrakk> \<Longrightarrow> \<forall> v \<in> svars_in c. t v = t' (m v)"
proof
  assume H1: "inj_on m (svars_in c)"
    and H2: "(c\<^sub>1, s) \<Rightarrow> t"
    and H3: "svars_in c\<^sub>1 \<subseteq> svars_in c"
    and H4: "\<forall> v \<in> svars_in c. s v = s' (m v)"
    and H5: "\<forall> v \<in> svars_in c\<^sub>1. t v = t' (m v)"
    and H6: "\<forall> a. (\<nexists> v. v \<in> svars_in c\<^sub>1 \<and> a = m v) \<longrightarrow> s' a = t' a"
  fix v
  assume H7: "v \<in> svars_in c"
  show "t v = t' (m v)"
  proof (cases "v \<in> svars_in c\<^sub>1")
    case False
    with H3 H7 H1 have H8: "\<nexists>v'. v' \<in> svars_in c\<^sub>1 \<and> (m v) = m v'" using inj_on_eq_iff by fastforce
    from H2 False have "t v = s v" using bigstep_state_invariance by fastforce
    also from H4 H7 have "\<dots> = s' (m v)" by simp
    also from H6 H8 have "\<dots> = t' (m v)" by simp
    finally show ?thesis .
  qed (simp add: H5)
qed

lemma ccomp_bigstep: "\<lbrakk>(c, s) \<Rightarrow> t; inj_on m (svars_in c)\<rbrakk> \<Longrightarrow>
    (\<And> s'. (\<forall> v \<in> svars_in c. s v = s' (m v)) \<Longrightarrow>
      (\<exists> t'. (ccomp m c \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m c), t', stk)) \<and>
          (\<forall> v \<in> svars_in c. t v = t' (m v)) \<and>
          (\<forall> a. (\<nexists> v. v \<in> svars_in c \<and> a = m v) \<longrightarrow> s' a = t' a)))"
proof (induct c s t arbitrary: stk rule: big_step_induct)
  case (Skip s)
  show ?case
  proof (intro exI conjI)
    show "ccomp m SKIP \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m SKIP), s', stk)" by simp
    show "\<forall>v \<in> svars_in SKIP. s v = s' (m v)" by simp
    show "\<forall>a. (\<nexists>v. v \<in> svars_in SKIP \<and> a = m v) \<longrightarrow> s' a = s' a" by simp
  qed
next
  case (Assign x a s)
  show ?case
  proof (intro exI conjI)
    from Assign(2) have "acomp m a \<turnstile> (0, s', stk) \<rightarrow>* (size (acomp m a), s', aval a s # stk)" by auto
    moreover have "[STORE (m x)] \<turnstile> (0, s', aval a s # stk) \<rightarrow>* (1, s'(m x := aval a s), stk)" by fastforce
    ultimately show "ccomp m (x ::= a) \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m (x ::= a)), s'(m x := aval a s), stk)" by auto
    have H1: "x \<in> svars_in (x ::= a)" by simp
    show "\<forall>v \<in> svars_in (x ::= a). (s(x := aval a s)) v = (s'(m x := aval a s)) (m v)"
    proof
      fix v
      assume H2: "v \<in> svars_in (x ::= a)"
      show "(s(x := aval a s)) v = (s'(m x := aval a s)) (m v)"
      proof (cases "v = x")
        case False
        then have "(s(x := aval a s)) v = s v" by simp
        also from Assign(2) H2 have "\<dots> = s' (m v)" by simp
        also from Assign(1) H1 H2 False have "m v \<noteq> m x" by (meson inj_onD)
        then have "s' (m v) = (s'(m x := aval a s)) (m v)" by simp
        finally show ?thesis .
      qed simp
    qed
    show "\<forall>aa. (\<nexists>v. v \<in> svars_in (x ::= a) \<and> aa = m v) \<longrightarrow> s' aa = (s'(m x := aval a s)) aa"
    proof (intro allI impI)
      fix aa
      assume "\<nexists>v. v \<in> svars_in (x ::= a) \<and> aa = m v"
      with H1 have "aa \<noteq> m x" by simp
      then show "s' aa = (s'(m x := aval a s)) aa" by simp
    qed
  qed
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  have Hs1: "svars_in c\<^sub>1 \<subseteq> svars_in (c\<^sub>1;; c\<^sub>2)" by simp
  with Seq(5) have "inj_on m (svars_in c\<^sub>1)" using inj_on_subset by blast
  moreover from Hs1 Seq(6) have "\<forall>v\<in>svars_in c\<^sub>1. s\<^sub>1 v = s' (m v)" by simp
  ultimately have "\<exists>t'. (ccomp m c\<^sub>1 \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m c\<^sub>1), t', stk)) \<and>
             (\<forall>v\<in>svars_in c\<^sub>1. s\<^sub>2 v = t' (m v)) \<and> (\<forall>a. (\<nexists>v. v \<in> svars_in c\<^sub>1 \<and> a = m v) \<longrightarrow> s' a = t' a)" using Seq(2) by fastforce
  then obtain s\<^sub>2' where H1: "ccomp m c\<^sub>1 \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m c\<^sub>1), s\<^sub>2', stk)"
    and H2: "\<forall> v \<in> svars_in c\<^sub>1. s\<^sub>2 v = s\<^sub>2' (m v)"
    and H3: "\<forall> a. (\<nexists> v. v \<in> svars_in c\<^sub>1 \<and> a = m v) \<longrightarrow> s' a = s\<^sub>2' a" by blast
  have Hs2: "svars_in c\<^sub>2 \<subseteq> svars_in (c\<^sub>1;; c\<^sub>2)" by simp
  with Seq(5) have "inj_on m (svars_in c\<^sub>2)" using inj_on_subset by blast
  moreover from Seq(1, 5, 6) Hs1 H2 H3 have H4: "\<forall> v \<in> svars_in (c\<^sub>1;; c\<^sub>2). s\<^sub>2 v = s\<^sub>2' (m v)" using map_invariance by blast
  then have "\<forall> v \<in> svars_in c\<^sub>2. s\<^sub>2 v = s\<^sub>2' (m v)" by simp
  ultimately have "\<exists>t'. (ccomp m c\<^sub>2 \<turnstile> (0, s\<^sub>2', stk) \<rightarrow>* (size (ccomp m c\<^sub>2), t', stk)) \<and>
             (\<forall>v\<in>svars_in c\<^sub>2. s\<^sub>3 v = t' (m v)) \<and> (\<forall>a. (\<nexists>v. v \<in> svars_in c\<^sub>2 \<and> a = m v) \<longrightarrow> s\<^sub>2' a = t' a)" using Seq(4) by fastforce
  then obtain s\<^sub>3' where H5: "ccomp m c\<^sub>2 \<turnstile> (0, s\<^sub>2', stk) \<rightarrow>* (size (ccomp m c\<^sub>2), s\<^sub>3', stk)"
    and H6: "\<forall>v\<in>svars_in c\<^sub>2. s\<^sub>3 v = s\<^sub>3' (m v)"
    and H7: "\<forall>a. (\<nexists>v. v \<in> svars_in c\<^sub>2 \<and> a = m v) \<longrightarrow> s\<^sub>2' a = s\<^sub>3' a" by blast
  show ?case
  proof (intro exI conjI)
    from H1 H5 show "ccomp m (c\<^sub>1;; c\<^sub>2) \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m (c\<^sub>1;; c\<^sub>2)), s\<^sub>3', stk)" by fastforce
    from Seq(3, 5) H4 Hs2 H6 H7 show "\<forall>v\<in>svars_in (c\<^sub>1;; c\<^sub>2). s\<^sub>3 v = s\<^sub>3' (m v)" using map_invariance by blast
    show "\<forall>a. (\<nexists>v. v \<in> svars_in (c\<^sub>1;; c\<^sub>2) \<and> a = m v) \<longrightarrow> s' a = s\<^sub>3' a"
    proof (intro allI impI)
      fix a
      assume "\<nexists>v. v \<in> svars_in (c\<^sub>1;; c\<^sub>2) \<and> a = m v"
      then have HH1: "\<nexists>v. v \<in> svars_in c\<^sub>1 \<and> a = m v"
        and HH2: "\<nexists>v. v \<in> svars_in c\<^sub>2 \<and> a = m v" by auto
      from HH1 H3 have "s' a = s\<^sub>2' a" by simp
      also from HH2 H7 have "s\<^sub>2' a = s\<^sub>3' a" by simp
      finally show "s' a = s\<^sub>3' a" .
    qed
  qed
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  let ?cc\<^sub>1 = "ccomp m c\<^sub>1" and ?cc\<^sub>2 = "ccomp m c\<^sub>2" and ?ci = "ccomp m (IF b THEN c\<^sub>1 ELSE c\<^sub>2)"
  let ?cb = "bcomp m b False (size ?cc\<^sub>1 + 1)"
  have "0 \<le> (size ?cc\<^sub>1 + 1)" by simp
  moreover from IfTrue(5) have "\<forall>v\<in>set (vars_in_bexp b). s' (m v) = s v" by simp
  ultimately have H1: "?cb \<turnstile> (0, s', stk) \<rightarrow>* (size ?cb, s', stk)"
    using IfTrue(1) bcomp_correct [of "size ?cc\<^sub>1 + 1" b s s' m False stk] by fastforce
  have Hs1: "svars_in c\<^sub>1 \<subseteq> svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2)" by auto
  with IfTrue(4) have "inj_on m (svars_in c\<^sub>1)" using inj_on_subset by blast
  moreover from Hs1 IfTrue(5) have "\<forall>v \<in> svars_in c\<^sub>1. s' (m v) = s v" by simp
  ultimately have "\<exists>t'. (?cc\<^sub>1 \<turnstile> (0, s', stk) \<rightarrow>* (size ?cc\<^sub>1, t', stk)) \<and>
    (\<forall>v \<in> svars_in c\<^sub>1. t v = t' (m v)) \<and> (\<forall>a. (\<nexists>v. v \<in> svars_in c\<^sub>1 \<and> a = m v) \<longrightarrow> s' a = t' a)" using IfTrue(3) by simp
  then obtain t' where H2: "?cc\<^sub>1 \<turnstile> (0, s', stk) \<rightarrow>* (size ?cc\<^sub>1, t', stk)"
    and H3: "\<forall>v\<in>svars_in c\<^sub>1. t v = t' (m v)"
    and H4: "\<forall>a. (\<nexists>v. v \<in> svars_in c\<^sub>1 \<and> a = m v) \<longrightarrow> s' a = t' a" by auto
  have H5: "JMP (size ?cc\<^sub>2) # ?cc\<^sub>2 \<turnstile> (0, t', stk) \<rightarrow>* (size ?cc\<^sub>2 + 1, t', stk)"  by fastforce
  from H1 H2 have "?cb @ ?cc\<^sub>1 \<turnstile> (0, s', stk) \<rightarrow>* (size ?cb + size ?cc\<^sub>1, t', stk)" by fastforce
  with H5 have H6: "?cb @ ?cc\<^sub>1 @ JMP (size ?cc\<^sub>2) # ?cc\<^sub>2 \<turnstile> (0, s', stk) \<rightarrow>* (size ?cb + size ?cc\<^sub>1 + (size ?cc\<^sub>2 + 1), t', stk)"
    using exec_append_trans [of "?cb @ ?cc\<^sub>1"] by fastforce
  have "size ?ci = size ?cb + size ?cc\<^sub>1 + (size ?cc\<^sub>2 + 1)" by simp
  with H6 have H7: "?cb @ ?cc\<^sub>1 @ JMP (size ?cc\<^sub>2) # ?cc\<^sub>2 \<turnstile> (0, s', stk) \<rightarrow>* (size ?ci, t', stk)" by presburger
  show ?case
  proof (intro exI conjI)
    from H7 show "?ci \<turnstile> (0, s', stk) \<rightarrow>* (size ?ci, t', stk)" by simp
    from IfTrue(2, 4, 5) Hs1 H3 H4 show "\<forall>v\<in>svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2). t v = t' (m v)" using map_invariance by blast
    from H4 show "\<forall>a. (\<nexists>v. v \<in> svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2) \<and> a = m v) \<longrightarrow> s' a = t' a" by auto
  qed
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  let ?cc\<^sub>1 = "ccomp m c\<^sub>1" and ?cc\<^sub>2 = "ccomp m c\<^sub>2" and ?ci = "ccomp m (IF b THEN c\<^sub>1 ELSE c\<^sub>2)"
  let ?cb = "bcomp m b False (size ?cc\<^sub>1 + 1)"
  have "0 \<le> (size ?cc\<^sub>1 + 1)" by simp
  moreover from IfFalse(5) have "\<forall>v\<in>set (vars_in_bexp b). s' (m v) = s v" by simp
  ultimately have H1: "?cb @ ?cc\<^sub>1 @ [JMP (size ?cc\<^sub>2)] \<turnstile> (0, s', stk) \<rightarrow>* (size ?cb + (size ?cc\<^sub>1 + 1), s', stk)"
    using IfFalse(1) bcomp_correct [of "size ?cc\<^sub>1 + 1" b s s' m False stk] by fastforce
  have Hs2: "svars_in c\<^sub>2 \<subseteq> svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2)" by auto
  with IfFalse(4) have "inj_on m (svars_in c\<^sub>2)" using inj_on_subset by blast
  with IfFalse(3, 5) have "\<exists>t'. (?cc\<^sub>2 \<turnstile> (0, s', stk) \<rightarrow>* (size ?cc\<^sub>2, t', stk)) \<and>
    (\<forall>v\<in>svars_in c\<^sub>2. t v = t' (m v)) \<and> (\<forall>a. (\<nexists>v. v \<in> svars_in c\<^sub>2 \<and> a = m v) \<longrightarrow> s' a = t' a)" by simp
  then obtain t' where H2: "?cc\<^sub>2 \<turnstile> (0, s', stk) \<rightarrow>* (size ?cc\<^sub>2, t', stk)"
    and H3: "\<forall>v\<in>svars_in c\<^sub>2. t v = t' (m v)"
    and H4: "\<forall>a. (\<nexists>v. v \<in> svars_in c\<^sub>2 \<and> a = m v) \<longrightarrow> s' a = t' a" by auto
  have H5: "size (?cb @ ?cc\<^sub>1 @ [JMP (size ?cc\<^sub>2)]) \<le> size ?cb + (size ?cc\<^sub>1 + 1)" by simp
  have "size ?cb + (size ?cc\<^sub>1 + 1) - size (?cb @ ?cc\<^sub>1 @ [JMP (size ?cc\<^sub>2)]) = 0" by simp
  with H2 have H6: "?cc\<^sub>2 \<turnstile> (size ?cb + (size ?cc\<^sub>1 + 1) - size (?cb @ ?cc\<^sub>1 @ [JMP (size ?cc\<^sub>2)]), s', stk) \<rightarrow>* (size ?cc\<^sub>2, t', stk)" by simp
  have H7: "size ?ci = size (?cb @ ?cc\<^sub>1 @ [JMP (size ?cc\<^sub>2)]) + size ?cc\<^sub>2" by simp
  thm exec_append_trans [OF H1 H5 H6 H7]
  have H8: "?cb @ ?cc\<^sub>1 @ [JMP (size ?cc\<^sub>2)] @ ?cc\<^sub>2 \<turnstile> (0, s', stk) \<rightarrow>* (size ?ci, t', stk)"
    using exec_append_trans [OF H1 H5 H6 H7] by simp
  show ?case
  proof (intro exI conjI)
    from H8 show "?ci \<turnstile> (0, s', stk) \<rightarrow>* (size ?ci, t', stk)" by simp
    from IfFalse(2, 4, 5) Hs2 H3 H4 show "\<forall>v\<in>svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2). t v = t' (m v)" using map_invariance by blast
    from H4 show "\<forall>a. (\<nexists>v. v \<in> svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2) \<and> a = m v) \<longrightarrow> s' a = t' a" by auto
  qed
next
  case (WhileFalse b s c)
  let ?cc = "ccomp m c"
  let ?cb = "bcomp m b False (size ?cc + 1)"
  let ?cw = "ccomp m (WHILE b DO c)"
  have H1: "0 \<le> size ?cc + 1" by simp
  from WhileFalse(3) have H2: "\<forall>v\<in>set (vars_in_bexp b). s v = s' (m v)" by simp

  show ?case
  proof (intro exI conjI)
    from WhileFalse(1) bcomp_correct [OF H1, of b s s' m, OF H2, of False stk]
    show "?cw \<turnstile> (0, s', stk) \<rightarrow>* (size ?cw, s', stk)" by auto
    from WhileFalse(3) show "\<forall>v\<in>svars_in (WHILE b DO c). s v = s' (m v)" .
    show "\<forall>a. (\<nexists>v. v \<in> svars_in (WHILE b DO c) \<and> a = m v) \<longrightarrow> s' a = s' a" by simp
  qed
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  let ?cc = "ccomp m c"
  let ?cb = "bcomp m b False (size ?cc + 1)"
  let ?cw = "ccomp m (WHILE b DO c)"
  have H1: "0 \<le> size ?cc + 1" by simp
  from WhileTrue(7) have H2: "\<forall>v\<in>set (vars_in_bexp b). s\<^sub>1 v = s' (m v)" by simp
  from WhileTrue(1) bcomp_correct [OF H1, of b s\<^sub>1 s' m, OF H2, of False stk]
  have H3: "?cb \<turnstile> (0, s', stk) \<rightarrow>* (size ?cb, s', stk)" by fastforce

  thm WhileTrue(3)
  have Hs: "svars_in c \<subseteq> svars_in (WHILE b DO c)" by simp
  with WhileTrue(6) have H4: "inj_on m (svars_in c)" using inj_on_subset by blast
  from WhileTrue(7) have H5: "\<forall>v\<in>svars_in c. s\<^sub>1 v = s' (m v)" by simp
  from WhileTrue(3) [OF H4 H5]
  have "\<exists>t'. (?cc \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m c), t', stk)) \<and>
    (\<forall>v\<in>svars_in c. s\<^sub>2 v = t' (m v)) \<and>
    (\<forall>a. (\<nexists>v. v \<in> svars_in c \<and> a = m v) \<longrightarrow> s' a = t' a)" by simp
  then obtain s\<^sub>2' where H6: "?cc \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp m c), s\<^sub>2', stk)"
    and H7: "\<forall>v\<in>svars_in c. s\<^sub>2 v = s\<^sub>2' (m v)"
    and H8: "\<forall>a. (\<nexists>v. v \<in> svars_in c \<and> a = m v) \<longrightarrow> s' a = s\<^sub>2' a" by auto
  have H9: "size ?cb \<le> size ?cb" by simp
  from H6 have H10: "?cc \<turnstile> (size ?cb - size ?cb, s', stk) \<rightarrow>* (size (ccomp m c), s\<^sub>2', stk)" by simp
  have H11: "size ?cb + size ?cc = size ?cb + size ?cc" by simp
  from exec_append_trans [OF H3 H9 H10 H11]
  have "?cb @ ?cc \<turnstile> (0, s', stk) \<rightarrow>* (size ?cb + size ?cc, s\<^sub>2', stk)" by fastforce
  then have "?cw \<turnstile> (0, s', stk) \<rightarrow>* (size ?cb + size ?cc, s\<^sub>2', stk)" using exec_appendR
    by (metis append.assoc ccomp.simps(5))

  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s\<^sub>2', stk) \<rightarrow>* (0, s\<^sub>2', stk)" by fastforce
  ultimately have H12: "?cw \<turnstile> (0, s', stk) \<rightarrow>* (0, s\<^sub>2', stk)" by (meson star_trans)

  have H13: "\<forall>v\<in>svars_in (WHILE b DO c). s\<^sub>2 v = s\<^sub>2' (m v)"
    using map_invariance [OF WhileTrue(6) WhileTrue(2) Hs WhileTrue(7) H7 H8] .
  moreover from WhileTrue(5) [OF WhileTrue(6) H13] have "\<exists>t'.
    (ccomp m (WHILE b DO c) \<turnstile> (0, s\<^sub>2', stk) \<rightarrow>* (size (ccomp m (WHILE b DO c)), t', stk)) \<and>
    (\<forall>v\<in>svars_in (WHILE b DO c). s\<^sub>3 v = t' (m v)) \<and>
    (\<forall>a. (\<nexists>v. v \<in> svars_in (WHILE b DO c) \<and> a = m v) \<longrightarrow> s\<^sub>2' a = t' a)" .
  then obtain s\<^sub>3' where H14: "?cw \<turnstile> (0, s\<^sub>2', stk) \<rightarrow>* (size ?cw, s\<^sub>3', stk)"
    and H15: "\<forall>v\<in>svars_in (WHILE b DO c). s\<^sub>3 v = s\<^sub>3' (m v)"
    and H16: "\<forall>a. (\<nexists>v. v \<in> svars_in (WHILE b DO c) \<and> a = m v) \<longrightarrow> s\<^sub>2' a = s\<^sub>3' a" by auto
  show ?case
  proof (intro exI conjI)
    from H12 H14 show "?cw \<turnstile> (0, s', stk) \<rightarrow>* (size ?cw, s\<^sub>3', stk)" by (meson star_trans)
    from H15 show "\<forall>v\<in>svars_in (WHILE b DO c). s\<^sub>3 v = s\<^sub>3' (m v)" .
    from Hs H8 H16 show "\<forall>a. (\<nexists>v. v \<in> svars_in (WHILE b DO c) \<and> a = m v) \<longrightarrow> s' a = s\<^sub>3' a"
      using in_mono by auto
  qed
qed

lemma ccomp_bigstep_addr_of: "(c, s) \<Rightarrow> t \<Longrightarrow>
    (\<And> s'. (\<forall> v \<in> svars_in c. s v = s' (addr_of c v)) \<Longrightarrow>
      (\<exists> t'. (ccomp (addr_of c) c \<turnstile> (0, s', stk) \<rightarrow>* (size (ccomp (addr_of c) c), t', stk)) \<and>
          (\<forall> v \<in> svars_in c. t v = t' (addr_of c v)) \<and>
          (\<forall> a. (\<nexists> v. v \<in> svars_in c \<and> a = addr_of c v) \<longrightarrow> s' a = t' a)))"
  using ccomp_bigstep inj_on_addr_of by blast

text \<open>
The preservation of the source code semantics is already shown in the
parent theory \<open>Compiler\<close>. This here shows the second direction.
\<close>

subsection \<open>Definitions\<close>

text \<open>Execution in \<^term>\<open>n\<close> steps for simpler induction\<close>
primrec
  exec_n :: "instr list \<Rightarrow> config \<Rightarrow> nat \<Rightarrow> config \<Rightarrow> bool"
  ("_/ \<turnstile> (_ \<rightarrow>^_/ _)" [65,0,1000,55] 55)
where
  "P \<turnstile> c \<rightarrow>^0 c' = (c'=c)" |
  "P \<turnstile> c \<rightarrow>^(Suc n) c'' = (\<exists>c'. (P \<turnstile> c \<rightarrow> c') \<and> P \<turnstile> c' \<rightarrow>^n c'')"

(* Note: big-step notation causes parsing ambiguity that isn't well-typed *)
text \<open>The possible successor PCs of an instruction at position \<^term>\<open>n\<close>\<close>

definition isuccs :: "instr \<Rightarrow> int \<Rightarrow> int set" where
  "isuccs i n = (case i of
    JMP j \<Rightarrow> {n + 1 + j} |
    JMPLESS j \<Rightarrow> {n + 1 + j, n + 1} |
    JMPGE j \<Rightarrow> {n + 1 + j, n + 1} |
    _ \<Rightarrow> {n +1})"

text \<open>The possible successors PCs of an instruction list starting from position n of P to its end\<close>
definition succs :: "instr list \<Rightarrow> int \<Rightarrow> int set" where
  "succs P n = {s :: int. \<exists>i\<ge>0. i < size P \<and> s \<in> isuccs (P !! i) (n + i)}"

text \<open>Possible exit PCs of a program\<close>
definition exits :: "instr list \<Rightarrow> int set" where
  "exits P = succs P 0 - {0..<size P}"

subsection \<open>Basic properties of \<^term>\<open>exec_n\<close>\<close>

lemma exec_n_exec:
  "P \<turnstile> c \<rightarrow>^n c' \<Longrightarrow> P \<turnstile> c \<rightarrow>* c'"
  by (induct n arbitrary: c) (auto intro: star.step)

lemma exec_0 [intro!]: "P \<turnstile> c \<rightarrow>^0 c" by simp

lemma exec_Suc: "\<lbrakk>P \<turnstile> c \<rightarrow> c'; P \<turnstile> c' \<rightarrow>^n c''\<rbrakk> \<Longrightarrow> P \<turnstile> c \<rightarrow>^(Suc n) c''"
  by (fastforce simp del: split_paired_Ex)

lemma exec_exec_n: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> \<exists>n. P \<turnstile> c \<rightarrow>^n c'"
  by (induct rule: star.induct) (auto intro: exec_Suc)

lemma exec_eq_exec_n: "(P \<turnstile> c \<rightarrow>* c') = (\<exists>n. P \<turnstile> c \<rightarrow>^n c')"
  by (blast intro: exec_exec_n exec_n_exec)

lemma exec_n_Nil [simp]: "[] \<turnstile> c \<rightarrow>^k c' = (c' = c \<and> k = 0)"
  by (induct k) (auto simp: exec1_def)

lemma exec1_exec_n [intro!]: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P \<turnstile> c \<rightarrow>^1 c'"
  by (cases c') simp

subsection \<open>Concrete symbolic execution steps\<close>

lemma exec_n_step: "n \<noteq> n' \<Longrightarrow>
  P \<turnstile> (n, s, stk) \<rightarrow>^k (n', s', stk') \<longleftrightarrow> (\<exists>c. P \<turnstile> (n, s, stk) \<rightarrow> c \<and> P \<turnstile> c \<rightarrow>^(k - 1) (n', s', stk') \<and> 0 < k)"
  by (cases k) auto

text \<open>Note: fst c refers to the program counter\<close>
lemma exec1_end: "size P \<le> fst c \<Longrightarrow> \<not> P \<turnstile> c \<rightarrow> c'"
  by (auto simp: exec1_def)

lemma exec_n_end: "size P \<le> n \<Longrightarrow> P \<turnstile> (n, s, stk) \<rightarrow>^k (n', s', stk') = (n' = n \<and> stk' = stk \<and> s' = s \<and> k = 0)"
  by (cases k) (auto simp: exec1_end)

lemmas exec_n_simps = exec_n_step exec_n_end

subsection \<open>Basic properties of \<^term>\<open>succs\<close>\<close>

(* follows directly from isuccs_def *)
lemma succs_simps [simp]:
  "succs [ADD] n = {n + 1}"
  "succs [LOADI v] n = {n + 1}"
  "succs [LOAD x] n = {n + 1}"
  "succs [STORE x] n = {n + 1}"
  "succs [JMP i] n = {n + 1 + i}"
  "succs [JMPGE i] n = {n + 1 + i, n + 1}"
  "succs [JMPLESS i] n = {n + 1 + i, n + 1}"
  by (auto simp: succs_def isuccs_def)

lemma succs_empty [iff]: "succs [] n = {}"
  by (simp add: succs_def)

lemma succs_Cons:
  "succs (x # xs) n = isuccs x n \<union> succs xs (1 + n)" (is "_ = ?x \<union> ?xs")
proof
  show "succs (x#xs) n \<subseteq> isuccs x n \<union> succs xs (1 + n)"
  proof
    fix p
    assume "p \<in> succs (x#xs) n"
    then have "\<exists>i\<ge>0. i < size (x # xs) \<and> p \<in> isuccs ((x # xs) !! i) (n + i)" unfolding succs_def by simp
    then obtain i where isuccs: "0 \<le> i" "i < size (x # xs)" "p \<in> isuccs ((x # xs) !! i) (n + i)" by auto
    (* iff i = 0, our p in succs (x # xn) is produced by the instruction x; hence we case split on whether input pc is 0 *)
    show "p \<in> isuccs x n \<union> succs xs (1 + n)"
    proof cases
      assume "i = 0"
      with isuccs(3) show ?thesis by simp
    next
      assume "i \<noteq> 0"
      with isuccs
      have "0 \<le> i - 1" "i - 1 < size xs" "p \<in> isuccs (xs !! (i - 1)) (1 + n + (i - 1))" by auto
      then have "p \<in> ?xs" unfolding succs_def by blast
      thus ?thesis ..
    qed
  qed

  show "isuccs x n \<union> succs xs (1 + n) \<subseteq> succs (x#xs) n"
  proof
    fix p
    assume "p \<in> isuccs x n \<union> succs xs (1 + n)"
    then consider "p \<in> ?x" | "p \<in> ?xs" by auto
    then show "p \<in> succs (x#xs) n"
    proof cases
      assume "p \<in> isuccs x n"
      then show ?thesis by (fastforce simp: succs_def)
    next
      assume "p \<in> succs xs (1 + n)"
      then obtain i where "0 \<le> i" "i < size xs" "p \<in> isuccs (xs !! i) (1 + n + i)"
        unfolding succs_def by auto
      then have "0 \<le> 1 + i" "1 + i < size (x # xs)" "p \<in> isuccs ((x # xs) !! (1 + i)) (n + (1 + i))"
        by (simp add: algebra_simps)+
      thus ?thesis unfolding succs_def by blast
    qed
  qed
qed

text \<open>the pc at the end of an instruction execution in P are indeed in the successors of P\<close>
lemma succs_iexec1:
  assumes "c' = iexec (P!!i) (i, s, stk)" "0 \<le> i" "i < size P"
  shows "fst c' \<in> succs P 0"
  using assms by (cases "P !! i", auto simp: succs_def isuccs_def)

text \<open>Successor of an instruction of P as a subprogram at the 0th index of a larger program is
  is the same successor shifted n places if we consider P as a subprogram at the nth index instead\<close>
lemma succs_shift:
  "p - n \<in> succs P 0 \<longleftrightarrow> p \<in> succs P n"
  by (fastforce simp: succs_def isuccs_def split: instr.split)

lemma inj_op_plus [simp]:
  "inj ((+) (i::int))"
  by (rule Fun.cancel_semigroup_add_class.inj_add_left)

lemma succs_set_shift [simp]:
  "(+) i ` succs xs 0 = succs xs i"
  by (force simp: succs_shift [where n=i, symmetric] intro: set_eqI)

lemma succs_append [simp]:
  "succs (xs @ ys) n = succs xs n \<union> succs ys (n + size xs)"
  by (induct xs arbitrary: n) (auto simp: succs_Cons algebra_simps)

lemma exits_append [simp]:
  "exits (xs @ ys) = exits xs \<union> ((+) (size xs)) ` exits ys -
                     {0..<size xs + size ys}"
  by (auto simp: exits_def image_set_diff)

lemma exits_single:
  "exits [x] = isuccs x 0 - {0}"
  by (auto simp: exits_def succs_def)

lemma exits_Cons:
  "exits (x # xs) = (isuccs x 0 - {0}) \<union> ((+) 1) ` exits xs -
                     {0..<1 + size xs}"
  using exits_append [of "[x]" xs]
  by (simp add: exits_single)

lemma exits_empty [iff]: "exits [] = {}" by (simp add: exits_def)

lemma exits_simps [simp]:
  "exits [ADD] = {1}"
  "exits [LOADI v] = {1}"
  "exits [LOAD x] = {1}"
  "exits [STORE x] = {1}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMP i] = {1 + i}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMPGE i] = {1 + i, 1}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMPLESS i] = {1 + i, 1}"
  by (auto simp: exits_def)

lemma acomp_succs [simp]:
  "succs (acomp m a) n = {n + 1 .. n + size (acomp m a)}"
  by (induct a arbitrary: n) auto

lemma acomp_size:
  "(1::int) \<le> size (acomp m a)"
  by (induct a) auto

(* consequence of acomp_succs *)
lemma acomp_exits [simp]:
  "exits (acomp m a) = {size (acomp m a)}"
  using [[simp_trace]]
  by (auto simp: exits_def acomp_size)

(* successors of bcomp bounded above by bcomp instructions themselves (plus one),
  and the jumped-to address *)
lemma bcomp_succs: "0 \<le> i \<Longrightarrow>
  succs (bcomp m b f i) n \<subseteq> {n..n + size (bcomp m b f i)} \<union> {n + i + size (bcomp m b f i)}"
proof (induct b arbitrary: f i n)
  case (And b1 b2)
  from And(3)
  \<comment> \<open>subsetD converts a subset conclusion into a membership in subset if in superset conclusion\<close>
  \<comment> \<open>rotated rotates the order of the premises\<close>
  show ?case
    by (cases f)
       (auto dest: And(1) [THEN subsetD, rotated]
                   And(2) [THEN subsetD, rotated])
qed auto

lemmas bcomp_succsD [dest!] = bcomp_succs [THEN subsetD, rotated]

lemma bcomp_exits:
  "0 \<le> i \<Longrightarrow>
  exits (bcomp m b f i) \<subseteq> {size (bcomp m b f i), i + size (bcomp m b f i)}"
  by (auto simp: exits_def)

lemma bcomp_exitsD [dest!]:
  "p \<in> exits (bcomp m b f i) \<Longrightarrow> 0 \<le> i \<Longrightarrow>
  p = size (bcomp m b f i) \<or> p = i + size (bcomp m b f i)"
  using bcomp_exits by fastforce

lemma ccomp_succs:
  "succs (ccomp m c) n \<subseteq> {n..n + size (ccomp m c)}"
proof (induct c arbitrary: n)
  case SKIP thus ?case by simp
next
  case Assign thus ?case by simp
next
  case (Seq c1 c2)
  show ?case
    by (fastforce dest: Seq [THEN subsetD])
next
  case (If b c1 c2)
  show ?case
    by (auto dest!: If [THEN subsetD] simp: isuccs_def succs_Cons)
next
  case (While b c)
  show ?case by (auto dest!: While [THEN subsetD])
qed

lemma ccomp_exits:
  "exits (ccomp m c) \<subseteq> {size (ccomp m c)}"
  using ccomp_succs [of m c 0] by (auto simp: exits_def)

lemma ccomp_exitsD [dest!]:
  "p \<in> exits (ccomp m c) \<Longrightarrow> p = size (ccomp m c)"
  using ccomp_exits by auto

subsection \<open>Splitting up machine executions\<close>

lemma exec1_split:
  "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow> (j,s') \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size c \<Longrightarrow>
  c \<turnstile> (i,s) \<rightarrow> (j - size P, s')"
proof -
  assume assm: "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow> (j, s')" "0 \<le> i" "i < size c"
  from assm(1) have "(\<exists>ii ss stk. (size P + i, s) = (ii, ss, stk) \<and>
    (j, s') = iexec ((P @ c @ P') !! ii) (ii, ss, stk) \<and>
    0 \<le> ii \<and> ii < size (P @ c @ P'))"
    using exec1_def by simp
  then obtain ii ss stk where assm1: "(size P + i, s) = (ii, ss, stk)"
    "(j, s') = iexec ((P @ c @ P') !! ii) (ii, ss, stk)"
    "0 \<le> ii" "ii < size (P @ c @ P')" by auto
  from assm1(1) assm(2, 3) have "(P @ c @ P') !! ii = c !! i" by auto
  with assm1(2) have "(j, s') = iexec (c !! i) (ii, ss, stk)" by simp
  with assm1(1) have "(j, s') = iexec (c !! i) (size P + i, ss, stk)" by simp
  then have "((- size P) + j, s') = iexec (c !! i) ((- size P) + (size P + i), ss, stk)"
    using iexec_shift by fastforce
  then have "(j - size P, s') = iexec (c !! i) (i, ss, stk)" by simp
  with assm(2, 3) assm1(1) show "c \<turnstile> (i, s) \<rightarrow> (j - size P, s')" by auto
qed

lemma exec_n_split:
  fixes i j :: int
  assumes "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow>^n (j, s')"
          "0 \<le> i" "i < size c"
          "j \<notin> {size P ..< size P + size c}"
  shows "\<exists>s'' (i'::int) k m.
                   c \<turnstile> (i, s) \<rightarrow>^k (i', s'') \<and>
                   i' \<in> exits c \<and>
                   P @ c @ P' \<turnstile> (size P + i', s'') \<rightarrow>^m (j, s') \<and>
                   n = k + m"
using assms proof (induction n arbitrary: i j s)
  case 0
  thus ?case by simp
next
  case (Suc n)
  have i: "0 \<le> i" "i < size c" by fact+
  from Suc.prems
  have j: "\<not> (size P \<le> j \<and> j < size P + size c)" by simp
  from Suc.prems
  obtain i0 s0 where
    step: "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow> (i0,s0)" and
    rest: "P @ c @ P' \<turnstile> (i0,s0) \<rightarrow>^n (j, s')"
    by clarsimp

  from step i
  have c: "c \<turnstile> (i,s) \<rightarrow> (i0 - size P, s0)" by (rule exec1_split)

  have "i0 = size P + (i0 - size P) " by simp
  then obtain j0::int where j0: "i0 = size P + j0"  ..

  note split_paired_Ex [simp del]

  have ?case if assm: "j0 \<in> {0 ..< size c}"
  proof -
    from assm j0 j rest c show ?case
      by (fastforce dest!: Suc.IH intro!: exec_Suc)
  qed
  moreover
  have ?case if assm: "j0 \<notin> {0 ..< size c}"
  proof -
    from c j0 have "j0 \<in> succs c 0"
      by (auto dest: succs_iexec1 simp: exec1_def simp del: iexec.simps)
    with assm have "j0 \<in> exits c" by (simp add: exits_def)
    with c j0 rest show ?case by fastforce
  qed
  ultimately
  show ?case by cases
qed

lemma exec_n_drop_right:
  assumes "c @ P' \<turnstile> (0, s) \<rightarrow>^n (j, s')" "j \<notin> {0..<size c}"
  shows "\<exists>s'' i' k m.
          (if c = [] then s'' = s \<and> i' = 0 \<and> k = 0
           else c \<turnstile> (0, s) \<rightarrow>^k (i', s'') \<and>
           i' \<in> exits c) \<and>
           c @ P' \<turnstile> (i', s'') \<rightarrow>^m (j, s') \<and>
           n = k + m"
  using assms
  by (cases "c = []")
     (auto dest: exec_n_split [where P="[]", simplified])

text \<open>
  Dropping the left context of a potentially incomplete execution of \<^term>\<open>c\<close>.
\<close>

lemma exec1_drop_left:
  assumes "P1 @ P2 \<turnstile> (i, s, stk) \<rightarrow> (n, s', stk')" "size P1 \<le> i"
  shows "P2 \<turnstile> (i - size P1, s, stk) \<rightarrow> (n - size P1, s', stk')"
proof -
  have "i = size P1 + (i - size P1)" by simp
  then obtain i' :: int where "i = size P1 + i'" ..
  moreover
  have "n = size P1 + (n - size P1)" by simp
  then obtain n' :: int where "n = size P1 + n'" ..
  ultimately
  show ?thesis using assms
    by (clarsimp simp: exec1_def simp del: iexec.simps)
qed

lemma exec_n_drop_left:
  assumes "P @ P' \<turnstile> (i, s, stk) \<rightarrow>^k (n, s', stk')"
          "size P \<le> i" "exits P' \<subseteq> {0..}"
  shows "P' \<turnstile> (i - size P, s, stk) \<rightarrow>^k (n - size P, s', stk')"
using assms proof (induction k arbitrary: i s stk)
  case 0 thus ?case by simp
next
  case (Suc k)
  from Suc.prems
  obtain i' s'' stk'' where
    step: "P @ P' \<turnstile> (i, s, stk) \<rightarrow> (i', s'', stk'')" and
    rest: "P @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^k (n, s', stk')"
    by auto
  from step \<open>size P \<le> i\<close>
  have *: "P' \<turnstile> (i - size P, s, stk) \<rightarrow> (i' - size P, s'', stk'')"
    by (rule exec1_drop_left)
  then have "i' - size P \<in> succs P' 0"
    by (fastforce dest!: succs_iexec1 simp: exec1_def simp del: iexec.simps)
  with \<open>exits P' \<subseteq> {0..}\<close>
  have "size P \<le> i'" by (auto simp: exits_def)
  from rest this \<open>exits P' \<subseteq> {0..}\<close>
  have "P' \<turnstile> (i' - size P, s'', stk'') \<rightarrow>^k (n - size P, s', stk')"
    by (rule Suc.IH)
  with * show ?case by auto
qed

lemmas exec_n_drop_Cons =
  exec_n_drop_left [where P="[instr]", simplified] for instr

definition
  "closed P \<longleftrightarrow> exits P \<subseteq> {size P}"

lemma ccomp_closed [simp, intro!]: "closed (ccomp m c)"
  using ccomp_exits by (auto simp: closed_def)

lemma acomp_closed [simp, intro!]: "closed (acomp m c)"
  by (simp add: closed_def)

text \<open>An execution of P @ P', where P is closed starting from start of P must pass through
a state where the pc is at the start of P'\<close>
lemma exec_n_split_full:
  assumes exec: "P @ P' \<turnstile> (0,s,stk) \<rightarrow>^k (j, s', stk')"
  assumes P: "size P \<le> j"
  assumes closed: "closed P"
  assumes exits: "exits P' \<subseteq> {0..}"
  shows "\<exists>k1 k2 s'' stk''. P \<turnstile> (0,s,stk) \<rightarrow>^k1 (size P, s'', stk'') \<and>
                           P' \<turnstile> (0,s'',stk'') \<rightarrow>^k2 (j - size P, s', stk')"
proof (cases "P")
  case Nil with exec
  show ?thesis by fastforce
next
  case Cons
  hence "0 < size P" by simp
  with exec P closed
  obtain k1 k2 s'' stk'' where
    1: "P \<turnstile> (0,s,stk) \<rightarrow>^k1 (size P, s'', stk'')" and
    2: "P @ P' \<turnstile> (size P,s'',stk'') \<rightarrow>^k2 (j, s', stk')"
    by (auto dest!: exec_n_split [where P="[]" and i=0, simplified]
             simp: closed_def)
  moreover
  have "j = size P + (j - size P)" by simp
  then obtain j0 :: int where "j = size P + j0" ..
  ultimately
  show ?thesis using exits
    by (fastforce dest: exec_n_drop_left)
qed

subsection \<open>Correctness theorem\<close>

lemma acomp_neq_Nil [simp]:
  "acomp m a \<noteq> []"
  by (induct a) auto

lemma acomp_exec_n [dest!]:
  "acomp m a \<turnstile> (0, s, stk) \<rightarrow>^n (size (acomp m a), s', stk') \<Longrightarrow>
  s' = s \<and> stk' = aval a (s \<circ> m) # stk"
proof (induction a arbitrary: n s' stk stk')
  case (Plus a1 a2)
  let ?sz = "size (acomp m a1) + (size (acomp m a2) + 1)"
  from Plus.prems
  have "acomp m a1 @ acomp m a2 @ [ADD] \<turnstile> (0, s, stk) \<rightarrow>^n (?sz, s', stk')"
    by (simp add: algebra_simps)
  then obtain n1 s1 stk1 n2 s2 stk2 n3 where
    "acomp m a1 \<turnstile> (0, s, stk) \<rightarrow>^n1 (size (acomp m a1), s1, stk1)"
    "acomp m a2 \<turnstile> (0, s1, stk1) \<rightarrow>^n2 (size (acomp m a2), s2, stk2)"
       "[ADD] \<turnstile> (0,s2,stk2) \<rightarrow>^n3 (1, s', stk')"
    by (auto dest!: exec_n_split_full)
  thus ?case by (fastforce dest: Plus.IH simp: exec_n_simps exec1_def)
qed (auto simp: exec_n_simps exec1_def)

text \<open>Execution of a bcomp @ P' to outside the bcomp, where the bcomp jump is forward
must pass through a state where the pc is at start of P', or at the jumped-to address\<close>
lemma bcomp_split:
  assumes "bcomp mp b f i @ P' \<turnstile> (0, s, stk) \<rightarrow>^n (j, s', stk')"
          "j \<notin> {0..<size (bcomp mp b f i)}" "0 \<le> i"
  shows "\<exists>s'' stk'' (i'::int) k m.
           bcomp mp b f i \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'') \<and>
           (i' = size (bcomp mp b f i) \<or> i' = i + size (bcomp mp b f i)) \<and>
           bcomp mp b f i @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^m (j, s', stk') \<and>
           n = k + m"
  using assms by (cases "bcomp mp b f i = []") (fastforce dest!: exec_n_drop_right)+

text \<open>Execution of a bcomp to outside the bcomp, where the jump is forward
must end in a state where the pc is at the start of P', or at the jumped-to address\<close>
lemma bcomp_exec_n [dest]:
  fixes i j :: int
  assumes "bcomp m b f j \<turnstile> (0, s, stk) \<rightarrow>^n (i, s', stk')"
          "size (bcomp m b f j) \<le> i" "0 \<le> j"
  shows "i = size (bcomp m b f j) + (if f = bval b (s \<circ> m) then j else 0) \<and>
         s' = s \<and> stk' = stk"
using assms proof (induct b arbitrary: f j i n s' stk')
  case Bc thus ?case
    by (simp split: if_split_asm add: exec_n_simps exec1_def)
next
  case (Not b)
  from Not(2-4) show ?case
    by (fastforce dest!: Not(1))
next
  case (And b1 b2)

  let ?cb2 = "bcomp m b2 f j"
  let ?n  = "if f then size ?cb2 else size ?cb2 + j"
  let ?cb1 = "bcomp m b1 False ?n"
  let ?cbAnd = "bcomp m (And b1 b2) f j"

  from And(3-5) obtain s'' stk'' i' k k' where
    Hb1: "?cb1 \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'')"
        "i' = size ?cb1 \<or> i' = ?n + size ?cb1" and
    Hb2: "?cb1 @ ?cb2 \<turnstile> (i', s'', stk'') \<rightarrow>^k' (i, s', stk')"
    "n = k + k'"
    by (auto dest!: bcomp_split dest: exec_n_drop_left)
  from Hb2 Hb1(2) And(5) (*ccomp_closed, automatically used*)
  have Hb2': "?cb2 \<turnstile> (i' - size ?cb1, s'', stk'') \<rightarrow>^k' (i - size ?cb1, s', stk')"
    by (auto dest: exec_n_drop_left)
  from Hb1(1, 2) And(1, 5)
  have HCb1: "i' = size ?cb1 + (if \<not>bval b1 (s \<circ> m) then ?n else 0)"
    "s'' = s" "stk'' = stk" by fastforce+
  show ?case
  proof (cases "bval b1 (s \<circ> m)")
    case True
    with HCb1 have "i' = size ?cb1" by simp
    with And(2, 4, 5) Hb2' HCb1(2,3) have HCb2: "i - size ?cb1 = size (bcomp m b2 f j) + (if f = bval b2 (s \<circ> m) then j else 0)"
      "s' = s" "stk' = stk"
      by fastforce+
    from HCb2(1) have "i = size ?cbAnd + (if f = bval b2 (s \<circ> m) then j else 0)" by auto
    with True HCb2(2, 3) bval.simps(3) show ?thesis by presburger
  next
    case False
    with HCb1 have "i' - size ?cb1 = ?n" by simp
    moreover from And(5) have "size ?cb2 \<le> ?n" by simp
    ultimately have HCb2: "i = i'" "stk' = stk''" "s' = s''" "k' = 0" using And(5) Hb2' exec_n_end by fastforce+
    from HCb2(1) HCb1(1) False have "i = size (bcomp m (And b1 b2) f j) + (if f = bval (And b1 b2) (s \<circ> m) then j else 0)" by simp
    with HCb1(2, 3) HCb2(2, 3) show ?thesis by blast
  qed
next
  case (Less x1a x2a)
  thm exec_n_split_full
  thm exec1_def
  let ?ca1 = "acomp m x1a" and ?ca2 = "acomp m x2a" and ?jmp = "(if f then [JMPLESS j] else [JMPGE j])"
  let ?cbLess = "bcomp m (Less x1a x2a) f j"
  from Less(3) have Hexits23: "exits (?ca2 @ ?jmp) \<subseteq> {0..}" by auto
  from exec_n_split_full [OF _ _ _ Hexits23] Less(1, 2) have "\<exists>k1 k23 s'' stk''.
    ?ca1 \<turnstile> (0, s, stk) \<rightarrow>^k1 (size ?ca1, s'', stk'') \<and>
    ?ca2 @ ?jmp \<turnstile> (0, s'', stk'') \<rightarrow>^k23 (i - size ?ca1, s', stk')"
    by auto
  then obtain k1 k23 s'' stk'' where He1: "?ca1 \<turnstile> (0, s, stk) \<rightarrow>^k1 (size ?ca1, s'', stk'')"
    and He2: "?ca2 @ ?jmp \<turnstile> (0, s'', stk'') \<rightarrow>^k23 (i - size ?ca1, s', stk')"
    by meson
  from He1 have "s'' = s" "stk'' = aval x1a (s \<circ> m) # stk" by auto
  with He2 have He2': "?ca2 @ ?jmp \<turnstile> (0, s, aval x1a (s \<circ> m) # stk) \<rightarrow>^k23 (i - size ?ca1, s', stk')" by simp
  from exec_n_split_full He2' Less(2, 3) have "\<exists>k2 k3 s''' stk'''.
    ?ca2 \<turnstile> (0, s, aval x1a (s \<circ> m) # stk) \<rightarrow>^k2 (size ?ca2, s''', stk''') \<and>
    ?jmp \<turnstile> (0, s''', stk''') \<rightarrow>^k3 (i - size ?ca1 - size ?ca2, s', stk')" by auto
  then obtain k2 k3 s''' stk''' where He2: "?ca2 \<turnstile> (0, s, aval x1a (s \<circ> m) # stk) \<rightarrow>^k2 (size ?ca2, s''', stk''')"
    and He3: "?jmp \<turnstile> (0, s''', stk''') \<rightarrow>^k3 (i - size ?ca1 - size ?ca2, s', stk')" by meson
  from He2 have "s''' = s" "stk''' = aval x2a (s \<circ> m) # aval x1a (s \<circ> m) # stk" by auto
  with He3 have He3': "?jmp \<turnstile> (0, s, aval x2a (s \<circ> m) # aval x1a (s \<circ> m) # stk) \<rightarrow>^k3 (i - size ?ca1 - size ?ca2, s', stk')" by simp
  from exec_n_simps(1) He3' Less(2) have "\<exists>c. ?jmp \<turnstile> (0, s, aval x2a (s \<circ> m) # aval x1a (s \<circ> m) # stk) \<rightarrow> c \<and> ?jmp \<turnstile> c \<rightarrow>^(k3 - 1) (i - size ?ca1 - size ?ca2, s', stk') \<and> 0 < k3"
    by auto
  then obtain c where He3'': "?jmp \<turnstile> (0, s, aval x2a (s \<circ> m) # aval x1a (s \<circ> m) # stk) \<rightarrow> c" and He4: "?jmp \<turnstile> c \<rightarrow>^(k3 - 1) (i - size ?ca1 - size ?ca2, s', stk')" and "0 < k3" by auto
  let ?jpc = "if f \<longleftrightarrow> aval x1a (s \<circ> m) < aval x2a (s \<circ> m) then (1 + j) else 1"
  from He3'' have "c = iexec (?jmp !! 0) (0, s, aval x2a (s \<circ> m) # aval x1a (s \<circ> m) # stk)" by auto
  then have "c = (?jpc, s, stk)" by simp
  with He4 have He4': "?jmp \<turnstile> (?jpc, s, stk) \<rightarrow>^(k3 - 1) (i - size ?ca1 - size ?ca2, s', stk')" by simp
  with exec_n_simps(2) Less(3) have HC: "i - size ?ca1 - size ?ca2 = (if f \<longleftrightarrow> aval x1a (s \<circ> m) < aval x2a (s \<circ> m) then (1 + j) else 1)"
    "s' = s" "stk' = stk" "k3 - 1 = 0" by auto
  from HC(1) have "i = size ?cbLess + (if f = bval (Less x1a x2a) (s \<circ> m) then j else 0)" by auto
  with HC(2, 3) show ?case by blast
qed

lemma ccomp_empty [elim!]:
  "ccomp m c = [] \<Longrightarrow> (c,s) \<Rightarrow> s"
  by (induct c) auto

declare assign_simp [simp]

lemma ccomp_exec_n:
  "ccomp m c \<turnstile> (0, s, stk) \<rightarrow>^n (size (ccomp m c), t, stk')
  \<Longrightarrow> inj_on m (svars_in c)
  \<Longrightarrow> (c, s \<circ> m) \<Rightarrow> (t \<circ> m) \<and> stk' = stk"
proof (induction c arbitrary: s t stk stk' n)
  case SKIP
  thus ?case by auto
next
  case (Assign x a)
  value "ccomp m (x ::= a)"
  thus ?case
    by simp (fastforce dest!: exec_n_split_full simp: exec_n_simps exec1_def)
next
  case (Seq c1 c2)
  thus ?case by (fastforce dest!: exec_n_split_full)
next
  case (If b c1 c2)
  note If.IH [dest!]

  let ?if = "IF b THEN c1 ELSE c2"
  let ?cs = "ccomp ?if"
  let ?bcomp = "bcomp b False (size (ccomp c1) + 1)"

  from \<open>?cs \<turnstile> (0,s,stk) \<rightarrow>^n (size ?cs,t,stk')\<close>
  obtain i' :: int and k m s'' stk'' where
    cs: "?cs \<turnstile> (i',s'',stk'') \<rightarrow>^m (size ?cs,t,stk')" and
        "?bcomp \<turnstile> (0,s,stk) \<rightarrow>^k (i', s'', stk'')"
        "i' = size ?bcomp \<or> i' = size ?bcomp + size (ccomp c1) + 1"
    by (auto dest!: bcomp_split)

  hence i':
    "s''=s" "stk'' = stk"
    "i' = (if bval b s then size ?bcomp else size ?bcomp+size(ccomp c1)+1)"
    by auto

  with cs have cs':
    "ccomp c1@JMP (size (ccomp c2))#ccomp c2 \<turnstile>
       (if bval b s then 0 else size (ccomp c1)+1, s, stk) \<rightarrow>^m
       (1 + size (ccomp c1) + size (ccomp c2), t, stk')"
    by (fastforce dest: exec_n_drop_left simp: exits_Cons isuccs_def algebra_simps)

  show ?case
  proof (cases "bval b s")
    case True with cs'
    show ?thesis
      by simp
         (fastforce dest: exec_n_drop_right
                   split: if_split_asm
                   simp: exec_n_simps exec1_def)
  next
    case False with cs'
    show ?thesis
      by (auto dest!: exec_n_drop_Cons exec_n_drop_left
               simp: exits_Cons isuccs_def)
  qed
next
  case (While b c)

  from While.prems
  show ?case
  proof (induction n arbitrary: s rule: nat_less_induct)
    case (1 n)

    have ?case if assm: "\<not> bval b s"
    proof -
      from assm "1.prems"
      show ?case
        by simp (fastforce dest!: bcomp_split simp: exec_n_simps)
    qed
    moreover
    have ?case if b: "bval b s"
    proof -
      let ?c0 = "WHILE b DO c"
      let ?cs = "ccomp ?c0"
      let ?bs = "bcomp b False (size (ccomp c) + 1)"
      let ?jmp = "[JMP (-((size ?bs + size (ccomp c) + 1)))]"

      from "1.prems" b
      obtain k where
        cs: "?cs \<turnstile> (size ?bs, s, stk) \<rightarrow>^k (size ?cs, t, stk')" and
        k:  "k \<le> n"
        by (fastforce dest!: bcomp_split)

      show ?case
      proof cases
        assume "ccomp c = []"
        with cs k
        obtain m where
          "?cs \<turnstile> (0,s,stk) \<rightarrow>^m (size (ccomp ?c0), t, stk')"
          "m < n"
          by (auto simp: exec_n_step [where k=k] exec1_def)
        with "1.IH"
        show ?case by blast
      next
        assume "ccomp c \<noteq> []"
        with cs
        obtain m m' s'' stk'' where
          c: "ccomp c \<turnstile> (0, s, stk) \<rightarrow>^m' (size (ccomp c), s'', stk'')" and
          rest: "?cs \<turnstile> (size ?bs + size (ccomp c), s'', stk'') \<rightarrow>^m
                       (size ?cs, t, stk')" and
          m: "k = m + m'"
          by (auto dest: exec_n_split [where i=0, simplified])
        from c
        have "(c,s) \<Rightarrow> s''" and stk: "stk'' = stk"
          by (auto dest!: While.IH)
        moreover
        from rest m k stk
        obtain k' where
          "?cs \<turnstile> (0, s'', stk) \<rightarrow>^k' (size ?cs, t, stk')"
          "k' < n"
          by (auto simp: exec_n_step [where k=m] exec1_def)
        with "1.IH"
        have "(?c0, s'') \<Rightarrow> t \<and> stk' = stk" by blast
        ultimately
        show ?case using b by blast
      qed
    qed
    ultimately show ?case by cases
  qed
qed

theorem ccomp_exec:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk') \<Longrightarrow> (c,s) \<Rightarrow> t"
  by (auto dest: exec_exec_n ccomp_exec_n)

corollary ccomp_sound:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)  \<longleftrightarrow>  (c,s) \<Rightarrow> t"
  by (blast intro!: ccomp_exec ccomp_bigstep)

end
*)


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005  (modified)   |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_continuous
imports CSP_T_traces Domain_T_cpo CSP.CPO_prod
begin

(*****************************************************************

         1. continuous traces
         2. continuous [[ ]]Tfun

 *****************************************************************)

(*--------------------------------*
 |        STOP,SKIP,DIV           |
 *--------------------------------*)

(*** Constant_continuous ***)

lemma continuous_Constant: "continuous (%p. C)"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (insert complete_cpo_lm)
apply (drule_tac x="X" in spec, simp)
apply (simp add: hasLUB_def)
apply (elim exE)
apply (simp add: image_def isLUB_def isUB_def)
apply (intro allI impI)
apply (elim conjE exE)
apply (drule mp)
apply (simp add: directed_def)
apply (auto)
done

lemma continuous_traces_STOP: "continuous (traces (STOP))"
by (simp add: traces_iff continuous_Constant)

lemma continuous_traces_SKIP: "continuous (traces (SKIP))"
by (simp add: traces_iff continuous_Constant)

lemma continuous_traces_DIV: "continuous (traces (DIV))"
by (simp add: traces_iff continuous_Constant)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

lemma continuous_traces_Act_prefix:
 "continuous (traces P) ==> continuous (traces (a -> P))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
apply (rule)
apply (simp add: in_traces)
apply (erule disjE, fast)
apply (elim conjE exE)
apply (simp)

(* => *)
apply (rule)
apply (simp)
apply (erule bexE)
apply (simp add: in_traces)
apply (erule disjE, simp)
apply (elim conjE exE)
apply (rule disjI2)
apply (rule_tac x="s" in exI, simp)
apply (rule_tac x="xa" in bexI)
apply (simp_all)

by (simp add: directed_def)

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

lemma continuous_traces_Ext_pre_choice:
 "ALL a. continuous (traces (Pf a))
  ==> continuous (traces (? a:X -> (Pf a)))"
apply (simp add: continuous_iff)
apply (intro allI impI)

apply (subgoal_tac "Xa ~= {}")
apply (erule exchange_forall_orderE)
apply (drule_tac x="Xa" in spec)
apply (simp add: isLUB_UnionT)

apply (rule_tac x="LUB Xa" in exI)
apply (rule conjI)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (erule disjE, fast)
 apply (elim conjE exE)
 apply (simp)
 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB Xa = x", simp)
 apply (simp add: isLUB_LUB)

(* => *)
 apply (rule)
 apply (simp)
 apply (erule bexE)
 apply (simp add: in_traces)
 apply (erule disjE, simp)
 apply (elim conjE exE)
 apply (rule disjI2)
 apply (rule_tac x="a" in exI)
 apply (rule_tac x="s" in exI, simp)

 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB Xa = xa", simp)
 apply (rule_tac x="x" in bexI)
 apply (simp)
 apply (simp)
 apply (simp add: isLUB_LUB)

 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (simp add: isLUB_LUB)

by (simp add: directed_def)

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

lemma continuous_traces_Ext_choice:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P [+] Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces, fast)
 apply (rule, simp add: in_traces, fast)
apply (simp add: directed_def)
by (rule LUB_unique, simp_all)

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

lemma continuous_traces_Int_choice:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P |~| Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces, fast)
 apply (rule, simp add: in_traces, fast)
apply (simp add: directed_def)
by (rule LUB_unique, simp_all)

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

lemma continuous_traces_Rep_int_choice:
 "ALL c. continuous (traces(Pf c))
  ==> continuous (traces (!! :C .. Pf))"
apply (simp add: continuous_iff)
apply (intro allI impI)

apply (subgoal_tac "X ~= {}")
apply (erule exchange_forall_orderE)
apply (drule_tac x="X" in spec)
apply (simp add: isLUB_UnionT)

apply (rule_tac x="LUB X" in exI)
apply (rule conjI)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (erule disjE, fast)
 apply (elim conjE bexE)
 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB X = x", simp)
 apply (elim bexE)
 apply (rule_tac x="xa" in bexI)
 apply (fast)
 apply (simp)
 apply (simp add: isLUB_LUB)

(* => *)
 apply (rule)
 apply (simp)
 apply (erule bexE)
 apply (simp add: in_traces)
 apply (erule disjE, simp)
 apply (elim conjE bexE)
 apply (rule disjI2)
 apply (rule_tac x="c" in bexI)

 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB X = xa", simp)
 apply (rule_tac x="x" in bexI)
 apply (simp)
 apply (simp)
 apply (simp add: isLUB_LUB)
 apply (simp)

 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (simp add: isLUB_LUB)

by (simp add: directed_def)

(*--------------------------------*
 |                IF              |
 *--------------------------------*)

lemma continuous_traces_IF:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (IF b THEN P ELSE Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)
apply (case_tac "b")
 apply (rule_tac x="x" in exI, simp)
 apply (simp add: traces_iff)
 apply (rule_tac x="xa" in exI, simp)
 apply (simp add: traces_iff)
done

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

lemma continuous_traces_Parallel:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P |[X]| Q))"
apply (subgoal_tac "mono (traces P) & mono (traces Q)")

apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="Xa" in spec, simp)
apply (drule_tac x="Xa" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "Xa ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim exE bexE conjE)

 apply (simp add: directed_def)
 apply (drule_tac x="xb" in spec)
 apply (drule_tac x="xc" in spec)
 apply (simp, elim conjE exE)
 apply (rule_tac x="z" in bexI)
 apply (rule_tac x="s" in exI)
 apply (rule_tac x="ta" in exI)
 apply (simp)
 apply (rule conjI)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (rotate_tac -4)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

apply (simp add: directed_def)
apply (simp add: LUB_unique)

by (simp add: continuous_mono)

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

lemma continuous_traces_Hiding:
 "continuous (traces P)
  ==> continuous (traces (P -- X))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="Xa" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "Xa ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

by (simp add: directed_def)

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

lemma continuous_traces_Renaming:
 "continuous (traces P)
  ==> continuous (traces (P [[r]]))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces, fast)
 apply (rule, simp add: in_traces, fast)
by (simp add: directed_def)

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

lemma continuous_traces_Seq_compo:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P ;; Q))"
apply (subgoal_tac "mono (traces P) & mono (traces Q)")
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim bexE exE conjE disjE)
 apply (rule_tac x="xb" in bexI)
 apply (fast)
 apply (simp)

 apply (simp add: directed_def)
 apply (drule_tac x="xb" in spec)
 apply (drule_tac x="xc" in spec)
 apply (simp, elim conjE exE)
 apply (rule_tac x="z" in bexI)
 apply (rule disjI2)
 apply (rule_tac x="s" in exI)
 apply (rule_tac x="ta" in exI)
 apply (simp)
 apply (rule conjI)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (rotate_tac -4)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

apply (simp add: directed_def)
apply (simp add: LUB_unique)

by (simp add: continuous_mono)

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

lemma continuous_traces_Depth_rest:
 "continuous (traces P)
  ==> continuous (traces (P |. n))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces)
 apply (rule, simp add: in_traces)
by (simp add: directed_def)

(*--------------------------------*
 |            variable            |
 *--------------------------------*)

lemma continuous_traces_variable:
   "continuous (traces ($p))"
apply (simp add: traces_iff)
apply (simp add: continuous_prod_variable)
done

(*--------------------------------*
 |            Procfun             |
 *--------------------------------*)

lemma continuous_traces:
  "continuous (traces P)"
apply (induct_tac P)
apply (simp add: continuous_traces_STOP)
apply (simp add: continuous_traces_SKIP)
apply (simp add: continuous_traces_DIV)
apply (simp add: continuous_traces_Act_prefix)
apply (simp add: continuous_traces_Ext_pre_choice)
apply (simp add: continuous_traces_Ext_choice)
apply (simp add: continuous_traces_Int_choice)
apply (simp add: continuous_traces_Rep_int_choice)
apply (simp add: continuous_traces_IF)
apply (simp add: continuous_traces_Parallel)
apply (simp add: continuous_traces_Hiding)
apply (simp add: continuous_traces_Renaming)
apply (simp add: continuous_traces_Seq_compo)
apply (simp add: continuous_traces_Depth_rest)
apply (simp add: continuous_traces_variable)
done

(*=============================================================*
 |                          [[P]]Tf                            |
 *=============================================================*)

lemma continuous_semTf:
  "continuous [[P]]Tf"
apply (simp add: semTf_def)
apply (simp add: continuous_traces)
done

(*=============================================================*
 |                         [[P]]Tfun                           |
 *=============================================================*)

lemma continuous_semTfun: "continuous [[Pf]]Tfun"
apply (simp add: prod_continuous)
apply (simp add: semTfun_def)
apply (simp add: proj_fun_def)
apply (simp add: comp_def)
apply (simp add: continuous_semTf)
done

end


(*  Title:      HOL/UNITY/Comp/Client.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section{*Distributed Resource Management System: the Client*}

theory Client imports "../Rename" AllocBase begin

type_synonym
  tokbag = nat     --{*tokbags could be multisets...or any ordered type?*}

record state =
  giv :: "tokbag list" --{*input history: tokens granted*}
  ask :: "tokbag list" --{*output history: tokens requested*}
  rel :: "tokbag list" --{*output history: tokens released*}
  tok :: tokbag        --{*current token request*}

record 'a state_d =
  state +
  dummy :: 'a          --{*new variables*}

(*Array indexing is translated to list indexing as A[n] == A!(n-1). *)

  (** Release some tokens **)

definition
  rel_act :: "('a state_d * 'a state_d) set"
  where "rel_act = {(s,s').
                  \<exists>nrel. nrel = size (rel s) &
                         s' = s (| rel := rel s @ [giv s!nrel] |) &
                         nrel < size (giv s) &
                         ask s!nrel \<le> giv s!nrel}"

  (** Choose a new token requirement **)

  (** Including s'=s suppresses fairness, allowing the non-trivial part
      of the action to be ignored **)

definition
  tok_act :: "('a state_d * 'a state_d) set"
  where "tok_act = {(s,s'). s'=s | s' = s (|tok := Suc (tok s mod NbT) |)}"

definition
  ask_act :: "('a state_d * 'a state_d) set"
  where "ask_act = {(s,s'). s'=s |
                         (s' = s (|ask := ask s @ [tok s]|))}"

definition
  Client :: "'a state_d program"
  where "Client =
       mk_total_program
            ({s. tok s \<in> atMost NbT &
                 giv s = [] & ask s = [] & rel s = []},
             {rel_act, tok_act, ask_act},
             \<Union>G \<in> preserves rel Int preserves ask Int preserves tok.
                   Acts G)"

definition
  (*Maybe want a special theory section to declare such maps*)
  non_dummy :: "'a state_d => state"
  where "non_dummy s = (|giv = giv s, ask = ask s, rel = rel s, tok = tok s|)"

definition
  (*Renaming map to put a Client into the standard form*)
  client_map :: "'a state_d => state*'a"
  where "client_map = funPair non_dummy dummy"

declare Client_def [THEN def_prg_Init, simp]
declare Client_def [THEN def_prg_AllowedActs, simp]
declare rel_act_def [THEN def_act_simp, simp]
declare tok_act_def [THEN def_act_simp, simp]
declare ask_act_def [THEN def_act_simp, simp]

lemma Client_ok_iff [iff]:
     "(Client ok G) =
      (G \<in> preserves rel & G \<in> preserves ask & G \<in> preserves tok &
       Client \<in> Allowed G)"
by (auto simp add: ok_iff_Allowed Client_def [THEN def_total_prg_Allowed])

text{*Safety property 1: ask, rel are increasing*}
lemma increasing_ask_rel:
     "Client \<in> UNIV guarantees Increasing ask Int Increasing rel"
apply (auto intro!: increasing_imp_Increasing simp add: guar_def preserves_subset_increasing [THEN subsetD])
apply (auto simp add: Client_def increasing_def)
apply (safety, auto)+
done

declare nth_append [simp] append_one_prefix [simp]

text{*Safety property 2: the client never requests too many tokens.
      With no Substitution Axiom, we must prove the two invariants
      simultaneously. *}
lemma ask_bounded_lemma:
     "Client ok G
      ==> Client Join G \<in>
              Always ({s. tok s \<le> NbT}  Int
                      {s. \<forall>elt \<in> set (ask s). elt \<le> NbT})"
apply auto
apply (rule invariantI [THEN stable_Join_Always2], force)
 prefer 2
 apply (fast elim!: preserves_subset_stable [THEN subsetD] intro!: stable_Int)
apply (simp add: Client_def, safety)
apply (cut_tac m = "tok s" in NbT_pos [THEN mod_less_divisor], auto)
done

text{*export version, with no mention of tok in the postcondition, but
  unfortunately tok must be declared local.*}
lemma ask_bounded:
     "Client \<in> UNIV guarantees Always {s. \<forall>elt \<in> set (ask s). elt \<le> NbT}"
apply (rule guaranteesI)
apply (erule ask_bounded_lemma [THEN Always_weaken])
apply (rule Int_lower2)
done

text{*** Towards proving the liveness property ***}

lemma stable_rel_le_giv: "Client \<in> stable {s. rel s \<le> giv s}"
by (simp add: Client_def, safety, auto)

lemma Join_Stable_rel_le_giv:
     "[| Client Join G \<in> Increasing giv;  G \<in> preserves rel |]
      ==> Client Join G \<in> Stable {s. rel s \<le> giv s}"
by (rule stable_rel_le_giv [THEN Increasing_preserves_Stable], auto)

lemma Join_Always_rel_le_giv:
     "[| Client Join G \<in> Increasing giv;  G \<in> preserves rel |]
      ==> Client Join G \<in> Always {s. rel s \<le> giv s}"
by (force intro: AlwaysI Join_Stable_rel_le_giv)

lemma transient_lemma:
     "Client \<in> transient {s. rel s = k & k<h & h \<le> giv s & h pfixGe ask s}"
apply (simp add: Client_def mk_total_program_def)
apply (rule_tac act = rel_act in totalize_transientI)
  apply (auto simp add: Domain_unfold Client_def)
 apply (blast intro: less_le_trans prefix_length_le strict_prefix_length_less)
apply (auto simp add: prefix_def genPrefix_iff_nth Ge_def)
apply (blast intro: strict_prefix_length_less)
done

lemma induct_lemma:
     "[| Client Join G \<in> Increasing giv;  Client ok G |]
  ==> Client Join G \<in> {s. rel s = k & k<h & h \<le> giv s & h pfixGe ask s}
                      LeadsTo {s. k < rel s & rel s \<le> giv s &
                                  h \<le> giv s & h pfixGe ask s}"
apply (rule single_LeadsTo_I)
apply (frule increasing_ask_rel [THEN guaranteesD], auto)
apply (rule transient_lemma [THEN Join_transient_I1, THEN transient_imp_leadsTo, THEN leadsTo_imp_LeadsTo, THEN PSP_Stable, THEN LeadsTo_weaken])
  apply (rule Stable_Int [THEN Stable_Int, THEN Stable_Int])
     apply (erule_tac f = giv and x = "giv s" in IncreasingD)
    apply (erule_tac f = ask and x = "ask s" in IncreasingD)
   apply (erule_tac f = rel and x = "rel s" in IncreasingD)
  apply (erule Join_Stable_rel_le_giv, blast)
 apply (blast intro: order_less_imp_le order_trans)
apply (blast intro: sym order_less_le [THEN iffD2] order_trans
                    prefix_imp_pfixGe pfixGe_trans)
done

lemma rel_progress_lemma:
     "[| Client Join G \<in> Increasing giv;  Client ok G |]
  ==> Client Join G \<in> {s. rel s < h & h \<le> giv s & h pfixGe ask s}
                      LeadsTo {s. h \<le> rel s}"
apply (rule_tac f = "%s. size h - size (rel s) " in LessThan_induct)
apply (auto simp add: vimage_def)
apply (rule single_LeadsTo_I)
apply (rule induct_lemma [THEN LeadsTo_weaken], auto)
 apply (blast intro: order_less_le [THEN iffD2] dest: common_prefix_linear)
apply (drule strict_prefix_length_less)+
apply arith
done

lemma client_progress_lemma:
     "[| Client Join G \<in> Increasing giv;  Client ok G |]
      ==> Client Join G \<in> {s. h \<le> giv s & h pfixGe ask s}
                          LeadsTo {s. h \<le> rel s}"
apply (rule Join_Always_rel_le_giv [THEN Always_LeadsToI], simp_all)
apply (rule LeadsTo_Un [THEN LeadsTo_weaken_L])
  apply (blast intro: rel_progress_lemma)
 apply (rule subset_refl [THEN subset_imp_LeadsTo])
apply (blast intro: order_less_le [THEN iffD2] dest: common_prefix_linear)
done

text{*Progress property: all tokens that are given will be released*}
lemma client_progress:
     "Client \<in>
       Increasing giv  guarantees
       (INT h. {s. h \<le> giv s & h pfixGe ask s} LeadsTo {s. h \<le> rel s})"
apply (rule guaranteesI, clarify)
apply (blast intro: client_progress_lemma)
done

text{*This shows that the Client won't alter other variables in any state
  that it is combined with*}
lemma client_preserves_dummy: "Client \<in> preserves dummy"
by (simp add: Client_def preserves_def, clarify, safety, auto)

text{** Obsolete lemmas from first version of the Client **}

lemma stable_size_rel_le_giv:
     "Client \<in> stable {s. size (rel s) \<le> size (giv s)}"
by (simp add: Client_def, safety, auto)

text{*clients return the right number of tokens*}
lemma ok_guar_rel_prefix_giv:
     "Client \<in> Increasing giv  guarantees  Always {s. rel s \<le> giv s}"
apply (rule guaranteesI)
apply (rule AlwaysI, force)
apply (blast intro: Increasing_preserves_Stable stable_rel_le_giv)
done

end


(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>Kildall for the JVM \label{sec:JVM}\<close>

theory BVExec
imports "../DFA/Abstract_BV" TF_JVM
begin

definition kiljvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow>
             instr list \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> ty\<^sub>i' err list"
where
  "kiljvm P mxs mxl T\<^sub>r is xt \<equiv>
  kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl)
          (exec P mxs T\<^sub>r xt is)"

definition wt_kildall :: "jvm_prog \<Rightarrow> cname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
                 instr list \<Rightarrow> ex_table \<Rightarrow> bool"
where
  "wt_kildall P C' Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<equiv>
   0 < size is \<and>
   (let first  = Some ([],[OK (Class C')]@(map OK Ts)@(replicate mxl\<^sub>0 Err));
        start  = OK first#(replicate (size is - 1) (OK None));
        result = kiljvm P mxs (1+size Ts+mxl\<^sub>0) T\<^sub>r is xt  start
    in \<forall>n < size is. result!n \<noteq> Err)"

definition wf_jvm_prog\<^sub>k :: "jvm_prog \<Rightarrow> bool"
where
  "wf_jvm_prog\<^sub>k P \<equiv>
  wf_prog (\<lambda>P C' (M,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)). wt_kildall P C' Ts T\<^sub>r mxs mxl\<^sub>0 is xt) P"

theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
(*<*)
proof -
  let ?n = "length is"
  have "Semilat A r f" using semilat_JVM[OF wf]
    by (simp add: Semilat.intro sl_def2)
  moreover have "acc r" using wf by simp blast
  moreover have "top r Err" by (simp add: JVM_le_unfold)
  moreover have "pres_type step ?n A" by (rule exec_pres_type)
  moreover have "bounded step ?n" by (rule bounded_step)
  moreover have "mono r step ?n A" using step_mono[OF wf] by simp
  ultimately have "is_bcv r Err step ?n A (kildall r f step)"
    by(rule is_bcv_kildall)
  moreover have kileq: "kiljvm P mxs mxl T\<^sub>r is xt = kildall r f step"
    using f_def kiljvm_def r_def step_def_exec by blast
  ultimately show ?thesis by simp
qed
(*>*)

(* FIXME: move? *)
lemma subset_replicate [intro?]: "set (replicate n x) \<subseteq> {x}"
  by (induct n) auto

lemma in_set_replicate:
  assumes "x \<in> set (replicate n y)"
  shows "x = y"
(*<*)
proof -
  note assms
  also have "set (replicate n y) \<subseteq> {y}" ..
  finally show ?thesis by simp
qed
(*>*)

lemma (in start_context) start_in_A [intro?]:
  "0 < size is \<Longrightarrow> start \<in> list (size is) A"
  using Ts C
(*<*)
 by (force simp add: JVM_states_unfold intro!: listI list_appendI
           dest!: in_set_replicate)
(*>*)

theorem (in start_context) wt_kil_correct:
  assumes wtk: "wt_kildall P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  shows "\<exists>\<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from wtk obtain res where
    result:   "res = kiljvm P mxs mxl T\<^sub>r is xt start" and
    success:  "\<forall>n < size is. res!n \<noteq> Err" and
    instrs:   "0 < size is"
    by (unfold wt_kildall_def) simp

  have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)

  from instrs have "start \<in> list (size is) A" ..
  with bcv success result have
    "\<exists>ts\<in>list (size is) A. start [\<sqsubseteq>\<^sub>r] ts \<and> wt_step r Err step ts"
    by (unfold is_bcv_def) blast
  then obtain \<tau>s' where
    in_A: "\<tau>s' \<in> list (size is) A" and
    s:    "start [\<sqsubseteq>\<^sub>r] \<tau>s'" and
    w:    "wt_step r Err step \<tau>s'"
    by blast
  hence wt_err_step: "wt_err_step (sup_state_opt P) step \<tau>s'"
    by (simp add: wt_err_step_def JVM_le_Err_conv)

  from in_A have l: "size \<tau>s' = size is" by simp
  moreover {
    from in_A  have "check_types P mxs mxl \<tau>s'" by (simp add: check_types_def)
    also from w have "\<forall>x \<in> set \<tau>s'. x \<noteq> Err"
      by (auto simp add: wt_step_def all_set_conv_all_nth)
    hence [symmetric]: "map OK (map ok_val \<tau>s') = \<tau>s'"
      by (auto intro!: map_idI simp add: wt_step_def)
    finally  have "check_types P mxs mxl (map OK (map ok_val \<tau>s'))" .
  }
  moreover {
    from s have "start!0 \<sqsubseteq>\<^sub>r \<tau>s'!0" by (rule le_listD) simp
    moreover
    from instrs w l
    have "\<tau>s'!0 \<noteq> Err" by (unfold wt_step_def) simp
    then obtain \<tau>s0 where "\<tau>s'!0 = OK \<tau>s0" by auto
    ultimately
    have "wt_start P C Ts mxl\<^sub>0 (map ok_val \<tau>s')" using l instrs
      by (unfold wt_start_def)
         (simp add: lesub_def JVM_le_Err_conv Err.le_def)
  }
  moreover
  from in_A have "set \<tau>s' \<subseteq> A" by simp
  with wt_err_step bounded_step
  have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l)
  ultimately
  have "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s')"
    using instrs by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis by blast
qed
(*>*)

theorem (in start_context) wt_kil_complete:
  assumes wtm: "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  shows "wt_kildall P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
(*<*)
proof -
  from wtm obtain
    instrs:   "0 < size is" and
    length:   "length \<tau>s = length is" and
    ck_type:  "check_types P mxs mxl (map OK \<tau>s)" and
    wt_start: "wt_start P C Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"
    by (simp add: wt_method_def2 check_types_def)

  from ck_type
  have in_A: "set (map OK \<tau>s) \<subseteq> A"
    by (simp add: check_types_def)
  with app_eff in_A bounded_step
  have "wt_err_step (sup_state_opt P) (err_step (size \<tau>s) app eff) (map OK \<tau>s)"
    by - (erule wt_app_eff_imp_wt_err,
          auto simp add: exec_def length states_def)
  hence wt_err: "wt_err_step (sup_state_opt P) step (map OK \<tau>s)"
    by (simp add: length)
  have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)
  moreover from instrs have "start \<in> list (size is) A" ..
  moreover
  let ?\<tau>s = "map OK \<tau>s"
  have less_\<tau>s: "start [\<sqsubseteq>\<^sub>r] ?\<tau>s"
  proof (rule le_listI)
    from length instrs
    show "length start = length (map OK \<tau>s)" by simp
  next
    fix n
    from wt_start have "P \<turnstile> ok_val (start!0) \<le>' \<tau>s!0"
      by (simp add: wt_start_def)
    moreover from instrs length have "0 < length \<tau>s" by simp
    ultimately have "start!0 \<sqsubseteq>\<^sub>r ?\<tau>s!0"
      by (simp add: JVM_le_Err_conv lesub_def)
    moreover {
      fix n'
      have "OK None \<sqsubseteq>\<^sub>r ?\<tau>s!n"
        by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def
                 split: err.splits)
      hence "\<lbrakk>n = Suc n'; n < size start\<rbrakk> \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by simp
    }
    ultimately
    show "n < size start \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by (cases n, blast+)
  qed
  moreover
  from ck_type length
  have "?\<tau>s \<in> list (size is) A"
    by (auto intro!: listI simp add: check_types_def)
  moreover
  from wt_err have "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  ultimately
  have "\<forall>p. p < size is \<longrightarrow> kiljvm P  mxs mxl T\<^sub>r is xt start ! p \<noteq> Err"
    by (unfold is_bcv_def) blast
  with instrs
  show "wt_kildall P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt" by (unfold wt_kildall_def) simp
qed
(*>*)

theorem jvm_kildall_correct:
  "wf_jvm_prog\<^sub>k P = wf_jvm_prog P"
(*<*)
proof -
  let ?\<Phi> = "\<lambda>C M. let (C,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)) = method P C M in
              SOME \<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  let ?A = "\<lambda>P C' (M, Ts, T\<^sub>r, mxs, mxl\<^sub>0, is, xt). wt_kildall P C' Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  let ?B\<^sub>\<Phi> = "\<lambda>\<Phi>. (\<lambda>P C (M,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)).
                wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M))"

  show ?thesis proof(rule iffI)
    \<comment> \<open>soundness\<close>
    assume wt: "wf_jvm_prog\<^sub>k P"
    then have "wf_prog ?A P" by(simp add: wf_jvm_prog\<^sub>k_def)
    moreover {
      fix wf_md C M Ts Ca T m bd
      assume "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M :  Ts\<rightarrow>T = m in Ca" and
             "set Ts \<subseteq> types P" and "bd = (M, Ts, T, m)" and
             "?A P Ca bd"
      then have "(?B\<^sub>\<Phi> ?\<Phi>) P Ca bd" using sees_method_is_class[OF sees]
        by (auto dest!: start_context.wt_kil_correct [OF start_context.intro]
                 intro: someI)
    }
    ultimately have "wf_prog (?B\<^sub>\<Phi> ?\<Phi>) P" by(rule wf_prog_lift)
    then have "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P" by (simp add: wf_jvm_prog_phi_def)
    thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
  next
    \<comment> \<open>completeness\<close>
    assume wt: "wf_jvm_prog P"
    then obtain \<Phi> where "wf_prog (?B\<^sub>\<Phi> \<Phi>) P" by(clarsimp simp: wf_jvm_prog_def wf_jvm_prog_phi_def)
    moreover {
      fix wf_md C M b Ts Ca T m bd
      assume "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M:  Ts\<rightarrow>T = m in Ca" and
             "set Ts \<subseteq> types P" and "bd = (M, Ts, T, m)" and
             "(?B\<^sub>\<Phi> \<Phi>) P Ca bd"
      then have "?A P Ca bd" using sees_method_is_class[OF sees]
        by (auto intro!: start_context.wt_kil_complete start_context.intro)
    }
    ultimately have "wf_prog ?A P" by(rule wf_prog_lift)
    thus "wf_jvm_prog\<^sub>k P" by (simp add: wf_jvm_prog\<^sub>k_def)
  qed
qed
(*>*)

end