diff --git a/Chapter10_1.thy b/Chapter10_1.thy
new file mode 100644
index 0000000..86afb41
--- /dev/null
+++ b/Chapter10_1.thy
@@ -0,0 +1,49 @@
+theory Chapter10_1
+imports "HOL-IMP.Def_Init"
+begin
+
+text\<open>
+\section*{Chapter 10}
+
+\exercise
+Define the definite initialisation analysis as two recursive functions
+\<close>
+
+fun ivars :: "com \<Rightarrow> vname set" where
+  "ivars SKIP = {}" |
+  "ivars (x ::= _) = {x}" |
+  "ivars (c\<^sub>1;; c\<^sub>2) = ivars c\<^sub>1 \<union> ivars c\<^sub>2" |
+  "ivars (IF _ THEN c\<^sub>1 ELSE c\<^sub>2) = ivars c\<^sub>1 \<inter> ivars c\<^sub>2" |
+  "ivars (WHILE _ DO _) = {}"
+
+fun ok :: "vname set \<Rightarrow> com \<Rightarrow> bool" where
+  "ok A SKIP = True" |
+  "ok A (x ::= a) \<longleftrightarrow> vars a \<subseteq> A" |
+  "ok A (c\<^sub>1;; c\<^sub>2) \<longleftrightarrow> ok A c\<^sub>1 \<and> ok (A \<union> ivars c\<^sub>1) c\<^sub>2" |
+  "ok A (IF b THEN c\<^sub>1 ELSE c\<^sub>2) \<longleftrightarrow> vars b \<subseteq> A \<and> ok A c\<^sub>1 \<and> ok A c\<^sub>2" |
+  "ok A (WHILE b DO c) \<longleftrightarrow> vars b \<subseteq> A \<and> ok A c"
+
+text\<open>
+such that @{const ivars} computes the set of definitely initialised variables
+and @{const ok} checks that only initialised variable are accessed.
+Prove
+\<close>
+
+lemma "D A c A' \<Longrightarrow> A' = A \<union> ivars c \<and> ok A c"
+  by (induct A c A' rule: D.induct) auto
+
+lemma "ok A c \<Longrightarrow> D A c (A \<union> ivars c)"
+proof (induct A c rule: ok.induct)
+  case (3 A c\<^sub>1 c\<^sub>2)
+  then show ?case by (auto simp add: Un_assoc intro: D.intros)
+next
+  case (4 A b c\<^sub>1 c\<^sub>2)
+  then show ?case by (auto simp add: sup_inf_distrib1 intro: D.intros)
+qed (auto intro: D.intros)
+
+text\<open>
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter10_2/AFold.thy b/Chapter10_2/AFold.thy
new file mode 100644
index 0000000..74ae012
--- /dev/null
+++ b/Chapter10_2/AFold.thy
@@ -0,0 +1,229 @@
+theory AFold
+imports 
+  "HOL-IMP.Sem_Equiv"
+  "HOL-IMP.Vars"
+begin
+
+notation Map.empty ("empty")
+
+text {*
+
+\exercise
+Extend @{text afold} with simplifying addition of @{text 0}. That is, for any
+expression $e$, $e+0$ and $0+e$ should be simplified to just $e$, including
+the case where the $0$ is produced by knowledge of the content of variables.
+
+*}
+type_synonym  tab = "vname \<Rightarrow> val option"
+
+fun afold :: "aexp \<Rightarrow> tab \<Rightarrow> aexp" where
+"afold (N n) _ = N n" |
+"afold (V x) t = (case t x of
+  None \<Rightarrow> V x |
+  Some k \<Rightarrow> N k)" |
+"afold (Plus e1 e2) t = (case (afold e1 t, afold e2 t) of
+  (N n1, N n2) \<Rightarrow> N (n1 + n2) |
+  (N n1, e2') \<Rightarrow> (if n1 = 0 then e2' else Plus (N n1) e2') |
+  (e1', N n2) \<Rightarrow> (if n2 = 0 then e1' else Plus e1' (N n2)) |
+  (e1', e2') \<Rightarrow> Plus e1' e2')"
+
+text {*
+Re-prove the results in this section with the extended version by
+copying and adjusting the contents of theory @{text Fold}.
+*}
+
+definition "approx t s \<longleftrightarrow> (\<forall>x k. t x = Some k \<longrightarrow> s x = k)"
+
+theorem aval_afold[simp]:
+assumes "approx t s"
+shows "aval (afold a t) s = aval a s"
+  using assms
+  by (induct a) (auto simp: approx_def split: aexp.split option.split)
+
+theorem aval_afold_N:
+assumes "approx t s"
+shows "afold a t = N n \<Longrightarrow> aval a s = n"
+  by (metis assms aval.simps(1) aval_afold)
+
+definition
+  "merge t1 t2 = (\<lambda>m. if t1 m = t2 m then t1 m else None)"
+
+primrec "defs" :: "com \<Rightarrow> tab \<Rightarrow> tab" where
+"defs SKIP t = t" |
+"defs (x ::= a) t =
+  (case afold a t of N k \<Rightarrow> t(x \<mapsto> k) | _ \<Rightarrow> t(x:=None))" |
+"defs (c1;;c2) t = (defs c2 o defs c1) t" |
+"defs (IF b THEN c1 ELSE c2) t = merge (defs c1 t) (defs c2 t)" |
+"defs (WHILE b DO c) t = t |` (-lvars c)"
+
+primrec fold where
+"fold SKIP _ = SKIP" |
+"fold (x ::= a) t = (x ::= (afold a t))" |
+"fold (c1;;c2) t = (fold c1 t;; fold c2 (defs c1 t))" |
+"fold (IF b THEN c1 ELSE c2) t = IF b THEN fold c1 t ELSE fold c2 t" |
+"fold (WHILE b DO c) t = WHILE b DO fold c (t |` (-lvars c))"
+
+lemma approx_merge:
+  "approx t1 s \<or> approx t2 s \<Longrightarrow> approx (merge t1 t2) s"
+  by (fastforce simp: merge_def approx_def)
+
+lemma approx_map_le:
+  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
+  by (clarsimp simp: approx_def map_le_def dom_def)
+
+lemma restrict_map_le [intro!, simp]: "t |` S \<subseteq>\<^sub>m t"
+  by (clarsimp simp: restrict_map_def map_le_def)
+
+lemma merge_restrict:
+  assumes "t1 |` S = t |` S"
+  assumes "t2 |` S = t |` S"
+  shows "merge t1 t2 |` S = t |` S"
+proof -
+  from assms
+  have "\<forall>x. (t1 |` S) x = (t |` S) x"
+   and "\<forall>x. (t2 |` S) x = (t |` S) x" by auto
+  thus ?thesis
+    by (auto simp: merge_def restrict_map_def
+             split: if_splits)
+qed
+
+
+lemma defs_restrict:
+  "defs c t |` (- lvars c) = t |` (- lvars c)"
+proof (induction c arbitrary: t)
+  case (Seq c1 c2)
+  hence "defs c1 t |` (- lvars c1) = t |` (- lvars c1)"
+    by simp
+  hence "defs c1 t |` (- lvars c1) |` (-lvars c2) =
+         t |` (- lvars c1) |` (-lvars c2)" by simp
+  moreover
+  from Seq
+  have "defs c2 (defs c1 t) |` (- lvars c2) =
+        defs c1 t |` (- lvars c2)"
+    by simp
+  hence "defs c2 (defs c1 t) |` (- lvars c2) |` (- lvars c1) =
+         defs c1 t |` (- lvars c2) |` (- lvars c1)"
+    by simp
+  ultimately
+  show ?case by (clarsimp simp: Int_commute)
+next
+  case (If b c1 c2)
+  hence "defs c1 t |` (- lvars c1) = t |` (- lvars c1)" by simp
+  hence "defs c1 t |` (- lvars c1) |` (-lvars c2) =
+         t |` (- lvars c1) |` (-lvars c2)" by simp
+  moreover
+  from If
+  have "defs c2 t |` (- lvars c2) = t |` (- lvars c2)" by simp
+  hence "defs c2 t |` (- lvars c2) |` (-lvars c1) =
+         t |` (- lvars c2) |` (-lvars c1)" by simp
+  ultimately
+  show ?case by (auto simp: Int_commute intro: merge_restrict)
+qed (auto split: aexp.split)
+
+
+lemma big_step_pres_approx:
+  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx t s \<Longrightarrow> approx (defs c t) s'"
+proof (induction arbitrary: t rule: big_step_induct)
+  case Skip thus ?case by simp
+next
+  case Assign
+  thus ?case
+    by (clarsimp simp: aval_afold_N approx_def split: aexp.split)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  have "approx (defs c1 t) s2" by (rule Seq.IH(1)[OF Seq.prems])
+  hence "approx (defs c2 (defs c1 t)) s3" by (rule Seq.IH(2))
+  thus ?case by simp
+next
+  case (IfTrue b s c1 s')
+  hence "approx (defs c1 t) s'" by simp
+  thus ?case by (simp add: approx_merge)
+next
+  case (IfFalse b s c2 s')
+  hence "approx (defs c2 t) s'" by simp
+  thus ?case by (simp add: approx_merge)
+next
+  case WhileFalse
+  thus ?case by (simp add: approx_def restrict_map_def)
+next
+  case (WhileTrue b s1 c s2 s3)
+  hence "approx (defs c t) s2" by simp
+  with WhileTrue
+  have "approx (defs c t |` (-lvars c)) s3" by simp
+  thus ?case by (simp add: defs_restrict)
+qed
+
+
+lemma big_step_pres_approx_restrict:
+  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx (t |` (-lvars c)) s \<Longrightarrow> approx (t |` (-lvars c)) s'"
+proof (induction arbitrary: t rule: big_step_induct)
+  case Assign
+  thus ?case by (clarsimp simp: approx_def)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s1"
+    by (simp add: Int_commute)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s2"
+    by (rule Seq)
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s2"
+    by (simp add: Int_commute)
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s3"
+    by (rule Seq)
+  thus ?case by simp
+next
+  case (IfTrue b s c1 s' c2)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s"
+    by (simp add: Int_commute)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s'"
+    by (rule IfTrue)
+  thus ?case by (simp add: Int_commute)
+next
+  case (IfFalse b s c2 s' c1)
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s"
+    by simp
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s'"
+    by (rule IfFalse)
+  thus ?case by simp
+qed auto
+
+
+declare assign_simp [simp]
+
+lemma approx_eq:
+  "approx t \<Turnstile> c \<sim> fold c t"
+proof (induction c arbitrary: t)
+  case SKIP show ?case by simp
+next
+  case Assign
+  show ?case by (simp add: equiv_up_to_def)
+next
+  case Seq
+  thus ?case by (auto intro!: equiv_up_to_seq big_step_pres_approx)
+next
+  case If
+  thus ?case by (auto intro!: equiv_up_to_if_weak)
+next
+  case (While b c)
+  hence "approx (t |` (- lvars c)) \<Turnstile>
+         WHILE b DO c \<sim> WHILE b DO fold c (t |` (- lvars c))"
+    by (auto intro: equiv_up_to_while_weak big_step_pres_approx_restrict)
+  thus ?case
+    by (auto intro: equiv_up_to_weaken approx_map_le)
+qed
+
+
+lemma approx_empty [simp]:
+  "approx empty = (\<lambda>_. True)"
+  by (auto simp: approx_def)
+
+theorem constant_folding_equiv:
+  "fold c empty \<sim> c"
+  using approx_eq [of Map.empty c]
+  by (simp add: equiv_up_to_True sim_sym)
+
+text{*
+\endexercise
+*}
+
+end
+
diff --git a/Chapter10_2/Bool_Fold.thy b/Chapter10_2/Bool_Fold.thy
new file mode 100644
index 0000000..3cc2ec2
--- /dev/null
+++ b/Chapter10_2/Bool_Fold.thy
@@ -0,0 +1,257 @@
+theory Bool_Fold imports "HOL-IMP.Fold" begin
+
+notation Map.empty ("empty")
+
+text \<open>
+\exercise
+Strengthen and re-prove the congruence rules for conditional semantic equivalence
+to take the value of boolean expressions into account in the \texttt{IF} and
+\texttt{WHILE} cases. As a reminder, the weaker rules are:
+
+@{thm [display] equiv_up_to_if_weak}
+
+@{thm [display] equiv_up_to_while_weak}
+
+Find a formulation that takes @{text b} into account for equivalences about @{term c} or @{term d}.
+\<close>
+
+lemma equiv_up_to_if_lemma:
+  assumes b: "P \<Turnstile> b <\<sim>> b'"
+  assumes c: "(\<lambda>s. P s \<and> bval b s) \<Turnstile> c \<sim> c'"
+  assumes d: "(\<lambda>s. P s \<and> (\<not> bval b s)) \<Turnstile> d \<sim> d'"
+  assumes H: "(IF b THEN c ELSE d, s) \<Rightarrow> s'" "P s"
+  shows "(IF b' THEN c' ELSE d', s) \<Rightarrow> s'"
+proof (insert H(1), elim IfE)
+  assume H': "(c, s) \<Rightarrow> s'" "bval b s"
+  from b H(2) H'(2) have "bval b' s" by (simp add: bequiv_up_to_subst)
+  moreover from c H' H(2) have "(c', s) \<Rightarrow> s'" by (simp add: equiv_up_toD1)
+  ultimately show ?thesis by auto
+next
+  assume H': "(d, s) \<Rightarrow> s'" "\<not>bval b s"
+  from b H(2) H'(2) have "\<not>bval b' s" by (simp add: bequiv_up_to_subst)
+  moreover from d H' H(2) have "(d', s) \<Rightarrow> s'" by (simp add: equiv_up_toD1)
+  ultimately show ?thesis by auto
+qed
+
+lemma equiv_up_to_if:
+  assumes b: "P \<Turnstile> b <\<sim>> b'"
+  assumes c: "(\<lambda>s. P s \<and> bval b s) \<Turnstile> c \<sim> c'"
+  assumes d: "(\<lambda>s. P s \<and> (\<not> bval b s)) \<Turnstile> d \<sim> d'"
+  shows "P \<Turnstile> IF b THEN c ELSE d \<sim> IF b' THEN c' ELSE d'"
+proof (clarsimp simp add: equiv_up_to_def)
+  fix s s'
+  assume H: "P s"
+  show "(IF b THEN c ELSE d, s) \<Rightarrow> s' = (IF b' THEN c' ELSE d', s) \<Rightarrow> s'"
+  proof
+    assume "(IF b THEN c ELSE d, s) \<Rightarrow> s'"
+    with b c d H show "(IF b' THEN c' ELSE d', s) \<Rightarrow> s'" by (simp add: equiv_up_to_if_lemma)
+  next
+    from b have b': "P \<Turnstile> b' <\<sim>> b" by (simp add: bequiv_up_to_sym)
+    from b c have c': "(\<lambda>s. P s \<and> bval b' s) \<Turnstile> c' \<sim> c"
+      by (auto elim: equiv_up_to_weaken simp add: equiv_up_to_sym bequiv_up_to_def)
+    from b d have d': "(\<lambda>s. P s \<and> \<not>bval b' s) \<Turnstile> d' \<sim> d"
+      by (auto elim: equiv_up_to_weaken simp add: equiv_up_to_sym bequiv_up_to_def)
+    assume "(IF b' THEN c' ELSE d', s) \<Rightarrow> s'"
+    with b' c' d' H show "(IF b THEN c ELSE d, s) \<Rightarrow> s'" by (simp add: equiv_up_to_if_lemma)
+  qed
+qed
+
+lemma equiv_up_to_while_lemma:
+  assumes b: "P \<Turnstile> b <\<sim>> b'"
+  assumes c: "(\<lambda>s. P s \<and> bval b s) \<Turnstile> c \<sim> c'"
+  assumes I: "\<And>s s'. \<lbrakk>(c, s) \<Rightarrow> s'; P s; bval b s\<rbrakk> \<Longrightarrow> P s'"
+  assumes H: "(WHILE b DO c, s) \<Rightarrow> s'" "P s"
+  shows "(WHILE b' DO c', s) \<Rightarrow> s'"
+proof (insert H, induct "WHILE b DO c" s s' rule: big_step_induct)
+  case (WhileFalse s)
+  with b show ?case by (auto simp add: bequiv_up_to_def)
+next
+  case (WhileTrue s\<^sub>1 s\<^sub>2 s\<^sub>3)
+  from c WhileTrue(1, 2, 6) have Hc: "(c', s\<^sub>1) \<Rightarrow> s\<^sub>2" by (auto simp add: equiv_up_toD1)
+  moreover from I WhileTrue(1, 2, 5, 6) have Hw: "(WHILE b' DO c', s\<^sub>2) \<Rightarrow> s\<^sub>3" by auto
+  moreover from b WhileTrue(1, 6) have "bval b' s\<^sub>1" by (auto simp add: bequiv_up_to_def)
+  ultimately show ?case by auto
+qed
+
+lemma equiv_up_to_while:
+  assumes b: "P \<Turnstile> b <\<sim>> b'"
+  assumes c: "(\<lambda>s. P s \<and> bval b s) \<Turnstile> c \<sim> c'"
+  assumes I: "\<And>s s'. \<lbrakk>(c, s) \<Rightarrow> s'; P s; bval b s\<rbrakk> \<Longrightarrow> P s'"
+  shows "P \<Turnstile> WHILE b DO c \<sim> WHILE b' DO c'"
+proof (clarsimp simp add: equiv_up_to_def)
+  fix s s'
+  assume H: "P s"
+  show "(WHILE b DO c, s) \<Rightarrow> s' = (WHILE b' DO c', s) \<Rightarrow> s'"
+  proof
+    assume "(WHILE b DO c, s) \<Rightarrow> s'"
+    with b c I H show "(WHILE b' DO c', s) \<Rightarrow> s'" by (simp add: equiv_up_to_while_lemma)
+  next
+    from b have b': "P \<Turnstile> b' <\<sim>> b" by (simp add: bequiv_up_to_sym)
+    from b c have c': "(\<lambda>s. P s \<and> bval b' s) \<Turnstile> c' \<sim> c"
+      by (auto elim: equiv_up_to_weaken simp add: equiv_up_to_sym bequiv_up_to_def)
+    from b c I have I': "\<And>s s'. \<lbrakk>(c', s) \<Rightarrow> s'; P s; bval b' s\<rbrakk> \<Longrightarrow> P s'"
+      by (auto simp add: bequiv_up_to_def equiv_up_to_def)
+    assume "(WHILE b' DO c', s) \<Rightarrow> s'"
+    with b' c' I' H show "(WHILE b DO c, s) \<Rightarrow> s'" by (simp add: equiv_up_to_while_lemma)
+  qed
+qed
+
+text \<open>
+\endexercise
+
+\exercise
+Extend constant folding with analysing boolean expressions
+and eliminate dead \texttt{IF} branches as well as loops whose body is
+never executed. Use the contents of theory @{theory "HOL-IMP.Fold"} as a blueprint.
+\<close>
+
+lemma equiv_up_to_pre_skip [intro!]: "P \<Turnstile> SKIP;; c \<sim> c"
+proof (intro equiv_up_toI)
+  fix s s'
+  show "(SKIP;; c, s) \<Rightarrow> s' = (c, s) \<Rightarrow> s'" by auto
+qed
+
+lemma equiv_up_to_post_skip [intro!]: "P \<Turnstile> c;; SKIP \<sim> c"
+proof (intro equiv_up_toI)
+  fix s s'
+  show "(c;; SKIP, s) \<Rightarrow> s' = (c, s) \<Rightarrow> s'" by auto
+qed
+
+fun bfold :: "bexp \<Rightarrow> tab \<Rightarrow> bexp"  where
+  "bfold (Bc v) t = Bc v" |
+  "bfold (Not b) t = (case bfold b t of
+    Bc v \<Rightarrow> Bc (\<not>v) |
+    b' \<Rightarrow> Not b')" |
+  "bfold (And b\<^sub>1 b\<^sub>2) t = (case (bfold b\<^sub>1 t, bfold b\<^sub>2 t) of
+    (Bc v\<^sub>1, b\<^sub>2') \<Rightarrow> (if v\<^sub>1 then b\<^sub>2' else (Bc False)) |
+    (b\<^sub>1', Bc v\<^sub>2) \<Rightarrow> (if v\<^sub>2 then b\<^sub>1' else (Bc False)) |
+    (b\<^sub>1', b\<^sub>2') \<Rightarrow> And b\<^sub>1' b\<^sub>2')" |
+  "bfold (Less a\<^sub>1 a\<^sub>2) t = (case (afold a\<^sub>1 t, afold a\<^sub>2 t) of
+    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> Bc (n\<^sub>1 < n\<^sub>2) |
+    (a\<^sub>1', a\<^sub>2') \<Rightarrow> Less a\<^sub>1' a\<^sub>2')"
+
+lemma bequiv_up_to_not: "P \<Turnstile> b <\<sim>> b' \<Longrightarrow> P \<Turnstile> Not b <\<sim>> Not b'"
+  by (simp add: bequiv_up_to_def)
+
+lemma bequiv_up_to_not_bc: "P \<Turnstile> b <\<sim>> Bc v \<Longrightarrow> P \<Turnstile> Not b <\<sim>> Bc (\<not>v)"
+  by (simp add: bequiv_up_to_def)
+
+lemma bequiv_up_to_and: "\<lbrakk>P \<Turnstile> b\<^sub>1 <\<sim>> b\<^sub>1'; P \<Turnstile> b\<^sub>2 <\<sim>> b\<^sub>2'\<rbrakk> \<Longrightarrow> P \<Turnstile> (And b\<^sub>1 b\<^sub>2) <\<sim>> (And b\<^sub>1' b\<^sub>2')"
+  by (simp add: bequiv_up_to_def)
+
+lemma bequiv_up_to_and_True1: "\<lbrakk>P \<Turnstile> b\<^sub>1 <\<sim>> Bc True; P \<Turnstile> b\<^sub>2 <\<sim>> b\<^sub>2'\<rbrakk> \<Longrightarrow> P \<Turnstile> (And b\<^sub>1 b\<^sub>2) <\<sim>> b\<^sub>2'"
+  by (simp add: bequiv_up_to_def)
+
+lemma bequiv_up_to_and_True2: "\<lbrakk>P \<Turnstile> b\<^sub>1 <\<sim>> b\<^sub>1'; P \<Turnstile> b\<^sub>2 <\<sim>> Bc True\<rbrakk> \<Longrightarrow> P \<Turnstile> (And b\<^sub>1 b\<^sub>2) <\<sim>> b\<^sub>1'"
+  by (simp add: bequiv_up_to_def)
+
+lemma bequiv_up_to_and_False1: "\<lbrakk>P \<Turnstile> b\<^sub>1 <\<sim>> Bc False\<rbrakk> \<Longrightarrow> P \<Turnstile> (And b\<^sub>1 b\<^sub>2) <\<sim>> Bc False"
+  by (simp add: bequiv_up_to_def)
+
+lemma bequiv_up_to_and_False2: "\<lbrakk>P \<Turnstile> b\<^sub>2 <\<sim>> Bc False\<rbrakk> \<Longrightarrow> P \<Turnstile> (And b\<^sub>1 b\<^sub>2) <\<sim>> Bc False"
+  by (simp add: bequiv_up_to_def)
+
+lemma bequiv_up_to_less_n: "P \<Turnstile> (Less (N n\<^sub>1) (N n\<^sub>2)) <\<sim>> Bc (n\<^sub>1 < n\<^sub>2)"
+  by (simp add: bequiv_up_to_def)
+
+lemma afold_less: "\<lbrakk>afold a\<^sub>1 t = a\<^sub>1'; afold a\<^sub>2 t = a\<^sub>2'\<rbrakk> \<Longrightarrow>
+  approx t \<Turnstile> Less a\<^sub>1 a\<^sub>2 <\<sim>> Less a\<^sub>1' a\<^sub>2'"
+  by (auto simp add: bequiv_up_to_def)
+
+lemma bfold_equiv [intro!]: "approx t \<Turnstile> b <\<sim>> bfold b t"
+proof (induct b)
+case (Bc x)
+  then show ?case by auto
+next
+  case (Not b)
+  then show ?case
+    by (auto split: bexp.split intro: bequiv_up_to_not bequiv_up_to_not_bc)
+next
+  case (And b1 b2)
+  then show ?case
+    by (auto split: bexp.split
+        intro: bequiv_up_to_and
+        bequiv_up_to_and_True1
+        bequiv_up_to_and_True2
+        bequiv_up_to_and_False1
+        bequiv_up_to_and_False2)
+next
+  case (Less x1a x2a)
+  then show ?case
+    by (auto simp add: afold_less split: aexp.split intro: bequiv_up_to_less_n)
+      (simp add: aval_afold_N bequiv_up_to_def)
+qed
+
+theorem bval_bfold_N:
+assumes "approx t s"
+shows "bfold b t = Bc v \<Longrightarrow> bval b s = v"
+  by (metis assms bval.simps(1) bfold_equiv bequiv_up_to_def)
+
+(*note that we do not fold skips*)
+primrec fold' :: "com \<Rightarrow> tab \<Rightarrow> com" where
+  "fold' SKIP _ = SKIP" |
+  "fold' (x ::= a) t = (x ::= afold a t)" |
+  "fold' (c\<^sub>1;; c\<^sub>2) t = (fold' c\<^sub>1 t;; fold' c\<^sub>2 (defs c\<^sub>1 t))" |
+  "fold' (IF b THEN c\<^sub>1 ELSE c\<^sub>2) t = (case bfold b t of
+    Bc v \<Rightarrow> (if v then fold' c\<^sub>1 t else fold' c\<^sub>2 t) |
+    b' \<Rightarrow> IF b' THEN fold' c\<^sub>1 t ELSE fold' c\<^sub>2 t)" |
+  "fold' (WHILE b DO c) t = (case bfold b t of
+    Bc v \<Rightarrow> (if v then (WHILE bfold b (t |` (-lvars c)) DO fold' c (t |` (-lvars c))) else SKIP) |
+    _ \<Rightarrow> WHILE bfold b (t |` (-lvars c)) DO fold' c (t |` (-lvars c)))"
+
+text \<open>
+  Hint: you will need to make use of stronger congruence rules
+        for conditional semantic equivalence.
+\<close>
+
+lemma bfold_if_True: "bfold b t = Bc True \<Longrightarrow> approx t \<Turnstile> IF b THEN c1 ELSE c2 \<sim> c1"
+  by (insert bfold_equiv [of t b], auto simp add: bequiv_up_to_def)
+
+lemma bfold_if_False: "bfold b t = Bc False \<Longrightarrow> approx t \<Turnstile> IF b THEN c1 ELSE c2 \<sim> c2"
+  by (insert bfold_equiv [of t b], auto simp add: bequiv_up_to_def)
+
+lemma bfold_while_False: "bfold b t = Bc False \<Longrightarrow> approx t \<Turnstile> WHILE b DO c1 \<sim> SKIP"
+  by (insert bfold_equiv [of t b], auto simp add: bequiv_up_to_def)
+
+lemma fold'_equiv: "approx t \<Turnstile> c \<sim> fold' c t"
+proof (induct c arbitrary: t)
+  case SKIP
+  then show ?case by simp
+next
+  case (Assign x1 x2)
+  then show ?case by (simp add: equiv_up_to_def)
+next
+  case (Seq c1 c2)
+  then show ?case
+    by (auto intro!: equiv_up_to_seq big_step_pres_approx)
+next
+  case (If x1 c1 c2)
+  have "approx t \<Turnstile> x1 <\<sim>> bfold x1 t" by auto
+  with If show ?case
+    by (auto split: bexp.split intro: equiv_up_to_if_weak)
+    (auto simp add: equiv_up_to_trans
+      dest: bfold_if_True [of x1 t c1 c2]
+       bfold_if_False [of x1 t c1 c2])
+next
+  case (While x1 c)
+  moreover let ?tr = "t |` (-lvars c)"
+  have H1: "approx ?tr \<Turnstile> x1 <\<sim>> bfold x1 ?tr" by auto
+  moreover have H2: "\<And>s s'. \<lbrakk>(c, s) \<Rightarrow> s'; approx ?tr s; bval x1 s\<rbrakk> \<Longrightarrow> approx ?tr s'"
+    by (auto intro: big_step_pres_approx_restrict)
+  ultimately have "approx ?tr \<Turnstile>
+         WHILE x1 DO c \<sim> WHILE bfold x1 ?tr DO fold' c ?tr"
+    by (auto intro!: equiv_up_to_while_weak)
+  with While have Hweak: "approx t \<Turnstile> WHILE x1 DO c \<sim> WHILE bfold x1 ?tr DO fold' c ?tr"
+    by (auto intro: equiv_up_to_weaken approx_map_le)
+  show ?case
+    by (auto simp add: bval_bfold_N intro: Hweak split: bexp.split)
+qed
+
+theorem constant_folding_equiv': "fold' c empty \<sim> c"
+  using fold'_equiv [of empty c]
+  by (simp add: equiv_up_to_True)
+
+text \<open> \endexercise \<close>
+
+end
+
diff --git a/Chapter10_2/Remove_And_Copy.thy b/Chapter10_2/Remove_And_Copy.thy
new file mode 100644
index 0000000..a9da341
--- /dev/null
+++ b/Chapter10_2/Remove_And_Copy.thy
@@ -0,0 +1,287 @@
+theory Remove_And_Copy
+  imports "HOL-IMP.Sem_Equiv" "HOL-IMP.Vars"
+begin
+
+notation Map.empty ("empty")
+
+text \<open>
+\exercise\label{exs:remove}
+This exercise builds infrastructure for \autoref{exs:acopy}, where we
+will have to manipulate partial maps from variable names to variable names.
+\<close>
+type_synonym tab = "vname \<Rightarrow> vname option"
+
+text \<open>
+  In addition to the function @{text merge} from theory @{text Fold},
+  implement two functions @{text remove} and @{text remove_all} that
+  remove one variable name from the range of a map, and a set of variable
+  names from the domain and range of a map.
+\<close>
+
+definition merge :: "tab \<Rightarrow> tab \<Rightarrow> tab" where
+  "merge t1 t2 = (\<lambda>m. if t1 m = t2 m then t1 m else None)"
+
+definition remove :: "vname \<Rightarrow> tab \<Rightarrow> tab" where
+  "remove v t = (\<lambda>m. if t m = Some v then None else t m)"
+
+definition remove_all :: "vname set \<Rightarrow> tab \<Rightarrow> tab" where
+  "remove_all vs t = (\<lambda>m. if (m \<in> vs)
+    then None
+    else if (t m \<in> Some ` vs)
+      then None
+      else t m)"
+
+text \<open>
+  Prove the following lemmas.
+\<close>
+
+lemma "ran (remove x t) = ran t - {x}"
+proof (auto simp add: remove_def ran_def)
+  fix xa a
+  assume "xa \<noteq> x" "t a = Some xa"
+  then have "t a \<noteq> Some x \<and> (t a \<noteq> Some x \<longrightarrow> t a = Some xa)" by auto
+  then show "\<exists>a. t a \<noteq> Some x \<and> (t a \<noteq> Some x \<longrightarrow> t a = Some xa)" by blast
+qed
+
+lemma "ran (remove_all S t) \<subseteq> -S"
+  by (auto simp add: remove_all_def ran_def)
+
+lemma "dom (remove_all S t) \<subseteq> -S"
+  by (auto simp add: remove_all_def dom_def)
+
+lemma remove_all_update[simp]:
+"remove_all {x} (t (x:= y)) = remove_all {x} t"
+  by (auto simp add: remove_all_def)
+
+lemma remove_all_remove[simp]:
+"remove_all {x} (remove x t) = remove_all {x} t"
+  by (auto simp add: remove_all_def remove_def)
+
+lemma remove_all_Un[simp]:
+"remove_all A (remove_all B t) = remove_all (A \<union> B) t"
+  by (intro ext, auto simp add: remove_all_def)
+
+lemma remove_all_in_dom [simp]: "a \<in> A \<Longrightarrow> remove_all A t a = None"
+  by (auto simp add: remove_all_def)
+
+lemma remove_all_in_range [simp]: "t a \<in> Some ` A \<Longrightarrow> remove_all A t a = None"
+  by (auto simp add: remove_all_def)
+
+lemma remove_all_in_range_singleton [simp]: "remove_all {x} t a \<noteq> Some x"
+  by (auto simp add: remove_all_def)
+
+lemma remove_all_notin [simp]: "\<lbrakk>a \<notin> A; t a \<notin> Some ` A\<rbrakk> \<Longrightarrow> remove_all A t a = t a"
+  by (auto simp add: remove_all_def)
+
+lemma remove_all_map_le [intro]: "remove_all A t \<subseteq>\<^sub>m t"
+  by (auto simp add: remove_all_def map_le_def split: if_split_asm)
+
+lemma map_leD1 [dest]: "\<lbrakk>f \<subseteq>\<^sub>m g; f x = Some y\<rbrakk> \<Longrightarrow> g x = Some y"
+  by (auto simp add: map_le_def Ball_def)
+
+lemma map_leD2 [dest]: "\<lbrakk>f \<subseteq>\<^sub>m g; g x = None\<rbrakk> \<Longrightarrow> f x = None"
+  by (auto simp add: map_le_def Ball_def)
+
+lemma remove_all_map_le1 [dest]: "remove_all A t a = Some k \<Longrightarrow> t a = Some k"
+  by (auto intro: map_leD1)
+
+lemma remove_all_map_le2 [dest]: "t a = None \<Longrightarrow> remove_all A t a = None"
+  by (auto intro: map_leD2)
+
+lemma merge_in: "(merge t1 t2) x \<in> Some ` S \<Longrightarrow> t1 x \<in> Some ` S \<and> t2 x \<in> Some ` S"
+  by (auto simp add: merge_def split: if_split_asm)
+
+lemma remove_all_merge_in_range: "(merge t1 t2) x \<in> Some ` S \<Longrightarrow> remove_all S t1 x = None \<and> remove_all S t2 x = None"
+  by (auto dest!: merge_in)
+
+lemma remove_all_merge1_none [simp]: "remove_all S t1 x = None \<Longrightarrow> remove_all S (merge t1 t2) x = None"
+  by (auto simp add: remove_all_def merge_def)
+
+lemma remove_all_merge2_none [simp]: "remove_all S t2 x = None \<Longrightarrow> remove_all S (merge t1 t2) x = None"
+  by (auto simp add: remove_all_def merge_def)
+
+lemma merge_map_le1 [intro]: "merge t1 t2 \<subseteq>\<^sub>m t1"
+  by (auto simp add: merge_def map_le_def)
+
+lemma merge_map_le2 [intro]: "merge t1 t2 \<subseteq>\<^sub>m t2"
+  by (auto simp add: merge_def map_le_def)
+
+lemma merge_remove_all:
+  assumes "remove_all S t1 = remove_all S t"
+  assumes "remove_all S t2 = remove_all S t"
+  shows "remove_all S (merge t1 t2) = remove_all S t"
+proof
+  fix x
+  from assms(1) [THEN fun_cong, of x] assms(2) [THEN fun_cong, of x]
+  show "remove_all S (merge t1 t2) x = remove_all S t x"
+    by (auto simp add: remove_all_def merge_def split: if_split_asm)
+qed
+
+text \<open>
+  \endexercise
+
+  \exercise\label{exs:acopy}
+  This is a more challenging exercise.
+  Define and prove correct \emph{copy propagation}. Copy propagation is
+similar to constant folding, but propagates the right-hand side of assignments
+if these right-hand sides are just variables. For instance, the program
+\texttt{x := y; z := x + z} will be transformed into
+\texttt{x := y; z := y + z}.
+The assignment \texttt{x := y} can then be eliminated in a liveness
+analysis. Copy propagation is useful for cleaning up after other optimisation
+phases.
+
+  To do this, take the definitions for constant folding from theory
+  @{text Fold} and adjust
+  them to do copy propagation instead (without constant folding).
+  Use the functions from \autoref{exs:remove} in your definition.
+  The general proof idea and structure of constant folding remains
+  applicable. Adjust it according to your new definitions.
+\<close>
+
+definition "approx t s \<longleftrightarrow> (\<forall>x k. t x = Some k \<longrightarrow> s x = s k)"
+
+primrec acopy :: "aexp \<Rightarrow> tab \<Rightarrow> aexp" where
+  "acopy (N n) _ = N n" |
+  "acopy (V x) t = (case t x of None \<Rightarrow> V x | Some x' \<Rightarrow> V x')" |
+  "acopy (Plus e1 e2) t = (Plus (acopy e1 t) (acopy e2 t))"
+
+primrec bcopy :: "bexp \<Rightarrow> tab \<Rightarrow> bexp" where
+  "bcopy (Bc v) _ = Bc v" |
+  "bcopy (Not b) t = Not (bcopy b t)" |
+  "bcopy (And b1 b2) t = And (bcopy b1 t) (bcopy b2 t)" |
+  "bcopy (Less e1 e2) t = Less (acopy e1 t) (acopy e2 t)"
+
+fun copy :: "com \<Rightarrow> tab \<Rightarrow> com" and
+  defs :: "com \<Rightarrow> tab \<Rightarrow> tab" where
+  "copy SKIP _ = SKIP" |
+  "defs SKIP t = t" |
+  "copy (x ::= a) t = (x ::= acopy a t)" |
+  "defs (x ::= a) t = (case acopy a t of V x' \<Rightarrow> (remove_all {x} t) (x \<mapsto> x') | _ \<Rightarrow> remove_all {x} t)" |
+  "copy (c1;; c2) t = (copy c1 t;; copy c2 (defs c1 t))" |
+  "defs (c1;; c2) t = (defs c2 (defs c1 t))" |
+  "copy (IF b THEN c1 ELSE c2) t = IF bcopy b t THEN copy c1 t ELSE copy c2 t" |
+  "defs (IF b THEN c1 ELSE c2) t = merge (defs c1 t) (defs c2 t)" |
+  "copy (WHILE b DO c) t = WHILE bcopy b (remove_all (lvars c) t) DO copy c (remove_all (lvars c) t)" |
+  "defs (WHILE b DO c) t = remove_all (lvars c) t"
+
+value "copy (''x'' ::= V ''y'';; ''z'' ::= Plus (V ''x'') (V ''z'')) Map.empty"
+
+lemma approx_merge:
+  "approx t1 s \<or> approx t2 s \<Longrightarrow> approx (merge t1 t2) s"
+  by (fastforce simp: merge_def approx_def)
+
+lemma approx_map_le:
+  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
+  by (clarsimp simp: approx_def map_le_def dom_def)
+
+theorem aval_acopy [simp]: "approx t s \<Longrightarrow> aval (acopy a t) s = aval a s"
+  by (induct a) (auto simp add: approx_def split: aexp.split option.split)
+
+lemma acopy_VD [dest]: "acopy a t = V x \<Longrightarrow> (a = V x \<and> t x = None) \<or> (\<exists> x'. a = V x' \<and> t x' = Some x)"
+  by (cases a, auto split: option.split_asm)
+
+lemma remove_all_lvars_defs: "remove_all (lvars c) (defs c t) = remove_all (lvars c) t"
+proof (induct c arbitrary: t)
+  case (Assign x1 x2)
+  then show ?case by (auto split: aexp.split)
+next
+  case (Seq c1 c2)
+  then show ?case
+  proof (auto)
+    assume H1: "\<And>t. remove_all (lvars c1) (defs c1 t) = remove_all (lvars c1) t"
+    assume H2: "\<And>t. remove_all (lvars c2) (defs c2 t) = remove_all (lvars c2) t"
+    have "remove_all (lvars c1 \<union> lvars c2) (defs c2 (defs c1 t)) =
+      remove_all (lvars c1) (remove_all (lvars c2) (defs c2 (defs c1 t)))" by simp
+    also from H2 have "\<dots> = remove_all (lvars c1) (remove_all (lvars c2) (defs c1 t))" by simp
+    also have "\<dots> = remove_all (lvars c2 \<union> lvars c1) (defs c1 t)" by (simp add: Un_commute)
+    also have "\<dots> = remove_all (lvars c2) (remove_all (lvars c1) (defs c1 t))" by simp
+    also from H1 have "\<dots> = remove_all (lvars c2) (remove_all (lvars c1) t)" by simp
+    also have "\<dots> = remove_all (lvars c1 \<union> lvars c2) t" by (simp add: Un_commute)
+    finally show "remove_all (lvars c1 \<union> lvars c2) (defs c2 (defs c1 t)) = remove_all (lvars c1 \<union> lvars c2) t" .
+  qed
+next
+  case (If x1 c1 c2)
+  then show ?case
+  proof (auto intro!: merge_remove_all)
+    assume "\<And>t. remove_all (lvars c1) (defs c1 t) = remove_all (lvars c1) t"
+    then have "remove_all (lvars c2) (remove_all (lvars c1) (defs c1 t)) = remove_all (lvars c2) (remove_all (lvars c1) t)" by simp
+    then show "remove_all (lvars c1 \<union> lvars c2) (defs c1 t) = remove_all (lvars c1 \<union> lvars c2) t" by (simp add: Un_commute)
+    assume "\<And>t. remove_all (lvars c2) (defs c2 t) = remove_all (lvars c2) t"
+    then have "remove_all (lvars c1) (remove_all (lvars c2) (defs c2 t)) = remove_all (lvars c1) (remove_all (lvars c2) t)" by simp
+    then show "remove_all (lvars c1 \<union> lvars c2) (defs c2 t) = remove_all (lvars c1 \<union> lvars c2) t" by simp
+  qed
+qed auto
+
+lemma big_step_pres_approx: "\<lbrakk>(c, s) \<Rightarrow> s'; approx t s\<rbrakk> \<Longrightarrow> approx (defs c t) s'"
+proof (induct c s s' arbitrary: t rule: big_step_induct)
+  case (Assign x a s)
+  then show ?case by (auto simp add: approx_def split: aexp.split)
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  then show ?case
+  proof auto
+    assume "approx t s\<^sub>1"
+    moreover assume "\<And>t. approx t s\<^sub>1 \<Longrightarrow> approx (defs c t) s\<^sub>2"
+    ultimately have "approx (defs c t) s\<^sub>2" by auto
+    moreover assume "\<And>t. approx t s\<^sub>2 \<Longrightarrow> approx (remove_all (lvars c) t) s\<^sub>3"
+    ultimately have "approx (remove_all (lvars c) (defs c t)) s\<^sub>3" by auto
+    then show "approx (remove_all (lvars c) t) s\<^sub>3" by (simp add: remove_all_lvars_defs)
+  qed
+qed (auto intro: approx_map_le)
+
+lemma big_step_pres_approx_remove_all_lvars:
+  "(c, s) \<Rightarrow> s' \<Longrightarrow> approx (remove_all (lvars c) t) s \<Longrightarrow> approx (remove_all (lvars c) t) s'"
+proof -
+  assume "(c, s) \<Rightarrow> s'" "approx (remove_all (lvars c) t) s"
+  then have "approx (defs c (remove_all (lvars c) t)) s'" by (simp add: big_step_pres_approx)
+  then have "approx (remove_all (lvars c) (defs c (remove_all (lvars c) t))) s'" by (auto intro: approx_map_le)
+  then have "approx (remove_all (lvars c) (remove_all (lvars c) t)) s'" by (simp add: remove_all_lvars_defs)
+  then show "approx (remove_all (lvars c) t) s'" by simp
+qed
+
+theorem approx_bcopy [intro]: "approx t \<Turnstile> b <\<sim>> bcopy b t" by (induct b) (auto simp add: bequiv_up_to_def)
+
+theorem copy_equiv: "approx t \<Turnstile> c \<sim> copy c t"
+proof (induct c arbitrary: t)
+case (Assign x1 x2)
+  then show ?case
+  proof (auto simp add: equiv_up_to_def)
+    fix s :: state
+    assume "approx t s"
+    have "(x1 ::= acopy x2 t, s) \<Rightarrow> s(x1 := aval (acopy x2 t) s)" by auto
+    with \<open>approx t s\<close> show "(x1 ::= acopy x2 t, s) \<Rightarrow> s(x1 := aval x2 s)" by auto
+  qed
+next
+  case (Seq c1 c2)
+  then show ?case by (auto intro!: equiv_up_to_seq big_step_pres_approx)
+next
+  case (If x1 c1 c2)
+  then show ?case by (auto intro!: equiv_up_to_if_weak)
+next
+  case (While x1 c)
+  moreover let ?tr = "remove_all (lvars c) t"
+  have H1: "approx ?tr \<Turnstile> x1 <\<sim>> bcopy x1 ?tr" by auto
+  moreover have H2: "\<And>s s'. \<lbrakk>(c, s) \<Rightarrow> s'; approx ?tr s; bval x1 s\<rbrakk> \<Longrightarrow> approx ?tr s'"
+    by (auto intro: big_step_pres_approx_remove_all_lvars)
+  ultimately have "approx ?tr \<Turnstile>
+         WHILE x1 DO c \<sim> WHILE bcopy x1 ?tr DO copy c ?tr"
+    by (auto intro!: equiv_up_to_while_weak)
+  with While have Hweak: "approx t \<Turnstile> WHILE x1 DO c \<sim> WHILE bcopy x1 ?tr DO copy c ?tr"
+    by (auto intro: equiv_up_to_weaken approx_map_le)
+  show ?case
+    by (auto intro: Hweak split: bexp.split)
+qed auto
+
+lemma approx_empty [simp]:
+  "approx empty = (\<lambda>_. True)"
+  by (auto simp: approx_def)
+
+theorem "copy c empty \<sim> c"
+  using copy_equiv [of empty c]
+  by (simp add: equiv_up_to_True)
+
+text \<open> \endexercise \<close>
+
+end
+
diff --git a/Chapter10_3.thy b/Chapter10_3.thy
new file mode 100644
index 0000000..c10bfa7
--- /dev/null
+++ b/Chapter10_3.thy
@@ -0,0 +1,217 @@
+theory Chapter10_3
+imports
+  "HOL-IMP.Live"
+  "HOL-IMP.Small_Step"
+begin
+
+text\<open>
+\exercise
+Prove the following termination-insensitive version of the correctness of
+@{const L}:
+\<close>
+
+theorem "\<lbrakk>(c, s) \<Rightarrow> s'; (c, t) \<Rightarrow> t'; s = t on L c X\<rbrakk> \<Longrightarrow> s' = t' on X"
+proof (induct arbitrary: t t' X rule: big_step_induct)
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  from Seq(5) obtain ti where HSeqt: "(c\<^sub>1, t) \<Rightarrow> ti" "(c\<^sub>2, ti) \<Rightarrow> t'" by auto
+  from HSeqt(1) Seq(2, 6) have "s\<^sub>2 = ti on (L c\<^sub>2 X)" by auto
+  with HSeqt(2) Seq(4) show "s\<^sub>3 = t' on X" by auto
+next
+  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
+  from IfTrue(5) have H: "s = t on vars b" "s = t on L c\<^sub>1 X" by auto
+  from bval_eq_if_eq_on_vars [OF H(1)] IfTrue(1) have "bval b t" by auto
+  with IfTrue(4) have "(c\<^sub>1, t) \<Rightarrow> t'" by auto
+  with IfTrue(3) H(2) show "s' = t' on X" by auto
+next
+  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
+  from IfFalse(5) have H: "s = t on vars b" "s = t on L c\<^sub>2 X" by auto
+  from bval_eq_if_eq_on_vars [OF H(1)] IfFalse(1) have "\<not>bval b t" by auto
+  with IfFalse(4) have "(c\<^sub>2, t) \<Rightarrow> t'" by auto
+  with IfFalse(3) H(2) show "s' = t' on X" by auto
+next
+  case (WhileFalse b s c)
+  from WhileFalse(3) have H: "s = t on vars b" using L_While_vars by blast
+  from bval_eq_if_eq_on_vars [OF H] WhileFalse(1) have "\<not>bval b t" by auto
+  with WhileFalse(2) have "t = t'" by auto
+  with WhileFalse(3) show ?case using L_While_X by blast
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  from WhileTrue(7) have H1: "s\<^sub>1 = t on vars b" "s\<^sub>1 = t on L c (L (WHILE b DO c) X)"
+    using L_While_vars L_While_pfp by blast+
+  from bval_eq_if_eq_on_vars [OF H1(1)] WhileTrue(1) have "bval b t" by auto
+  with WhileTrue(6) obtain ti where H2: "(c, t) \<Rightarrow> ti" "(WHILE b DO c, ti) \<Rightarrow> t'" by auto
+  from WhileTrue(3) H2(1) H1(2) have "s\<^sub>2 = ti on L (WHILE b DO c) X" by simp
+  with H2(2) WhileTrue(5) show "s\<^sub>3 = t' on X" by simp
+qed auto
+
+text\<open>
+Do not derive it as a corollary of the original correctness theorem
+but prove it separately. Hint: modify the original proof.
+\endexercise
+
+\exercise\label{exe:bury-not-idemp}
+Find a command @{text c} such that @{prop"bury (bury c {}) {} \<noteq> bury c {}"}.
+For an arbitrary command, can you put a limit on the amount of burying needed
+until everything that is dead is also buried?
+\<close>
+
+value "bury (''y'' ::= (V ''x'');; ''z'' ::= (V ''y'')) {}"
+value "bury (bury (''y'' ::= (V ''x'');; ''z'' ::= (V ''y'')) {}) {}"
+(* Amount of burying bounded above by the number of assignment statements,
+  since the only transformation that bury does is removing assignment statements
+*)
+
+text\<open>
+\endexercise
+
+\exercise
+Let @{term"lvars c"} / @{term"rvars c"} be the set of variables that
+occur on the left-hand / right-hand side of an assignment in @{text c}.
+Let @{term "rvars c"} additionally including those variables mentioned in
+the conditionals of @{text IF} and @{text WHILE}.
+Both functions are predefined in theory @{short_theory "Vars"}.
+Show the following two properties of the small-step semantics.
+Variables that are not assigned to do not change their value:
+\<close>
+
+lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); lvars c \<inter> X = {}\<rbrakk> \<Longrightarrow> s = s' on X"
+proof (induct rule: star_induct)
+  case (step c s c' s' c'' s'')
+  from step(1, 4) have "s = s' on X" by (induct rule: small_step_induct) auto
+  moreover from step(1, 4) have "lvars c' \<inter> X = {}" by (induct rule: small_step_induct) auto
+  with step(3) have "s' = s'' on X" by simp
+  ultimately show ?case by simp
+qed simp
+
+text\<open>
+The reduction behaviour of a command is only influenced by the variables
+read by the command:
+\<close>
+
+lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); s = t on X; rvars c \<subseteq> X\<rbrakk>
+  \<Longrightarrow> \<exists>t'. (c,t) \<rightarrow>* (c',t') \<and> s' = t' on X"
+proof (induct arbitrary: t rule: star_induct)
+  case (step c s c' s' c'' s'')
+    (* a stronger conclusion than necessary; that a step corresponds to a step,
+    not several steps *)
+  from step(1, 4, 5) have "\<exists>t'. (c, t) \<rightarrow> (c', t') \<and> s' = t' on X"
+  proof (induct arbitrary: t rule: small_step_induct)
+    case (Assign x a s)
+    have "(x ::= a, t) \<rightarrow> (SKIP, t(x := aval a t))" by auto
+    moreover from Assign have "s = t on vars a" by auto
+    then have Hav: "aval a s = aval a t" by auto
+    with Assign have "s(x := aval a s) = t(x := aval a t) on X" by auto
+    ultimately show ?case by blast
+  next
+    case (Seq2 c\<^sub>1 s c\<^sub>1' s' c\<^sub>2)
+    from Seq2(2-4) obtain t' where H: "(c\<^sub>1, t) \<rightarrow> (c\<^sub>1', t')" "s' = t' on X" by fastforce
+    from H(1) have "(c\<^sub>1;; c\<^sub>2, t) \<rightarrow> (c\<^sub>1';; c\<^sub>2, t')" by auto
+    with H(2) show ?case by auto
+  next
+    case (IfTrue b s c\<^sub>1 c\<^sub>2)
+    from IfTrue(2, 3) have "s = t on vars b" by auto
+    from IfTrue(1) bval_eq_if_eq_on_vars [OF this] have "bval b t" by auto
+    then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<rightarrow> (c\<^sub>1, t)" by auto
+    with IfTrue(2) show ?case by auto
+  next
+    case (IfFalse b s c\<^sub>1 c\<^sub>2)
+    from IfFalse(2, 3) have "s = t on vars b" by auto
+    from IfFalse(1) bval_eq_if_eq_on_vars [OF this] have "\<not>bval b t" by auto
+    then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, t) \<rightarrow> (c\<^sub>2, t)" by auto
+    with IfFalse(2) show ?case by auto
+  qed auto
+  then obtain t' where H1: "(c, t) \<rightarrow> (c', t')" "s' = t' on X" by auto
+  from step(1, 5) have "rvars c' \<subseteq> X" by (induct rule: small_step_induct) auto
+  with H1(2) step(3) obtain t'' where H2: "(c', t') \<rightarrow>* (c'', t'')" "s'' = t'' on X" by fastforce
+  from H1(1) H2(1) have "(c, t) \<rightarrow>* (c'', t'')" by (simp add: star.step)
+  with H2(2) show ?case by blast
+qed auto
+
+text\<open>
+Hint: prove single step versions of the lemmas first.
+\endexercise
+
+\exercise
+An \concept{available definitions} analysis determines which previous
+assignments \texttt{x := a} are valid equalities \texttt{x = a} at later
+program points.  For example, after \texttt{x := y+1} the equality \texttt{x =
+y+1} is available, but after \mbox{\texttt{x := y+1;}} \texttt{y := 2} the equality \texttt{x = y+1} is
+no longer available. The motivation for the analysis is that if \texttt{x =
+a} is available before \texttt{v := a} then \mbox{\texttt{v := a}} can be replaced by
+\texttt{v := x}.
+
+Define an available definitions analysis as a gen/kill analysis,
+for suitably defined @{text gen} and @{text kill} (which may need to be
+mutually recursive):
+\<close>
+hide_const (open) gen "kill"
+fun gen :: "com \<Rightarrow> (vname * aexp) set" and
+  "kill" :: "com \<Rightarrow> (vname * aexp) set" where
+  "gen SKIP = {}" |
+  "gen (x ::= a) = (if x \<in> vars a then {} else {(x, a)})" |
+  "gen (c\<^sub>1;; c\<^sub>2) = (gen c\<^sub>1 - kill c\<^sub>2) \<union> gen c\<^sub>2" |
+  "gen (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = gen c\<^sub>1 \<inter> gen c\<^sub>2" |
+  "gen (WHILE b DO c) = {}" |
+  "kill SKIP = {}" |
+  "kill (x ::= a) = {(x', a')| x' a'. x = x' \<or> x \<in> vars a'}" |
+  "kill (c\<^sub>1;; c\<^sub>2) = kill c\<^sub>1 \<union> kill c\<^sub>2" |
+  "kill (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = kill c\<^sub>1 \<union> kill c\<^sub>2" |
+  "kill (WHILE b DO c) = kill c"
+
+definition AD :: "(vname * aexp) set \<Rightarrow> com \<Rightarrow> (vname * aexp) set" where
+"AD A c = gen c \<union> (A - kill c)"
+
+text\<open>
+The defining equations for both @{const gen} and @{const kill} follow
+the \isacom{where} and are separated by ``@{text "|"}'' as usual.
+
+A call \ @{term"AD A c"} \ should compute the available definitions
+after the execution of @{text c} assuming that the definitions in @{text A}
+are available before the execution of @{text c}.
+
+Prove correctness of the analysis:
+\<close>
+
+theorem "\<lbrakk> (c,s) \<Rightarrow> s';  \<forall> (x,a) \<in> A. s x = aval a s \<rbrakk>
+  \<Longrightarrow> \<forall> (x,a) \<in> AD A c. s' x = aval a s'"
+proof (induct arbitrary: A rule: big_step_induct)
+  case (Skip s)
+  then show ?case by (auto simp add: AD_def)
+next
+  case (Assign x a s)
+  show ?case
+  proof (intro ballI, unfold AD_def)
+    fix p' :: "vname \<times> aexp"
+    assume Hin: "p' \<in> gen (x ::= a) \<union> (A - kill (x ::= a))"
+    obtain x' a' where HP: "p' = (x', a')" using prod.split_sel by blast
+    with Hin consider (Bgen) "(x', a') \<in> gen (x ::= a)" | (BA) "(x', a') \<in> (A - kill (x ::= a))" by auto
+    then have "(s(x := aval a s)) x' = aval a' (s(x := aval a s))"
+    proof cases
+      case Bgen
+      with Assign show ?thesis by (auto split: if_split_asm)
+    next
+      case BA
+      with Assign have "s x' = aval a' s" "x' \<noteq> x" "x \<notin> vars a'" by auto
+      then show ?thesis by auto
+    qed
+    with HP show "case p' of (x', a') \<Rightarrow> (s(x := aval a s)) x' = aval a' (s(x := aval a s))" by auto
+  qed
+next
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  from Seq(2, 5) have "\<forall>(x, a) \<in> AD A c\<^sub>1. s\<^sub>2 x = aval a s\<^sub>2" by (auto simp add: AD_def)
+  with Seq(4) have "\<forall>(x, a) \<in> AD (AD A c\<^sub>1) c\<^sub>2. s\<^sub>3 x = aval a s\<^sub>3" by (auto simp add: AD_def)
+  then show ?case by (auto simp add: AD_def)
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  from WhileTrue(3, 6) have "\<forall>(x, a) \<in> AD A c. s\<^sub>2 x = aval a s\<^sub>2" by (auto simp add: AD_def)
+  with WhileTrue(5) show ?case by (auto simp add: AD_def)
+qed (auto simp add: AD_def)
+
+text\<open>
+\endexercise
+\<close>
+
+
+
+end
+
diff --git a/Chapter10_4.thy b/Chapter10_4.thy
new file mode 100644
index 0000000..6b6a64f
--- /dev/null
+++ b/Chapter10_4.thy
@@ -0,0 +1,109 @@
+theory Chapter10_4
+imports "HOL-IMP.Live_True" "HOL-IMP.Vars"
+begin
+
+lemma "(let b = Less (N 0) (V ''x''); c = ''x'' ::= V ''y'';; ''y'' ::= V ''z''
+  in L (WHILE b DO c) {}) = {''x'', ''y'', ''z''}"
+by eval
+
+text \<open>That there are live variables before the loop is not weird, even though
+there are no live variables after the loop; the fixpoint adds in the vars including those in
+the loop that are needed in the computation of the test (vars b) to the set of live variables.
+For checking termination before the first loop, pre-loop value of x from before is needed,
+for check inf just after the first loop, pre-loop value of y decides, and after that value of
+z is needed\<close>
+
+
+text \<open>Ex 10.12 WHILE b (relying on e\<^sub>1) DO e\<^sub>1 ::= e\<^sub>2;; e\<^sub>2 ::= e\<^sub>3 ...\<close>
+
+text\<open>
+\exercise
+In the context of ordinary live variable analysis, elimination of dead variables
+(@{text bury}) is not idempotent (Exercise~\ref{exe:bury-not-idemp}).
+Now define the textually identical function @{text bury} in the context
+of true liveness analysis (theory @{theory "HOL-IMP.Live_True"})
+and prove that it is idempotent.
+\<close>
+
+fun bury :: "com \<Rightarrow> vname set \<Rightarrow> com" where
+"bury SKIP X = SKIP" |
+"bury (x ::= a) X = (if x \<in> X then x ::= a else SKIP)" |
+"bury (c\<^sub>1;; c\<^sub>2) X = (bury c\<^sub>1 (L c\<^sub>2 X);; bury c\<^sub>2 X)" |
+"bury (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = IF b THEN bury c\<^sub>1 X ELSE bury c\<^sub>2 X" |
+"bury (WHILE b DO c) X = WHILE b DO bury c (L (WHILE b DO c) X)"
+
+text\<open> The following two tweaks improve proof automation: \<close>
+
+declare L.simps(5)[simp]
+lemmas L_mono2 = L_mono[unfolded mono_def]
+
+text\<open> To show that @{const bury} is idempotent we need a key lemma: \<close>
+
+lemma L_bury: "X \<subseteq> Y \<Longrightarrow> L (bury c Y) X = L c X"
+proof (induct c arbitrary: X Y)
+  case (Seq c1 c2)
+  from Seq(3) have "(L c2 X) \<subseteq> (L c2 Y)" by (simp add: L_mono2)
+  with Seq(1) have "L (bury c1 (L c2 Y)) (L c2 X) = L c1 (L c2 X)" by simp
+  moreover from Seq(2, 3) have "L (bury c2 Y) X = L c2 X" by simp
+  ultimately have "L (bury c1 (L c2 Y)) (L (bury c2 Y) X) = L c1 (L c2 X)" by simp
+  then show ?case by simp
+next
+  case (While x1 c)
+  let ?x = "\<lambda>U. vars x1 \<union> X \<union> L c U" and ?y = "\<lambda>V. vars x1 \<union> Y \<union> L c V"
+  let ?xb = "\<lambda>U. vars x1 \<union> X \<union> L (bury c (lfp ?y)) U"
+  have "mono ?x" and "mono ?xb" by (auto intro: mono_union_L)
+  then have fpx: "?x (lfp ?x) = lfp ?x" and fpxb: "?xb (lfp ?xb) = lfp ?xb" by (auto intro!: lfp_fixpoint)
+  from While(2) have x_s_y: "lfp ?x \<subseteq> lfp ?y" by (auto intro!: lfp_mono)
+  with While(1) have "L (bury c (lfp ?y)) (lfp ?x) = L c (lfp ?x)" by simp
+  with fpx have "?xb (lfp ?x) = lfp ?x" by simp
+  then have xb_s_x: "lfp ?xb \<subseteq> lfp ?x" by (auto intro!: lfp_lowerbound)
+  with x_s_y have "lfp ?xb \<subseteq> lfp ?y" by simp
+  with While(1) have "L (bury c (lfp ?y)) (lfp ?xb) = L c (lfp ?xb)" by simp
+  with fpxb have "?x (lfp ?xb) = lfp ?xb" by simp
+  then have x_s_xb: "lfp ?x \<subseteq> lfp ?xb" by (auto intro!: lfp_lowerbound)
+  with xb_s_x show ?case by simp
+qed auto
+
+text\<open> The proof is straightforward except for the case
+\noquotes{@{term[source] "While b c"}} where reasoning about @{const lfp}
+is required. Sledgehammer should help with the details.
+
+Now we can prove idempotence of @{const bury}, again by induction on @{text c}:
+\<close>
+
+theorem bury_idemp: "bury (bury c X) X = bury c X"
+proof (induct c arbitrary: X)
+  case (Seq c1 c2)
+  show ?case
+  proof (simp, intro conjI)
+    from Seq(2) show "bury (bury c2 X) X = bury c2 X" .
+    have "bury (bury c1 (L c2 X)) (L (bury c2 X) X) = bury (bury c1 (L c2 X)) (L c2 X)" by (simp add: L_bury)
+    also from Seq(1) have "\<dots> = bury c1 (L c2 X)" by simp
+    finally show "bury (bury c1 (L c2 X)) (L (bury c2 X) X) = bury c1 (L c2 X)" .
+  qed
+next
+case (While x1 c)
+  let ?x = "\<lambda>Y. vars x1 \<union> X \<union> L c Y"
+  let ?xb = "\<lambda>Y. vars x1 \<union> X \<union> L (bury c (lfp ?x)) Y"
+  have "mono ?x" and "mono ?xb" by (simp add: mono_union_L)+
+  then have fpx: "?x (lfp ?x) = lfp ?x" and fpxb: "?xb (lfp ?xb) = lfp ?xb" by (auto intro!: lfp_fixpoint)
+  then have "?xb (lfp ?x) = lfp ?x" by (simp add: L_bury)
+  then have xb_s_x: "lfp ?xb \<subseteq> lfp ?x" by (auto intro!: lfp_lowerbound)
+  then have "L (bury c (lfp ?x)) (lfp ?xb) = L c (lfp ?xb)" by (simp add: L_bury)
+  then have "?xb (lfp ?xb) = ?x (lfp ?xb)" by simp
+  with fpxb have "?x (lfp ?xb) = lfp ?xb" by simp
+  then have x_s_xb: "lfp ?x \<subseteq> lfp ?xb" by (auto intro!: lfp_lowerbound)
+  with xb_s_x have "lfp ?x = lfp ?xb" by simp
+  moreover from While have "bury (bury c (lfp ?x)) (lfp ?x) = bury c (lfp ?x)" by simp
+  ultimately have "bury (bury c (lfp ?x)) (lfp ?xb) = bury c (lfp ?x)" by simp
+  then show ?case by simp
+qed auto
+(* your definition/proof here *)
+
+text\<open>
+Due to lemma @{thm[source] L_bury}, even the @{text While} case should be easy.
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter11.thy b/Chapter11.thy
new file mode 100644
index 0000000..fd29ee6
--- /dev/null
+++ b/Chapter11.thy
@@ -0,0 +1,371 @@
+theory Chapter11
+imports "HOL-IMP.Denotational" "HOL-IMP.Vars"
+begin
+
+text\<open>
+\section*{Chapter 11}
+
+\begin{exercise}
+Building on Exercise~\ref{exe:IMP:REPEAT}, extend the denotational
+semantics and the equivalence proof with the big-step semantics
+with a @{text REPEAT} loop.
+\end{exercise}
+
+\exercise
+Consider Example~11.14 and prove the following equation by induction on @{text n}:
+\<close>
+lemma "(W (\<lambda>s. s ''x'' \<noteq> 0) {(s,t). t = s(''x'' := s ''x'' - 1)} ^^ n) {} =
+  {(s,t). 0 \<le> s ''x'' \<and> s ''x'' < int n \<and> t = s(''x'' := 0)}" (is "(W ?b ?c ^^ n) {} = ?S n")
+proof (induct n)
+  case 0
+  then show ?case by auto
+next
+  case (Suc n)
+  let "?W n" = "W ?b ?c ^^ n"
+  have "?W (Suc n) {} = W ?b ?c (?W n {})" by simp
+  also from Suc have "\<dots> = W ?b ?c (?S n)" by (rule arg_cong)
+  also have "\<dots> = ?S (Suc n)" by (force simp add: W_def)
+  finally show ?case .
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+Consider Example~11.14 but with the loop condition
+@{prop"b = Less (N 0) (V ''x'')"}. Find a closed expression @{text M}
+(containing @{text n})
+for @{prop"(f ^^ n) {}"} and prove @{prop"(f ^^ n) {} = M"}.
+\<close>
+lemma "(W (bval (Less (N 0) (V ''x''))) {(s,t). t = s(''x'' := s ''x'' - 1)} ^^ n) {} =
+  {(s,t). 0 < n \<and> s ''x'' < int n \<and> t = (if 0 < s ''x'' then s(''x'' := 0) else s)}" (is "(W ?b ?c ^^ n) {} = ?S n")
+proof (induct n)
+  case 0
+  then show ?case by auto
+next
+  case (Suc n)
+  let "?W n" = "W ?b ?c ^^ n"
+  let ?S2 = "{(s, t). 0 < n \<and> s ''x'' < int n \<and> t = (if 0 < s ''x'' then s(''x'' := 0) else s)}"
+  have "?W (Suc n) {} = W ?b ?c (?W n {})" by simp
+  also from Suc have "\<dots> = W ?b ?c (?S n)" by (rule arg_cong)
+  also have "\<dots> = {(s, t). if ?b s then (s,t) \<in> ?c O (?S n) else s=t}" by (simp add: W_def)
+  also have "\<dots> = ?S (Suc n)"
+  proof (cases "0 < n")
+    case npos: True
+    then show ?thesis
+    proof (intro equalityI subsetI, fastforce split: if_split_asm)
+      fix x
+      assume H1: "0 < n" "x \<in> ?S (Suc n)"
+      then obtain s t where H2: "x = (s, t)" "0 < Suc n" "s ''x'' < int (Suc n)" "t = (if 0 < s ''x'' then s(''x'' := 0) else s)" by auto
+      let ?s' = "s(''x'' := s ''x'' - 1)"
+      have "if ?b s then (s, t) \<in> ?c O ?S n else s = t"
+      proof (cases "0 < s ''x''")
+        case sxpos: True
+        have "(s, ?s') \<in> ?c" by auto
+        moreover have "(?s', t) \<in> ?S n"
+        proof -
+          from H1(1) have "0 < n" .
+          moreover from H2(3) have "?s' ''x'' < int n" by simp
+          moreover from H2(4) sxpos have "t = (if 0 < ?s' ''x'' then ?s'(''x'' := 0) else ?s')" by (auto split: if_split_asm)
+          ultimately show ?thesis by simp
+        qed
+        ultimately have "(s, t) \<in> ?c O ?S n" by fastforce
+        with sxpos show ?thesis by fastforce
+      qed (simp add: H2(4))
+      with H2(1) show "x \<in> {(s, t). if ?b s then (s, t) \<in> ?c O ?S n else s = t}" by auto
+    qed
+  next
+    case npos: False
+    then show ?thesis
+    proof (intro equalityI subsetI, fastforce split: if_split_asm)
+      fix x
+      assume H1: "\<not>0 < n" "x \<in> ?S (Suc n)"
+      then obtain s t where H2: "x = (s, t)" "n = 0" "s ''x'' < int (Suc n)" "t = (if 0 < s ''x'' then s(''x'' := 0) else s)" by auto
+      then show "x \<in> {(s, t). if ?b s then (s, t) \<in> ?c O ?S n else s = t}" by fastforce
+    qed
+  qed
+  finally show "?W (Suc n) {} = ?S (Suc n)" .
+qed
+
+text \<open>
+\endexercise
+
+\exercise
+Define an operator @{text B} such that you
+can express the equation for @{term "D (IF b THEN c1 ELSE c2)"}
+in a point free way.
+\<close>
+definition B :: "bexp \<Rightarrow> (state \<times> state) set" where
+  "B b = {(s, t). bval b s \<and> s = t}"
+
+lemma "D (IF b THEN c1 ELSE c2) = (B b O D c1) \<union> (B (Not b) O D c2)"
+  unfolding B_def by auto
+
+text \<open>
+  Similarly, find a point free equation for @{term "W (bval b) dc"}
+  and use it to write down a point free version of
+  @{term "D (WHILE b DO c)"} (still using @{text lfp}).
+  Prove that your equations are equivalent to the old ones.
+\<close>
+
+lemma Wpf: "W (bval b) dc = (\<lambda>dw. B b O dc O dw \<union> B (Not b))"
+  unfolding W_def B_def by auto
+
+lemma "D (WHILE b DO c) = lfp (\<lambda>dw. B b O D c O dw \<union> B (Not b))"
+  by (simp add: Wpf)
+
+text\<open>
+\endexercise
+
+\exercise
+Let the `thin' part of a relation be its single-valued subset:
+\<close>
+
+definition thin :: "'a rel \<Rightarrow> 'a rel" where
+"thin R = {(a,b) . (a,b) \<in> R \<and> (\<forall> c. (a,c) \<in> R \<longrightarrow> c = b)}"
+
+lemma single_valued_thin: "single_valued (thin R)"
+  unfolding single_valued_def thin_def by auto
+
+text\<open> Prove \<close>
+
+lemma fixes f :: "'a rel \<Rightarrow> 'a rel"
+assumes "mono f" and thin_f: "\<And> R. f (thin R) \<subseteq> thin (f R)"
+shows "single_valued (lfp f)"
+proof -
+  from thin_f have "f (thin (lfp f)) \<subseteq> thin (f (lfp f))" .
+  also from \<open>mono f\<close> have "thin (f (lfp f)) = thin (lfp f)" by (simp add: lfp_fixpoint)
+  finally have "lfp f \<subseteq> thin (lfp f)" by (simp add: lfp_lowerbound)
+  with single_valued_thin show "single_valued (lfp f)" by (blast intro: single_valued_subset)
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+Generalise our set-theoretic treatment of continuity and least fixpoints to
+\concept{chain-complete partial order}s (\concept{cpo}s),
+i.e.\ partial orders @{text"\<le>"} that have a least element @{text "\<bottom>"} and
+where every chain @{text"c 0 \<le> c 1 \<le> \<dots>"} has a least upper bound
+@{term"lub c"} where \noquotes{@{term[source]"c :: nat \<Rightarrow> 'a"}}.
+This setting is described by the following type class @{text cpo}
+which is an extension of the type class @{class order} of partial orders.
+For details see the decription of type classes in Chapter~13.
+\<close>
+
+context order
+begin
+definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
+"chain c = (\<forall>n. c n \<le> c (Suc n))"
+end
+
+class cpo = order +
+fixes bot :: 'a and lub :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
+assumes bot_least: "bot \<le> x"
+and lub_ub: "chain c \<Longrightarrow> c n \<le> lub c"
+and lub_least: "chain c \<Longrightarrow> (\<And>n. c n \<le> u) \<Longrightarrow> lub c \<le> u"
+
+text\<open>
+A function \noquotes{@{term[source] "f :: 'a \<Rightarrow> 'b"}}
+between two cpos @{typ 'a} and @{typ 'b}
+is called \concept{continuous} if @{prop"f(lub c) = lub (f o c)"}.
+Prove that if @{text f} is monotone and continuous then
+\ \mbox{@{text"lub (\<lambda>n. (f ^^ n) \<bottom>)"}} \ is the least (pre)fixpoint of @{text f}:
+\<close>
+
+
+definition cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool" where
+"cont f = (\<forall>c. chain c \<longrightarrow> f (lub c) = lub (f o c))"
+
+abbreviation "fix f \<equiv> lub (\<lambda>n. (f^^n) bot)"
+
+lemma bot_mono: fixes f :: "'a::cpo \<Rightarrow> 'a" assumes "mono f" shows "(f ^^ n) bot \<le> (f ^^ Suc n) bot"
+proof (induct n)
+  case (Suc n)
+  with assms show ?case unfolding mono_def by simp
+qed (simp add: bot_least)
+
+lemma fix_lpfp: assumes "mono f" and "f p \<le> p" shows "fix f \<le> p"
+proof (intro lub_least, simp add: chain_def, intro allI)
+  from bot_mono [OF assms(1)] show "(f ^^ n) cpo_class.bot \<le> f ((f ^^ n) cpo_class.bot)" for n by simp
+  show "(f ^^ n) cpo_class.bot \<le> p" for n
+  proof (induct n)
+    case (Suc n)
+    with assms show ?case unfolding mono_def by fastforce
+  qed (simp add: bot_least)
+qed
+
+theorem fix_fp: assumes "mono f" and "cont f" shows "f(fix f) = fix f"
+proof -
+  let ?c = "(\<lambda>n. (f^^n) bot)"
+  let ?cS = "(\<lambda>n. (f^^Suc n) bot)"
+  from bot_mono [OF assms(1)] have cc: "chain ?c" unfolding chain_def by simp
+  then have ccS: "chain ?cS" unfolding chain_def by fastforce
+  with assms(2) cc have "f (lub ?c) = lub (f \<circ> ?c)" unfolding cont_def by blast
+  also have "f \<circ> ?c = ?cS" by (rule ext, auto)
+  then have "lub (f \<circ> ?c) = lub ?cS" by simp
+  also have "lub ?cS = fix f"
+  proof (rule antisym)
+    from ccS show "lub ?cS \<le> fix f"
+    proof (elim lub_least)
+      fix n
+      from lub_ub [OF cc, of "Suc n"] show "(f ^^ Suc n) bot \<le> fix f" .
+    qed
+    from cc show "fix f \<le> lub (\<lambda>n. (f ^^ Suc n) bot)"
+    proof (elim lub_least)
+      fix n
+      from cc have "(f ^^ n) bot \<le> (f ^^ Suc n) bot" unfolding chain_def by simp
+      also from lub_ub [OF ccS] have "\<dots> \<le> lub (\<lambda>n. (f ^^ Suc n) bot)" .
+      finally show "(f ^^ n) bot \<le> lub (\<lambda>n. (f ^^ Suc n) bot)" .
+    qed
+  qed
+  finally show ?thesis .
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+We define a dependency analysis @{text Dep} that maps commands to relations
+between variables such that @{term "(x,y) : Dep c"} means that in
+the execution of @{text c}
+the initial value of @{text x} can influence the final value of @{text y}:
+\<close>
+
+fun Dep :: "com \<Rightarrow> (vname * vname) set" where
+"Dep SKIP = Id" |
+"Dep (x::=a) = {(u,v). if v = x then u \<in> vars a else u = v}" |
+"Dep (c1;;c2) = Dep c1 O Dep c2" |
+"Dep (IF b THEN c1 ELSE c2) = Dep c1 \<union> Dep c2 \<union> vars b \<times> UNIV" |
+"Dep (WHILE b DO c) = lfp(\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R)"
+
+text\<open>
+where @{text"\<times>"} is the cross product of two sets.
+Prove monotonicity of the function @{const lfp} is applied to.
+\<close>
+
+
+text\<open> For the correctness statement define \<close>
+
+abbreviation Deps :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
+"Deps c X \<equiv> (\<Union> x\<in>X. {y. (y,x) : Dep c})"
+
+text\<open> and prove \<close>
+
+lemma "\<lbrakk> (c,s) \<Rightarrow> s';  (c,t) \<Rightarrow> t';  s = t on Deps c X \<rbrakk> \<Longrightarrow> s' = t' on X"
+proof (induct arbitrary: t t' X rule: big_step_induct)
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  from Seq(5) obtain ti where Hti: "(c\<^sub>1, t) \<Rightarrow> ti" "(c\<^sub>2, ti) \<Rightarrow> t'" by auto
+  from Seq(6) have "s\<^sub>1 = t on Deps c\<^sub>1 (Deps c\<^sub>2 X)" by auto
+  from Seq(2) [OF Hti(1) this] have "s\<^sub>2 = ti on Deps c\<^sub>2 X" .
+  from Seq(4) [OF Hti(2) this] show ?case .
+next
+  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
+  show ?case
+  proof (cases "X = {}")
+    case False
+    with IfTrue(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>1 X" by auto
+    from bval_eq_if_eq_on_vars [OF Heq(1)] IfTrue(1) have "bval b t" by simp
+    with IfTrue(4) have "(c\<^sub>1, t) \<Rightarrow> t'" by auto
+    from IfTrue(3) [OF this Heq(2)] show ?thesis .
+  qed simp
+next
+  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
+  then show ?case
+  proof (cases "X = {}")
+    case False
+    with IfFalse(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>2 X" by auto
+    from bval_eq_if_eq_on_vars [OF Heq(1)] IfFalse(1) have "\<not>bval b t" by simp
+    with IfFalse(4) have "(c\<^sub>2, t) \<Rightarrow> t'" by auto
+    from IfFalse(3) [OF this Heq(2)] show ?thesis .
+  qed simp
+next
+  case (WhileFalse b s c)
+  let ?f = "\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R"
+  have monof: "mono ?f" unfolding mono_def by auto
+  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
+  show ?case
+  proof (cases "X = {}")
+    case False
+    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
+    also from fpf have "\<dots> \<subseteq> Deps (WHILE b DO c) X" by simp
+    finally have "vars b \<subseteq> Deps (WHILE b DO c) X" .
+    with WhileFalse(3) have Heq1: "s = t on vars b" by auto
+    from bval_eq_if_eq_on_vars [OF Heq1] WhileFalse(1) have "\<not>bval b t" by simp
+    with WhileFalse(2) have Htt': "t' = t" by auto
+    from False have "X \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
+    also from fpf have "\<dots> \<subseteq> Deps (WHILE b DO c) X" by simp
+    finally have Heq2: "X \<subseteq> Deps (WHILE b DO c) X" .
+    with WhileFalse(3) Htt' show ?thesis by auto
+  qed simp
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  let ?f = "\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R"
+  have monof: "mono ?f" unfolding mono_def by auto
+  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
+  show ?case
+  proof (cases "X = {}")
+    case False
+    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
+    also from fpf have "\<dots> \<subseteq> Deps (WHILE b DO c) X" by simp
+    finally have "vars b \<subseteq> Deps (WHILE b DO c) X" .
+    with WhileTrue(7) have Heq1: "s\<^sub>1 = t on vars b" by auto
+    from bval_eq_if_eq_on_vars [OF Heq1] WhileTrue(1) have "bval b t" by simp
+    with WhileTrue(6) obtain ti where Htw: "(c, t) \<Rightarrow> ti" "(WHILE b DO c, ti) \<Rightarrow> t'" by auto
+    have "Deps c (Deps (WHILE b DO c) X) \<subseteq> Deps (WHILE b DO c) X" using lfp_fixpoint [OF monof] by auto
+    with WhileTrue(7) have "s\<^sub>1 = t on Deps c (Deps (WHILE b DO c) X)" by blast
+    from WhileTrue(3) [OF Htw(1) this] have "s\<^sub>2 = ti on Deps (WHILE b DO c) X" .
+    from WhileTrue(5) [OF Htw(2) this] show ?thesis .
+  qed simp
+qed auto
+
+text\<open>
+
+Give an example that the following stronger termination-sensitive property
+@{prop[display] "\<lbrakk> (c,s) \<Rightarrow> s'; s = t on Deps c X \<rbrakk>
+  \<Longrightarrow> \<exists>t'. (c,t) \<Rightarrow> t' \<and> s' = t' on X"}
+does not hold. Hint: @{prop"X = {}"}.
+\<close>
+
+lemma "\<exists> c s s' t X. (c, s) \<Rightarrow> s' \<and> s = t on Deps c X \<and> (\<nexists>t'. (c, t) \<Rightarrow> t')"
+proof -
+  let ?b = "Less (N 0) (V ''x'')"
+  let ?c = "SKIP"
+  let ?w = "WHILE ?b DO ?c"
+  let ?s = "<> :: vname \<Rightarrow> val"
+  let ?t = "<''x'' := 1> :: vname \<Rightarrow> val"
+  have H1: "(?w, ?s) \<Rightarrow> ?s" unfolding null_state_def by auto
+  have H2: "?s = ?t on Deps ?w {}" by simp
+  have Hbt: "bval ?b ?t" by simp
+  have H3: "\<nexists>t'. (?w, ?t) \<Rightarrow> t'"
+  proof
+    assume "\<exists>t'. (?w, ?t) \<Rightarrow> t'"
+    then obtain t' where "(?w, ?t) \<Rightarrow> t'" by auto
+    then show "False"
+      using Hbt by (induct "?w" "?t" t' rule: big_step_induct) auto
+  qed
+  from H1 H2 H3 show ?thesis by blast
+qed
+
+text\<open>
+
+In the definition of @{term"Dep(IF b THEN c1 ELSE c2)"} the variables
+in @{text b} can influence all variables (@{text UNIV}). However,
+if a variable is not assigned to in @{text c1} and @{text c2}
+it is not influenced by @{text b} (ignoring termination).
+Theory @{theory "HOL-IMP.Vars"} defines a function @{const lvars} such
+that @{term"lvars c"} is the set of variables on the left-hand side
+of an assignment in @{text c}.
+Modify the definition of @{const Dep} as follows:
+replace @{const UNIV} by @{term"lvars c1 \<union> lvars c2"}
+(in the case @{term"IF b THEN c1 ELSE c2"}) and by \mbox{@{term"lvars c"}}
+(in the case @{term"WHILE b DO c"}).
+Adjust the proof of the above correctness statement.
+\<close>
+
+text\<open>
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter12_2.thy b/Chapter12_2.thy
new file mode 100644
index 0000000..b2578de
--- /dev/null
+++ b/Chapter12_2.thy
@@ -0,0 +1,351 @@
+theory Chapter12_2
+imports "HOL-IMP.Hoare_Examples"
+begin
+
+text\<open>
+\section*{Chapter 12}
+
+\setcounter{exercise}{1}
+\<close>
+
+lemma "\<not>(\<forall>P x a. \<Turnstile> {P} x ::= a {\<lambda>s. P (s[a/x])})"
+proof (intro notI)
+  assume "\<forall>P x a. \<Turnstile> {P} x ::= a {\<lambda>s. P (s[a/x])}"
+  then have h: "\<And>P x a s t. \<lbrakk>P s; (x ::= a, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P (t[a/x])" unfolding hoare_valid_def by blast
+  let ?x = "''x''"
+  let ?a = "Plus (N 1) (V ?x)"
+  let ?P = "(\<lambda>s. s ''x'' = 0) :: assn"
+  let ?s = "<> :: state"
+  let ?t = "<''x'' := 1> :: state"
+  let ?tt = "<''x'' := 2> :: state"
+  let ?c = "?x ::= ?a"
+  have h1: "?P ?s" unfolding null_state_def by simp
+  moreover from big_step.Assign [of ?x ?a ?s] have h2: "(''x'' ::= ?a, <>) \<Rightarrow> ?t" unfolding null_state_def by simp
+  from h [of ?P ?s, OF h1 h2] show False by simp
+qed
+
+text\<open>
+\exercise
+Define @{text bsubst} and prove the Substitution Lemma:
+\<close>
+
+fun asubst :: "aexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> aexp" where
+  "asubst (N n) _ _ = N n" |
+  "asubst (V v) a x = (if v = x then a else (V v))" |
+  "asubst (Plus a\<^sub>1 a\<^sub>2) a x = Plus (asubst a\<^sub>1 a x) (asubst a\<^sub>2 a x)"
+
+fun bsubst :: "bexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> bexp" where
+  "bsubst (Bc v) _ _ = Bc v" |
+  "bsubst (Not b) a x = Not (bsubst b a x)" |
+  "bsubst (And b\<^sub>1 b\<^sub>2) a x = And (bsubst b\<^sub>1 a x) (bsubst b\<^sub>2 a x)" |
+  "bsubst (Less a\<^sub>1 a\<^sub>2) a x = Less (asubst a\<^sub>1 a x) (asubst a\<^sub>2 a x)"
+
+lemma asubstitution: "aval (asubst a a' x) s = aval a (s[a'/x])"
+  by (induct a) simp_all
+
+lemma bsubstitution: "bval (bsubst b a x) s = bval b (s[a/x])"
+proof (induct b)
+  case (Less x1a x2a)
+  have "bval (bsubst (Less x1a x2a) a x) s \<longleftrightarrow> aval (asubst x1a a x) s < aval (asubst x2a a x) s" by simp
+  also from asubstitution have "\<dots> \<longleftrightarrow> aval x1a (s[a/x]) < aval x2a (s[a/x])" by simp
+  also have "\<dots> = bval (Less x1a x2a) (s[a/x])" by simp
+  finally show ?case .
+qed simp_all
+
+text\<open>
+This may require a similar definition and proof for @{typ aexp}.
+\endexercise
+
+\exercise
+Define a command @{text cmax} that stores the maximum of the values of the IMP variables
+@{text "x"} and @{text "y"} in the IMP variable @{text "z"} and prove that
+@{text cmax} satisfies its specification:
+\<close>
+
+abbreviation cmax :: com where
+  "cmax \<equiv> IF Less (V ''x'') (V ''y'') THEN ''z'' ::= V ''y'' ELSE ''z'' ::= V ''x''"
+
+lemma "\<turnstile> {\<lambda>s. True} cmax {\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')}"
+proof (rule If; rule Assign'; intro allI impI; elim conjE)
+  fix s
+  have "(s[V ''y''/''z'']) ''z'' = s ''y''" by simp
+  also assume "bval (Less (V ''x'') (V ''y'')) s"
+  then have "s ''x'' < s ''y''" by simp
+  then have "s ''y'' = max (s ''x'') (s ''y'')" by simp
+  also have "\<dots> = max ((s[V ''y''/''z'']) ''x'') ((s[V ''y''/''z'']) ''y'')" by simp
+  finally show "(s[V ''y''/''z'']) ''z'' = max ((s[V ''y''/''z'']) ''x'') ((s[V ''y''/''z'']) ''y'')" .
+next
+  fix s
+  have "(s[V ''x''/''z'']) ''z'' = s ''x''" by simp
+  also assume "\<not>bval (Less (V ''x'') (V ''y'')) s"
+  then have "\<not>s ''x'' < s ''y''" by simp
+  then have "s ''x'' = max (s ''x'') (s ''y'')" by simp
+  also have "\<dots> = max ((s[V ''x''/''z'']) ''x'') ((s[V ''x''/''z'']) ''y'')" by simp
+  finally show "(s[V ''x''/''z'']) ''z'' = max ((s[V ''x''/''z'']) ''x'') ((s[V ''x''/''z'']) ''y'')" .
+qed
+
+
+text\<open>
+Function @{const max} is the predefined maximum function.
+Proofs about @{const max} are often automatic when simplifying with @{thm[source] max_def}.
+\endexercise
+
+\exercise\label{exe:Hoare:sumeq}
+Define an equality operation for arithmetic expressions
+\<close>
+
+
+definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
+  "Eq a1 a2 = (And (Not (Less a1 a2)) (Not (Less a2 a1)))"
+
+text\<open> such that \<close>
+
+lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
+  unfolding Eq_def by auto
+
+text\<open> Prove the following variant of the summation command correct: \<close>
+
+lemma
+  "\<turnstile> {\<lambda>s. s ''x'' = i \<and> 0 \<le> i}
+     ''y'' ::= N 0;;
+     WHILE Not(Eq (V ''x'') (N 0))
+     DO (''y'' ::= Plus (V ''y'') (V ''x'');;
+           ''x'' ::= Plus (V ''x'') (N (-1)))
+     {\<lambda>s. s ''y'' = sum i}"
+proof (intro Seq While' allI impI; (elim conjE)?)
+  let ?ax = "Plus (V ''x'') (N (- 1))"
+  let ?cx = "''x'' ::= ?ax"
+  let ?ay = "Plus (V ''y'') (V ''x'')"
+  let ?cy = "''y'' ::= ?ay"
+  let ?bx = "(bexp.Not (Eq (V ''x'') (N 0)))"
+  let ?P = "\<lambda>s. s ''y'' = sum i - sum (s ''x'') \<and> 0 \<le> s ''x''"
+  let ?PS = "\<lambda>s. ?P (s[?ax/''x''])"
+  let ?Q = "\<lambda>s. s ''y'' = sum i - sum (s ''x'' - 1) \<and> 0 \<le> s ''x'' - 1"
+  let ?Pw = "\<lambda>s. ?P s \<and> bval ?bx s"
+  let ?HI = "\<lambda>s. s ''x'' = i \<and> 0 \<le> i"
+  let ?yi = "N 0"
+  let ?cyi = "''y'' ::= ?yi"
+  {
+    fix s
+    assume HP: "?P s"
+    assume "\<not>bval ?bx s"
+    then have "s ''x'' = 0" by simp
+    with HP show "s ''y'' = sum i" by simp
+  next
+    have "\<turnstile> {?PS} ?cx {?P}" by (rule Assign)
+    then show "\<turnstile> {?Q} ?cx {?P}" by simp
+  next
+    have "\<forall>s. ?Pw s \<longrightarrow> ?Q (s[?ay/''y''])"
+    proof (intro allI impI, elim conjE)
+      fix s
+      assume "bval (bexp.Not (Eq (V ''x'') (N 0))) s"
+      then have Hx0: "s ''x'' \<noteq> 0" by simp
+      have "(s[?ay/''y'']) ''y'' = s ''y'' + s ''x''" by simp
+      also assume "s ''y'' = sum i - sum (s ''x'')"
+      then have "s ''y'' + s ''x'' = sum i - sum (s ''x'') + s ''x''" by simp
+      also assume Hxp: "0 \<le> s ''x''"
+      with Hx0 have "sum i - sum (s ''x'') + s ''x'' = sum i - sum (s ''x'' - 1)" by auto
+      also have "\<dots> = sum i - sum ((s[?ay/''y'']) ''x'' - 1)" by simp
+      finally have "(s[?ay/''y'']) ''y'' = sum i - sum ((s[?ay/''y'']) ''x'' - 1)" (is ?H1) .
+      moreover from Hxp Hx0 have "0 \<le> (s[?ay/''y'']) ''x'' - 1" (is ?H2) by simp
+      ultimately show "?H1 \<and> ?H2" by blast
+    qed
+    from Assign' [OF this] show "\<turnstile> {?Pw} ?cy {?Q}" .
+  next
+    have "\<forall>s. ?HI s \<longrightarrow> ?P (s[?yi/''y''])"
+    proof (intro allI impI, elim conjE)
+      fix s
+      assume Hxi: "s ''x'' = i"
+      then have "(s[N 0/''y'']) ''y'' = sum i - sum ((s[?yi/''y'']) ''x'')" (is ?H1) by simp
+      moreover assume Hi: "0 \<le> i"
+      with Hxi have "0 \<le> (s[N 0/''y'']) ''x''" (is ?H2) by simp
+      ultimately show "?H1 \<and> ?H2" by blast
+    qed
+    from Assign' [OF this] show "\<turnstile> {?HI} ?cyi {?P}" .
+  }
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+Prove that the following command computes @{prop"y - x"} if @{prop"(0::nat) \<le> x"}:
+\<close>
+
+lemma
+  "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
+     WHILE Less (N 0) (V ''x'')
+     DO (''x'' ::= Plus (V ''x'') (N (-1));; ''y'' ::= Plus (V ''y'') (N (-1)))
+     {\<lambda>t. t ''y'' = y - x}"
+proof (rule strengthen_pre; intro While' Seq allI impI; (elim conjE)?)
+  let ?P = "\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x''"
+  let ?Q = "\<lambda>s. s ''y'' - 1 - s ''x'' = y - x \<and> 0 \<le> s ''x''"
+  let ?b = "Less (N 0) (V ''x'')"
+  let ?Pw = "\<lambda>s. ?P s \<and> bval ?b s"
+  let ?ay = "Plus (V ''y'') (N (- 1))"
+  let ?ax = "Plus (V ''x'') (N (- 1))"
+  let ?cy = "''y'' ::= ?ay"
+  let ?cx = "''x'' ::= ?ax"
+  {
+    fix s
+    assume "\<not> bval (Less (N 0) (V ''x'')) s"
+    then have "s ''x'' \<le> 0" by simp
+    moreover assume "?P s"
+    ultimately show "s ''y'' = y - x" by simp
+  next
+    have "\<turnstile> {\<lambda>s. ?P (s[?ay/''y''])} ?cy {?P}" by (rule Assign)
+    then show "\<turnstile> {?Q} ?cy {?P}" by simp
+  next
+    have Hsle: "\<And>s::state. 0 \<le> s ''x'' - 1 \<longleftrightarrow> 0 \<le> s ''x'' \<and> bval ?b s" by auto
+    have "\<turnstile> {\<lambda>s. ?Q (s[?ax/''x''])} ?cx {?Q}" by (rule Assign)
+    then have "\<turnstile> {\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x'' - 1} ?cx {?Q}" by simp
+    with Hsle show "\<turnstile> {\<lambda>s. ?P s \<and> bval ?b s} ?cx {?Q}" by simp
+  next
+    fix s
+    assume "s ''x'' = x" "s ''y'' = y" "0 \<le> x"
+    then show "?P s" by simp
+  }
+qed
+
+text\<open>
+\endexercise
+
+\exercise\label{exe:Hoare:mult}
+Define and verify a command @{text cmult} that stores the product of
+@{text "x"} and @{text "y"} in @{text "z"} assuming @{prop"(0::int)\<le>y"}:
+\<close>
+
+abbreviation cmult :: com where
+  "cmult \<equiv> ''z'' ::= N 0;;
+    WHILE Less (N 0) (V ''y'') DO (''y'' ::= (Plus (V ''y'') (N (-1)));; ''z'' ::= (Plus (V ''z'') (V ''x'')))"
+
+lemma
+  "\<turnstile> {\<lambda>s.  s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} cmult {\<lambda>t. t ''z'' = x*y}"
+proof (intro Seq While' allI impI; (elim conjE)?)
+  let ?I = "\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y"
+  let ?P = "\<lambda>s. s ''x'' = x \<and> s ''z'' = s ''x'' * (y - s ''y'') \<and> 0 \<le> s ''y''"
+  let ?Q = "\<lambda>s. s ''x'' = x \<and> s ''z'' = s ''x'' * (y - s ''y'' - 1) \<and> 0 \<le> s ''y''"
+  let ?b = "Less (N 0) (V ''y'')"
+  let ?az = "Plus (V ''z'') (V ''x'')"
+  let ?cz = "''z'' ::= ?az"
+  let ?ay = "Plus (V ''y'') (N (- 1))"
+  let ?cy = "''y'' ::= ?ay"
+  {
+    show "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} ''z'' ::= N 0 {?P}" by (auto simp add: Assign')
+  next
+    fix s
+    assume "?P s" "\<not>bval ?b s"
+    then show "s ''z'' = x * y" by auto
+  next
+    have Heq: "\<And>s. s ''z'' + s ''x'' = s ''x'' * (y - s ''y'') \<longleftrightarrow> s ''z'' = s ''x'' * (y - s ''y'' - 1)" by (auto simp add: int_distrib(4))
+    have "\<turnstile> {\<lambda>s. ?P (s[?az/''z''])} ?cz {?P}" by (rule Assign)
+    with Heq show "\<turnstile> {?Q} ?cz {?P}" by simp
+  next
+    have Hsle: "\<And>s::state. 0 \<le> s ''y'' - 1 \<longleftrightarrow> 0 \<le> s ''y'' \<and> bval ?b s" by auto
+    have "\<turnstile> {\<lambda>s. ?Q (s[?ay/''y''])} ?cy {?Q}" by (rule Assign)
+    with Hsle show "\<turnstile> {\<lambda>s. ?P s \<and> bval ?b s} ?cy {?Q}" by simp
+  }
+qed
+
+text\<open>
+You may have to simplify with @{thm[source] algebra_simps} to deal with ``@{text"*"}''.
+\endexercise
+
+\exercise\label{exe:Hoare:sqrt}
+The following command computes an integer approximation @{text r} of the square root
+of @{text "i \<ge> 0"}, i.e.\ @{text"r\<^sup>2 \<le> i < (r+1)\<^sup>2"}. Prove
+\<close>
+
+lemma
+  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}
+     ''r'' ::= N 0;; ''r2'' ::= N 1;;
+     WHILE (Not (Less (V ''x'') (V ''r2'')))
+     DO (''r'' ::= Plus (V ''r'') (N 1);;
+            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
+     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
+proof (intro Seq While' allI impI conjI; (elim conjE)?)
+  let ?I = "\<lambda>s. s ''x'' = i \<and> 0 \<le> i"
+  let ?II = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> 1 = (s ''r'' + 1)\<^sup>2"
+  let ?P = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'' + 1)\<^sup>2"
+  let ?Q = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'')\<^sup>2"
+  let ?b = "Not (Less (V ''x'') (V ''r2''))"
+  let ?ar = "Plus (V ''r'') (N 1)"
+  let ?ar2 = "Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1))"
+  {
+    have "\<turnstile> {\<lambda>s. ?P (s[N 1/''r2''])} ''r2'' ::= N 1 {?P}" by (rule Assign)
+    then show "\<turnstile> {?II} ''r2'' ::= N 1 {?P}" by simp
+  next
+    have "\<forall>s. ?I s \<longrightarrow> ?II (s[N 0/''r''])" by auto
+    then show "\<turnstile> {?I} ''r'' ::= N 0 {?II}" by (rule Assign')
+  next
+    fix s
+    assume "?P s"
+    then have H: "s ''x'' = i" "(s ''r'')\<^sup>2 \<le> s ''x''" "s ''r2'' = (s ''r'' + 1)\<^sup>2" by blast+
+    moreover assume "\<not> bval ?b s"
+    then have "s ''x'' < s ''r2''" by auto
+    ultimately show "(s ''r'')\<^sup>2 \<le> i" "i < (s ''r'' + 1)\<^sup>2" by auto
+  next
+    have Heqv: "\<And>x::int. (x + 1)\<^sup>2 = x\<^sup>2 + x + x + 1" by (simp add: power2_sum)
+    have "\<turnstile> {\<lambda>s. ?P (s[?ar2/''r2''])} ''r2'' ::= ?ar2 {?P}" by (rule Assign)
+    with Heqv show "\<turnstile> {?Q} ''r2'' ::= ?ar2 {?P}" by simp
+  next
+    have "\<forall>s. (\<lambda>s. ?P s \<and> bval ?b s) s \<longrightarrow> ?Q (s[?ar/''r''])" by auto
+    then show "\<turnstile> {\<lambda>s. ?P s \<and> bval ?b s} ''r'' ::= ?ar {?Q}" by (rule Assign')
+  }
+qed
+
+text\<open>
+Figure out how @{text r2} is related to @{text r} before
+formulating the invariant.
+The proof may require simplification with @{thm[source] algebra_simps}
+and @{thm[source] power2_eq_square}.
+\endexercise
+
+\exercise
+Prove by induction:
+\<close>
+
+lemma "\<turnstile> {P} c {\<lambda>s. True}"
+proof (induct c arbitrary: P)
+  case SKIP
+  then show ?case by (rule weaken_post, auto)
+next
+  case (Assign x1 x2)
+  then show ?case by (rule Assign', auto)
+next
+  case (Seq c1 c2)
+  then show ?case by (rule hoare.Seq)
+next
+  case (If x1 c1 c2)
+  then show ?case by (rule hoare.If)
+next
+  case (While x1 c)
+  show ?case by (rule strengthen_pre [of _ "\<lambda>_. True"], simp, rule While', auto simp add: While)
+qed
+
+text\<open>
+\endexercise
+
+\exercise\label{exe:fwdassign}
+Design and prove correct a forward assignment rule of the form
+\ \mbox{@{text"\<turnstile> {P} x ::= a {?}"}} \
+where @{text"?"} is some suitable postcondition that depends on @{text P},
+@{text x} and @{text a}. Hint: @{text"?"} may need @{text"\<exists>"}.
+\<close>
+
+lemma "\<turnstile> {P} x ::= a {\<lambda>s. \<exists> x'. P (s(x := x')) \<and> s x = aval a (s(x := x'))}"
+proof (rule Assign', intro allI impI)
+  fix s :: state
+  let ?x' = "s x"
+  assume "P s"
+  then have "P ((s[a/x])(x := ?x'))" by simp
+  moreover have "(s[a/x]) x = aval a ((s[a/x])(x := ?x'))" by simp
+  ultimately show "\<exists>x'. P ((s[a/x])(x := x')) \<and> (s[a/x]) x = aval a ((s[a/x])(x := x'))" by blast
+qed
+
+text\<open>
+(In case you wonder if your @{text Questionmark} is strong enough: see Exercise~\ref{exe:sp})
+\endexercise
+\<close>
+end
+
diff --git a/Chapter12_3.thy b/Chapter12_3.thy
new file mode 100644
index 0000000..7d2ae3b
--- /dev/null
+++ b/Chapter12_3.thy
@@ -0,0 +1,138 @@
+theory Chapter12_3
+imports "HOL-IMP.Hoare_Sound_Complete"
+begin
+
+text\<open>
+\exercise
+Prove
+\<close>
+
+lemma "\<Turnstile> {P} c {Q} \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> wp c Q s)"
+    unfolding hoare_valid_def wp_def by auto
+
+text\<open>
+\endexercise
+
+\begin{exercise}
+Replace the assignment command with a new command \mbox{@{term"Do f"}} where
+@{text "f ::"} @{typ "state \<Rightarrow> state"} can be an arbitrary state transformer.
+Update the big-step semantics, Hoare logic and the soundness and completeness proofs.
+\end{exercise}
+\<close>
+text \<open>
+\exercise
+Which of the following rules are correct? Proof or counterexample!
+\<close>
+
+lemma "\<lbrakk>\<turnstile> {P} c {Q};  \<turnstile> {P'} c {Q'}\<rbrakk> \<Longrightarrow>
+  \<turnstile> {\<lambda>s. P s \<or> P' s} c {\<lambda>s. Q s \<or> Q' s}"
+proof -
+  assume "\<turnstile> {P} c {Q}"
+  then have "\<Turnstile> {P} c {Q}" by (rule hoare_sound)
+  moreover assume "\<turnstile> {P'} c {Q'}"
+  then have "\<Turnstile> {P'} c {Q'}" by (rule hoare_sound)
+  ultimately have "\<Turnstile> {\<lambda>s. P s \<or> P' s} c {\<lambda>s. Q s \<or> Q' s}"
+    unfolding hoare_valid_def by blast
+  then show ?thesis by (rule hoare_complete)
+qed
+
+lemma "\<lbrakk>\<turnstile> {P} c {Q};  \<turnstile> {P'} c {Q'}\<rbrakk> \<Longrightarrow>
+  \<turnstile> {\<lambda>s. P s \<and> P' s} c {\<lambda>s. Q s \<and> Q' s}"
+proof -
+  assume "\<turnstile> {P} c {Q}"
+  then have "\<Turnstile> {P} c {Q}" by (rule hoare_sound)
+  moreover assume "\<turnstile> {P'} c {Q'}"
+  then have "\<Turnstile> {P'} c {Q'}" by (rule hoare_sound)
+  ultimately have "\<Turnstile> {\<lambda>s. P s \<and> P' s} c {\<lambda>s. Q s \<and> Q' s}"
+    unfolding hoare_valid_def by blast
+  then show ?thesis by (rule hoare_complete)
+qed
+
+lemma "\<exists>P Q P' Q' c. \<turnstile> {P} c {Q} \<and>  \<turnstile> {P'} c {Q'} \<and> \<not> \<turnstile> {\<lambda>s. P s \<longrightarrow> P' s} c {\<lambda>s. Q s \<longrightarrow> Q' s}"
+proof -
+  let ?P = "\<lambda>s::state. s ''x'' = 1"
+  let ?Q = "\<lambda>s::state. True"
+  have "\<turnstile> {?P} SKIP {?P}" (is ?P1) by (rule Skip)
+  moreover from this have "\<turnstile> {?P} SKIP {?Q}" (is ?P2) by (rule weaken_post, blast)
+  moreover have "\<not> \<turnstile> {\<lambda>s. ?P s \<longrightarrow> ?P s} SKIP {\<lambda>s. ?Q s \<longrightarrow> ?P s}" (is ?P3)
+  proof
+    assume "\<turnstile> {\<lambda>s. ?P s \<longrightarrow> ?P s} SKIP {\<lambda>s. ?Q s \<longrightarrow> ?P s}"
+    then have "\<Turnstile> {\<lambda>s. ?P s \<longrightarrow> ?P s} SKIP {\<lambda>s. ?Q s \<longrightarrow> ?P s}" by (rule hoare_sound)
+    then have H1: "\<And>s t. \<lbrakk>(?P s \<longrightarrow> ?P s); (SKIP, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (?Q t \<longrightarrow> ?P t)"
+      unfolding hoare_valid_def by (intro allI impI, blast)
+    have H2: "?P <> \<longrightarrow> ?P <>" unfolding null_state_def by blast
+    have H3: "(SKIP, <>) \<Rightarrow> <>" by auto
+    from H1 [of "<>", OF H2 H3] show False unfolding null_state_def by simp
+  qed
+  ultimately show ?thesis by blast
+qed
+text\<open>
+\endexercise
+
+\begin{exercise}
+Based on Exercise~\ref{exe:IMP:OR}, extend Hoare logic and the soundness and completeness proofs
+with nondeterministic choice.
+\end{exercise}
+
+\begin{exercise}
+Based on Exercise~\ref{exe:IMP:REPEAT}, extend Hoare logic and the soundness and completeness proofs
+with a @{text REPEAT} loop. Hint: think of @{text"REPEAT c UNTIL b"} as
+equivalent to \noquotes{@{term[source]"c;; WHILE Not b DO c"}}.
+\end{exercise}
+
+\exercise\label{exe:sp}
+The dual of the weakest precondition is the \concept{strongest postcondition}
+@{text sp}. Define @{text sp} in analogy with @{const wp} via the big-step semantics:
+\<close>
+
+definition sp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
+  "sp c P = (\<lambda>t. \<exists>s. P s \<and> (c, s) \<Rightarrow> t)"
+
+text\<open> Prove that @{const sp} really is the strongest postcondition: \<close>
+
+lemma "(\<Turnstile> {P} c {Q}) \<longleftrightarrow> (\<forall>s. sp c P s \<longrightarrow> Q s)"
+  unfolding hoare_valid_def sp_def by blast
+
+text\<open>
+In analogy with the derived equations for @{const wp} given in the text,
+give and prove equations for ``calculating'' @{const sp} for three constructs:
+@{prop"sp (x ::= a) P = Q\<^sub>1"}, @{prop"sp (c\<^sub>1;;c\<^sub>2) P = Q\<^sub>2"}, and
+@{prop"sp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) P = Q\<^sub>3"}.
+The @{text Q\<^sub>i} must not involve the semantics and may only call
+@{const sp} recursively on the subcommands @{text c\<^sub>i}.
+Hint: @{text Q\<^sub>1} requires an existential quantifier.
+\<close>
+
+lemma sp_Ass [simp]: "sp (x::=a) P = (\<lambda>s. \<exists> x'. P (s(x := x')) \<and> s x = aval a (s(x := x')))"
+  unfolding sp_def
+proof (rule ext, auto)
+  fix s :: state
+  have Heq: "s(x := s x) = s" by auto
+  assume "P s"
+  with Heq have "P (s(x := s x)) \<and> aval a s = aval a (s(x := s x))" by auto
+  then show "\<exists>x'. P (s(x := x')) \<and> aval a s = aval a (s(x := x'))" by blast
+next
+  fix t :: state and x'
+  let ?s = "t(x := x')"
+  assume H: "P (t(x := x'))" "t x = aval a ?s"
+  have Heq: "t(x := t x) = t" by auto
+  have "(x ::= a, ?s) \<Rightarrow> ?s(x := aval a ?s)" by (rule big_step.Assign)
+  with H(2) Heq have "(x ::= a, ?s) \<Rightarrow> t" by simp
+  with H have "P ?s \<and> (x ::= a, ?s) \<Rightarrow> t" by simp
+  from exI [of "\<lambda>s. P s \<and> (x ::= a, s) \<Rightarrow> t", OF this]
+  show "\<exists>s. P s \<and> (x ::= a, s) \<Rightarrow> t" .
+qed
+
+lemma sp_Seq [simp]: "sp (c\<^sub>1;; c\<^sub>2) P = sp c\<^sub>2 (sp c\<^sub>1 P)"
+  unfolding sp_def by (rule ext) auto
+
+lemma sp_If [simp]: "sp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) P =
+  (\<lambda>t. sp c\<^sub>1 (\<lambda>s. P s \<and> bval b s) t \<or> sp c\<^sub>2 (\<lambda>s. P s \<and> \<not>bval b s) t)"
+  unfolding sp_def by (rule ext) auto
+
+text\<open>
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter12_4.thy b/Chapter12_4.thy
new file mode 100644
index 0000000..b1b0988
--- /dev/null
+++ b/Chapter12_4.thy
@@ -0,0 +1,266 @@
+theory Chapter12_4
+imports "HOL-IMP.VCG" "HOL-IMP.Hoare_Examples"
+begin
+
+text \<open>
+\exercise
+Let @{term "asum i"} be the annotated command \texttt{y := 0; W}
+where \texttt{W} is defined in Example~12.7. Prove
+\<close>
+definition asum :: "int \<Rightarrow> acom"where
+  "asum i = ''y'' ::= (N 0);;
+    {\<lambda>s. s ''y'' + sum (s ''x'') = sum i}
+    WHILE Less (N 0) (V ''x'') DO
+    (''y'' ::= Plus (V ''y'') (V ''x'');; ''x'' ::= Plus (V ''x'') (N (-1)))"
+
+lemma "\<turnstile> {\<lambda>s. s ''x'' = i} strip(asum i) {\<lambda>s. s ''y'' = sum i}"
+  unfolding asum_def
+  by (rule vc_sound', auto)
+
+text \<open>
+with the help of corollary @{thm[source] vc_sound'}.
+\endexercise
+
+\exercise
+Solve exercises \ref{exe:Hoare:sumeq} to \ref{exe:Hoare:sqrt} using the VCG:
+for every Hoare triple @{prop"\<turnstile> {P} c {Q}"} from one of those exercises
+define an annotated version @{text C} of @{text c} and prove
+@{prop"\<turnstile> {P} strip C {Q}"} with the help of %Corollary~\ref{cor:vc_sound}
+corollary @{thm[source] vc_sound'}.
+\<close>
+
+definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
+  "Eq a1 a2 = (And (Not (Less a1 a2)) (Not (Less a2 a1)))"
+
+lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
+  unfolding Eq_def by auto
+
+lemma "\<turnstile> {\<lambda>s. s ''x'' = i \<and> 0 \<le> i} strip (
+  ''y'' ::= N 0;;
+  {\<lambda>s. s ''y'' = sum i - sum (s ''x'') \<and> 0 \<le> s ''x''}
+  WHILE Not(Eq (V ''x'') (N 0))
+  DO (''y'' ::= Plus (V ''y'') (V ''x'');;
+    ''x'' ::= Plus (V ''x'') (N (-1))))
+  {\<lambda>s. s ''y'' = sum i}"
+  by (rule vc_sound', auto)
+
+lemma "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x} strip (
+  {\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x''}
+  WHILE Less (N 0) (V ''x'')
+  DO (''x'' ::= Plus (V ''x'') (N (-1));;
+    ''y'' ::= Plus (V ''y'') (N (-1))))
+  {\<lambda>t. t ''y'' = y - x}"
+  by (rule vc_sound', auto)
+
+abbreviation cmult :: com where
+  "cmult \<equiv> ''z'' ::= N 0;;
+    WHILE Less (N 0) (V ''y'') DO (''y'' ::= (Plus (V ''y'') (N (-1)));; ''z'' ::= (Plus (V ''z'') (V ''x'')))"
+
+lemma
+  "\<turnstile> {\<lambda>s.  s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} strip (
+    ''z'' ::= N 0;;
+    {\<lambda>s. s ''x'' = x \<and> s ''z'' = s ''x'' * (y - s ''y'') \<and> 0 \<le> s ''y''}
+    WHILE Less (N 0) (V ''y'')
+    DO (''y'' ::= (Plus (V ''y'') (N (-1)));;
+      ''z'' ::= (Plus (V ''z'') (V ''x''))))
+  {\<lambda>t. t ''z'' = x*y}"
+  by (rule vc_sound', auto simp add: algebra_simps)
+
+lemma
+  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i} strip (
+     ''r'' ::= N 0;; ''r2'' ::= N 1;;
+     {\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'' + 1)\<^sup>2}
+     WHILE (Not (Less (V ''x'') (V ''r2'')))
+     DO (''r'' ::= Plus (V ''r'') (N 1);;
+            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1))))
+     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
+proof (rule vc_sound', auto simp add: algebra_simps)
+  fix s :: state
+  have "\<And>x::int. 3 + (2 * x + (1 + x)\<^sup>2) = (2 + x)\<^sup>2"
+  proof -
+    fix x :: int
+    have "(1 + x)\<^sup>2 = x\<^sup>2 + 2 * x + 1" by (simp add: power2_sum)
+    then have "3 + (2 * x + (1 + x)\<^sup>2) = 3 + (2 * x + (x\<^sup>2 + 2 * x + 1))" by simp
+    also have "\<dots> = 4 + 4 * x + x\<^sup>2" by simp
+    also have "\<dots> = (2 + x)\<^sup>2" by (simp add: power2_sum)
+    finally show "3 + (2 * x + (1 + x)\<^sup>2) = (2 + x)\<^sup>2" .
+  qed
+  then show "3 + (2 * s ''r'' + (1 + s ''r'')\<^sup>2) = (2 + s ''r'')\<^sup>2" by simp
+qed
+
+
+text \<open>
+\endexercise
+
+\exercise
+Having two separate functions @{const pre} and @{const vc} is inefficient.
+When computing @{const vc} one often needs to compute @{const pre} too,
+leading to multiple traversals of many subcommands. Define an optimised function
+\<close>
+fun prevc :: "acom \<Rightarrow> assn \<Rightarrow> assn \<times> bool" where
+  "prevc SKIP Q = (Q, True)" |
+  "prevc (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)), True)" |
+  "prevc (C\<^sub>1;; C\<^sub>2) Q = (\<lambda>(P', S'). (\<lambda>(P, S). (P, S \<and> S')) (prevc C\<^sub>1 P')) (prevc C\<^sub>2 Q)" |
+  "prevc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
+    (\<lambda>(P\<^sub>1, S\<^sub>1). (\<lambda>(P\<^sub>2, S\<^sub>2). (\<lambda>s. if bval b s then P\<^sub>1 s else P\<^sub>2 s, S\<^sub>1 \<and> S\<^sub>2) ) (prevc C\<^sub>2 Q)) (prevc C\<^sub>1 Q)" |
+  "prevc ({I} WHILE b DO C) Q = (\<lambda>(P, S).
+    (I, (\<forall>s.
+      (I s \<and> bval b s \<longrightarrow> P s) \<and>
+      (I s \<and> \<not> bval b s \<longrightarrow> Q s)) \<and>
+      S)) (prevc C I)"
+
+text \<open> that traverses the command only once. Prove \<close>
+
+lemma "prevc C Q = (pre C Q, vc C Q)"
+  by (induct C arbitrary: Q) auto
+
+text \<open>
+\endexercise
+
+\exercise
+Design a VCG that computes post rather than preconditions.
+Start by solving Exercise~\ref{exe:fwdassign}. Now modify theory
+@{short_theory "VCG"} as follows. Instead of @{const pre} define a function
+\<close>
+
+fun post :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
+  "post SKIP P = P" |
+  "post (x ::= a) P = (\<lambda>s. \<exists> x'. P (s(x := x')) \<and> s x = aval a (s(x := x')))" |
+  "post (C\<^sub>1;; C\<^sub>2) P = post C\<^sub>2 (post C\<^sub>1 P)" |
+  "post (IF b THEN C\<^sub>1 ELSE C\<^sub>2) P =
+  (\<lambda>t. post C\<^sub>1 (\<lambda>s. P s \<and> bval b s) t \<or> post C\<^sub>2 (\<lambda>s. P s \<and> \<not>bval b s) t)" |
+  "post ({I} WHILE b DO c) P = (\<lambda>s. I s \<and> \<not>bval b s)"
+
+text \<open>
+such that (with the execption of loops) @{term "post C P"} is the strongest
+postcondition of @{text C} w.r.t.\ the precondition @{text P} (see also
+Exercise~\ref{exe:sp}). Now modify @{const vc} such that is uses
+@{const post} instead of @{const pre} and prove its soundness
+and completeness.
+\<close>
+
+fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
+  "vc SKIP P = True" |
+  "vc (x ::= a) P = True" |
+  "vc (C\<^sub>1;; C\<^sub>2) P \<longleftrightarrow> vc C\<^sub>1 P \<and> vc C\<^sub>2 (post C\<^sub>1 P)" |
+  "vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) P \<longleftrightarrow> vc C\<^sub>1 (\<lambda>s. P s \<and> bval b s) \<and> vc C\<^sub>2 (\<lambda>s. P s \<and> \<not>bval b s)" |
+  "vc ({I} WHILE b DO C) P =
+    ((\<forall>s. (post C (\<lambda>s. I s \<and> bval b s) s \<longrightarrow> I s) \<and>
+      (P s \<longrightarrow> I s)) \<and>
+      vc C (\<lambda>s. I s \<and> bval b s))"
+
+lemma vc_sound: "vc C P \<Longrightarrow> \<turnstile> {P} strip C {post C P}"
+proof (induction C arbitrary: P)
+  case (Aassign x x2)
+  show ?case
+  proof (rule strengthen_pre; (simp, rule hoare.Assign)?; simp, intro allI impI)
+    fix s :: state
+    let ?H = "\<lambda>x'. P (s(x := x')) \<and> aval x2 s = aval x2 (s(x := x'))"
+    assume "P s"
+    then have "?H (s x)" by auto
+    from exI [of ?H, OF this]
+    show "\<exists>x'. ?H x'" by simp
+  qed
+next
+  case (Aif b C1 C2)
+  show ?case by (simp, rule hoare.If; rule weaken_post; (rule Aif(1) | rule Aif(2))?; insert Aif(3)) auto
+next
+  case (Awhile I b C)
+  let ?c = "strip C"
+  show ?case by (simp, rule strengthen_pre; (rule hoare.While, rule weaken_post; (rule Awhile(1))?)?; insert Awhile(2); auto)
+qed auto
+
+lemma post_mono: "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> post C P s \<Longrightarrow> post C P' s"
+proof (induction C arbitrary: P P' s)
+  case (Aassign x1 x2)
+  then show ?case by simp metis
+next
+  case (Aseq C1 C2)
+  then show ?case by simp metis
+next
+  case (Aif b C1 C2)
+  let ?PT = "\<lambda>P s. P s \<and> bval b s"
+  let ?PF = "\<lambda>P s. P s \<and> \<not>bval b s"
+  from Aif(3) have HT: "\<forall>s. ?PT P s \<longrightarrow> ?PT P' s" by simp
+  from Aif(3) have HF: "\<forall>s. ?PF P s \<longrightarrow> ?PF P' s" by simp
+  from Aif(4) consider (T) "post C1 (?PT P) s" | (F) "post C2 (?PF P) s" by auto
+  then show ?case
+  proof cases
+    case T
+    from Aif(1) [OF HT T] show ?thesis by simp
+  next
+    case F
+    from Aif(2) [OF HF F] show ?thesis by simp
+  qed
+qed auto
+
+lemma vc_antimono: "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> vc C P' \<Longrightarrow> vc C P"
+proof(induct C arbitrary: P P')
+  case (Aseq C1 C2) thus ?case by simp (metis post_mono)
+next
+  case (Aif b C1 C2)
+  let ?PT = "\<lambda>P s. P s \<and> bval b s"
+  let ?PF = "\<lambda>P s. P s \<and> \<not>bval b s"
+  from Aif(3) have HT: "\<forall>s. ?PT P s \<longrightarrow> ?PT P' s" by simp
+  from Aif(3) have HF: "\<forall>s. ?PF P s \<longrightarrow> ?PF P' s" by simp
+  from Aif(1) [OF HT] Aif(2) [OF HF] Aif(4) show ?case by auto
+qed simp_all
+
+lemma vc_complete: "\<turnstile> {P} c {Q}
+  \<Longrightarrow> \<exists>C. strip C = c \<and> vc C P \<and> (\<forall>s. post C P s \<longrightarrow> Q s)"
+  (is "_ \<Longrightarrow> \<exists>C. ?G P c Q C")
+proof (induct rule: hoare.induct)
+  case (Skip P)
+  show ?case (is "\<exists>C. ?C C")
+    by (rule exI [of ?C Askip], simp)
+next
+  case (Assign P a x)
+  show ?case (is "\<exists>C. ?C C")
+  proof (rule exI [of ?C "Aassign x a"], auto)
+    fix s :: state and x'
+    assume "s x = aval a (s(x := x'))"
+    then have "s(x := aval a (s(x := x'))) = s" by auto
+    moreover assume "P (s(x := aval a (s(x := x'))))"
+    ultimately show "P s" by simp
+  qed
+next
+  case (Seq P c\<^sub>1 Q c\<^sub>2 R)
+  from Seq(4) obtain C\<^sub>2 where IH2: "?G Q c\<^sub>2 R C\<^sub>2" by blast
+  from Seq(2) obtain C\<^sub>1 where IH1: "?G P c\<^sub>1 Q C\<^sub>1" by blast
+  have "?G P (c\<^sub>1;; c\<^sub>2) R (C\<^sub>1;; C\<^sub>2)"
+  proof (intro conjI)
+    from IH1 IH2 show "strip (C\<^sub>1;; C\<^sub>2) = c\<^sub>1;; c\<^sub>2" by auto
+    from IH1 IH2 show "vc (C\<^sub>1;; C\<^sub>2) P" by (fastforce elim!: post_mono vc_antimono)
+    show "\<forall>s. post (C\<^sub>1;; C\<^sub>2) P s \<longrightarrow> R s"
+    proof (intro allI)
+      fix s
+      from IH1 have "post C\<^sub>2 (post C\<^sub>1 P) s \<Longrightarrow> post C\<^sub>2 Q s" by (auto elim!: post_mono)
+      with IH2 show "post (C\<^sub>1;; C\<^sub>2) P s \<longrightarrow> R s" by auto
+    qed
+  qed
+  then show ?case by blast
+next
+  case (If P b c\<^sub>1 Q c\<^sub>2)
+  from If(2) obtain C\<^sub>1 where IH1: "?G (\<lambda>s. P s \<and> bval b s) c\<^sub>1 Q C\<^sub>1" by blast
+  from If(4) obtain C\<^sub>2 where IH2: "?G (\<lambda>s. P s \<and> \<not>bval b s) c\<^sub>2 Q C\<^sub>2" by blast
+  from IH1 IH2 have "?G P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q (IF b THEN C\<^sub>1 ELSE C\<^sub>2)" by simp
+  then show ?case by blast
+next
+  case (While P b c)
+  from While(2) obtain C where IH: "?G (\<lambda>s. P s \<and> bval b s) c P C" by blast
+  then have "?G P (WHILE b DO c) (\<lambda>s. P s \<and> \<not>bval b s) ({P} WHILE b DO C)" by auto
+  then show ?case by blast
+next
+  case (conseq P' P c Q Q')
+  from conseq(3) obtain C where HC: "strip C = c" "vc C P" "\<forall>s. post C P s \<longrightarrow> Q s" by blast+
+  from conseq(1) HC(2) have "vc C P'" by (simp add: vc_antimono)
+  moreover from conseq(1, 4) HC(3) have "\<forall>s. post C P' s \<longrightarrow> Q' s" by (simp add: post_mono vc_antimono)
+  ultimately show ?case using HC(1) by auto
+qed
+
+text  \<open>
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter12_5.thy b/Chapter12_5.thy
new file mode 100644
index 0000000..a626fef
--- /dev/null
+++ b/Chapter12_5.thy
@@ -0,0 +1,242 @@
+theory Chapter12_5
+imports "HOL-IMP.Hoare_Total"
+begin
+
+text\<open>
+\exercise
+Prove total correctness of the commands in exercises~\ref{exe:Hoare:sumeq} to
+\ref{exe:Hoare:sqrt}.
+\<close>
+
+definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
+  "Eq a1 a2 = (And (Not (Less a1 a2)) (Not (Less a2 a1)))"
+
+lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
+  unfolding Eq_def by auto
+
+lemma
+  "\<turnstile>\<^sub>t {\<lambda>s. s ''x'' = i \<and> 0 \<le> i}
+     ''y'' ::= N 0;;
+     WHILE Not(Eq (V ''x'') (N 0))
+     DO (''y'' ::= Plus (V ''y'') (V ''x'');;
+           ''x'' ::= Plus (V ''x'') (N (-1)))
+     {\<lambda>s. s ''y'' = sum i}"
+  (is "\<turnstile>\<^sub>t {?HI} ''y'' ::= ?yi;; WHILE ?bx DO (''y'' ::= ?ay;; ''x'' ::= ?ax) {?HE}")
+proof (intro Seq While_fun' allI impI; (elim conjE)?)
+  let ?ax = "Plus (V ''x'') (N (- 1))"
+  let ?ay = "Plus (V ''y'') (V ''x'')"
+  let ?P = "\<lambda>s. s ''y'' = sum i - sum (s ''x'') \<and> 0 \<le> s ''x''"
+  let ?f = "\<lambda>s::state. nat (s ''x'')"
+  let ?Pw' = "\<lambda>n s. ?P s \<and> ?f s < n"
+  let ?Q = "\<lambda>n s. ?Pw' n (s[?ax/''x''])"
+  let ?Pw = "\<lambda>n s. ?P s \<and> bval ?bx s \<and> n = ?f s"
+  let ?yi = "N 0"
+  {
+    have "\<forall>s. ?HI s \<longrightarrow> ?P (s[?yi/''y''])"
+    proof (intro allI impI, elim conjE)
+      fix s
+      assume Hxi: "s ''x'' = i"
+      then have "(s[?yi/''y'']) ''y'' = sum i - sum ((s[?yi/''y'']) ''x'')" (is ?H1) by simp
+      moreover assume Hi: "0 \<le> i"
+      with Hxi have "0 \<le> (s[?yi/''y'']) ''x''" (is ?H2) by simp
+      ultimately show "?H1 \<and> ?H2" by blast
+    qed
+    from Assign' [OF this] show "\<turnstile>\<^sub>t {?HI} ''y'' ::= ?yi {?P}" .
+  next
+    fix s
+    assume HP: "?P s"
+    assume "\<not>bval ?bx s"
+    then have "s ''x'' = 0" by simp
+    with HP show "s ''y'' = sum i" by simp
+  next
+    fix n
+    show "\<turnstile>\<^sub>t {?Q n} ''x'' ::= ?ax {?Pw' n}" by (rule Assign)
+  next
+    fix n
+    have "\<forall>s. ?Pw n s \<longrightarrow> ?Q n (s[?ay/''y''])"
+    proof (intro allI impI conjI; elim conjE)
+      fix s
+      assume assm: "s ''y'' = sum i - sum (s ''x'')" "0 \<le> s ''x''" "bval (bexp.Not (Eq (V ''x'') (N 0))) s" "n = nat (s ''x'')"
+      from assm(2, 3) have Hx0: "0 < s ''x''" by simp
+      from assm(1) have "((s[?ay/''y''])[?ax/''x'']) ''y'' = sum i - sum (s ''x'') + s ''x''" by simp
+      also from Hx0 have "\<dots> = sum i - sum (s ''x'' - 1)" by auto
+      also have "\<dots> = sum i - sum (((s[?ay/''y''])[?ax/''x'']) ''x'')" by simp
+      finally show "((s[?ay/''y''])[?ax/''x'']) ''y'' = sum i - sum (((s[?ay/''y''])[?ax/''x'']) ''x'')" .
+      from Hx0 show "0 \<le> ((s[?ay/''y''])[?ax/''x'']) ''x''" by simp
+      from Hx0 assm(4) show "?f ((s[?ay/''y''])[?ax/''x'']) < n" by auto
+    qed
+    from Assign' [OF this] show "\<turnstile>\<^sub>t {?Pw n} ''y'' ::= ?ay {?Q n}" .
+  }
+qed
+
+lemma
+  "\<turnstile>\<^sub>t {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
+     WHILE Less (N 0) (V ''x'')
+     DO (''x'' ::= Plus (V ''x'') (N (-1));; ''y'' ::= Plus (V ''y'') (N (-1)))
+     {\<lambda>t. t ''y'' = y - x}"
+proof (rule strengthen_pre; intro While_fun' Seq allI impI; (elim conjE)?)
+  let ?b = "Less (N 0) (V ''x'')"
+  let ?P = "\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x''"
+  let ?f = "\<lambda>s::state. nat(s ''x'')"
+  let ?Pw' = "\<lambda>n s. ?P s \<and> ?f s < n"
+  let ?Pw = "\<lambda>n s. ?P s \<and> bval ?b s \<and> n = ?f s"
+  let ?Qold = "\<lambda>s. s ''y'' - 1 - s ''x'' = y - x \<and> 0 \<le> s ''x''"
+  let ?ay = "Plus (V ''y'') (N (- 1))"
+  let ?ax = "Plus (V ''x'') (N (- 1))"
+  let ?Q = "\<lambda>n s. ?Pw' n (s[?ay/''y''])"
+  {
+    fix s
+    assume "s ''x'' = x" "s ''y'' = y" "0 \<le> x"
+    then show "?P s" by simp
+  next
+    fix s
+    assume "\<not> bval (Less (N 0) (V ''x'')) s"
+    then have "s ''x'' \<le> 0" by simp
+    moreover assume "?P s"
+    ultimately show "s ''y'' = y - x" by simp
+  next
+    fix n
+    show "\<turnstile>\<^sub>t {?Q n} ''y'' ::= ?ay {?Pw' n}" by (rule Assign)
+  next
+    fix n
+    have "\<forall>s. ?Pw n s \<longrightarrow> ?Q n (s[?ax/''x''])"
+    proof (intro allI impI conjI; elim conjE)
+      fix s
+      assume assm: "s ''y'' - s ''x'' = y - x" "bval (Less (N 0) (V ''x'')) s" "n = nat (s ''x'')"
+      from assm(2) have Hx0: "0 < s ''x''" by simp
+      from assm(1) show "((s[?ax/''x''])[?ay/''y'']) ''y'' - ((s[?ax/''x''])[?ay/''y'']) ''x'' = y - x" by simp
+      from Hx0 show "0 \<le> ((s[?ax/''x''])[?ay/''y'']) ''x''" by simp
+      from assm(3) Hx0 show "?f ((s[Plus (V ''x'') (N (- 1))/''x''])[Plus (V ''y'') (N (- 1))/''y'']) < n" by simp
+    qed
+    then show "\<turnstile>\<^sub>t {?Pw n} ''x'' ::= ?ax {?Q n}" by (rule Assign')
+  }
+qed
+
+lemma
+  "\<turnstile>\<^sub>t { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}
+     ''r'' ::= N 0;; ''r2'' ::= N 1;;
+     WHILE (Not (Less (V ''x'') (V ''r2'')))
+     DO (''r'' ::= Plus (V ''r'') (N 1);;
+            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
+     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
+proof (intro Seq While_fun' allI impI conjI; (elim conjE)?)
+  let ?b = "Not (Less (V ''x'') (V ''r2''))"
+  let ?ar = "Plus (V ''r'') (N 1)"
+  let ?ar2 = "Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1))"
+  let ?I = "\<lambda>s. s ''x'' = i \<and> 0 \<le> i"
+  let ?II = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> 1 = (s ''r'' + 1)\<^sup>2 \<and> 0 \<le> s ''r''"
+  let ?P = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'' + 1)\<^sup>2 \<and> 0 \<le> s ''r''"
+  let ?f = "\<lambda>s::state. nat (s ''x'' + 1 - s ''r2'')"
+  let ?Qold = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'')\<^sup>2"
+  let ?Pw' = "\<lambda>n s. ?P s \<and> ?f s < n"
+  let ?Q = "\<lambda>n s. ?Pw' n (s[?ar2/''r2''])"
+  let ?Pw = "\<lambda>n s. ?P s \<and> bval ?b s \<and> n = ?f s"
+  {
+    have "\<forall>s. ?I s \<longrightarrow> ?II (s[N 0/''r''])" by auto
+    then show "\<turnstile>\<^sub>t {?I} ''r'' ::= N 0 {?II}" by (rule Assign')
+  next
+    have "\<turnstile>\<^sub>t {\<lambda>s. ?P (s[N 1/''r2''])} ''r2'' ::= N 1 {?P}" by (rule Assign)
+    then show "\<turnstile>\<^sub>t {?II} ''r2'' ::= N 1 {?P}" by simp
+  next
+    fix s
+    assume "?P s"
+    then have H: "s ''x'' = i" "(s ''r'')\<^sup>2 \<le> s ''x''" "s ''r2'' = (s ''r'' + 1)\<^sup>2" by blast+
+    moreover assume "\<not> bval ?b s"
+    then have "s ''x'' < s ''r2''" by auto
+    ultimately show "(s ''r'')\<^sup>2 \<le> i" "i < (s ''r'' + 1)\<^sup>2" by auto
+  next
+    fix n
+    have Heqv: "\<And>x::int. (x + 1)\<^sup>2 = x\<^sup>2 + x + x + 1" by (simp add: power2_sum)
+    show "\<turnstile>\<^sub>t {?Q n} ''r2'' ::= ?ar2 {?Pw' n}" by (rule Assign)
+  next
+    fix n
+    have "\<forall>s. ?Pw n s \<longrightarrow> ?Q n (s[?ar/''r''])"
+    proof auto
+      fix s :: state
+      let ?r = "s ''r''"
+      have "(?r + 1)\<^sup>2 + (3 + 2 * ?r) = ?r\<^sup>2 + 4 * ?r + 4" by (simp add: power2_sum)
+      also have "\<dots> = (2 + ?r)\<^sup>2" by (simp add: power2_sum)
+      finally show "(?r + 1)\<^sup>2 + (3 + 2 * ?r) = (2 + ?r)\<^sup>2" .
+    qed
+    then show "\<turnstile>\<^sub>t {?Pw n} ''r'' ::= ?ar {?Q n}" by (rule Assign')
+  }
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+Modify the VCG to take termination into account. First modify type @{text acom}
+by annotating  @{text WHILE} with a measure function in addition to an
+invariant:
+\<close>
+datatype acom =
+  Askip                  ("SKIP") |
+  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
+  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
+  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
+  Awhile assn "state \<Rightarrow> nat" bexp acom
+    ("({_, _}/ WHILE _/ DO _)"  [0, 0, 61] 61)
+
+notation com.SKIP ("SKIP")
+
+fun strip :: "acom \<Rightarrow> com" where
+"strip SKIP = SKIP" |
+"strip (x ::= a) = (x ::= a)" |
+"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
+"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
+"strip ({_,_} WHILE b DO C) = (WHILE b DO strip C)"
+
+fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
+"pre SKIP Q = Q" |
+"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
+"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
+"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
+  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
+"pre ({I,f} WHILE b DO C) Q = I"
+
+fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
+"vc SKIP Q = True" |
+"vc (x ::= a) Q = True" |
+"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
+"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
+"vc ({I, f} WHILE b DO C) Q =
+  (\<forall>n. (\<forall>s. (I s \<and> bval b s \<and> n = f s \<longrightarrow> pre C (\<lambda>s. I s \<and> f s < n) s) \<and>
+        (I s \<and> \<not> bval b s \<longrightarrow> Q s)) \<and>
+    vc C (\<lambda>s. I s \<and> f s < n))"
+
+text\<open>
+Functions @{const strip} and @{const pre} remain almost unchanged.
+The only significant change is in the @{text WHILE} case for @{const vc}.
+Modify the old soundness proof to obtain
+\<close>
+
+lemmas [simp] = hoaret.Skip hoaret.Assign hoaret.Seq If
+
+lemmas [intro!] = hoaret.Skip hoaret.Assign hoaret.Seq hoaret.If
+
+lemma strengthen_pre: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s; \<turnstile>\<^sub>t {P} c {Q} \<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>t {P'} c {Q}"
+  by (blast intro: conseq)
+
+lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
+proof(induct C arbitrary: Q)
+  case (Awhile I f b C)
+  show ?case
+  proof (simp, rule While_fun')
+    from Awhile(2) show "\<forall>s. I s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
+    fix n
+    from Awhile(2) have "\<forall>s. I s \<and> bval b s \<and> n = f s \<longrightarrow> pre C (\<lambda>s. I s \<and> f s < n) s" by auto
+    moreover from Awhile(2) have "vc C (\<lambda>s. I s \<and> f s < n)" by auto
+    with Awhile(1) have "\<turnstile>\<^sub>t {pre C (\<lambda>s. I s \<and> f s < n)} strip C {\<lambda>s. I s \<and> f s < n}" by auto
+    ultimately show "\<turnstile>\<^sub>t {\<lambda>s. I s \<and> bval b s \<and> n = f s} strip C {\<lambda>s. I s \<and> f s < n}" by (rule strengthen_pre)
+  qed
+qed (auto intro: hoaret.conseq)
+
+text\<open>
+You may need the combined soundness and completeness of @{text"\<turnstile>\<^sub>t"}:
+@{thm hoaret_sc}
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter13_3.thy b/Chapter13_3.thy
new file mode 100644
index 0000000..d42306a
--- /dev/null
+++ b/Chapter13_3.thy
@@ -0,0 +1,16 @@
+theory Chapter13_3
+imports "HOL-IMP.Collecting_Examples"
+begin
+
+definition cex :: com where "cex =
+  ''x'' ::= N 0;; ''y'' ::= N 2;;
+  WHILE Less (N 0) (V ''y'')
+  DO (''x'' ::= Plus (V ''x'') (V ''y'');;
+      ''y'' ::= Plus (V ''y'') (N (-1)))"
+
+definition Cex :: "state set acom" where "Cex = annotate (\<lambda>p. {}) cex"
+
+value "show_acom ((step {<>} ^^ 12) Cex)"
+
+end
+
diff --git a/Chapter13_3_additional.thy b/Chapter13_3_additional.thy
new file mode 100644
index 0000000..7a556bc
--- /dev/null
+++ b/Chapter13_3_additional.thy
@@ -0,0 +1,103 @@
+theory Chapter13_3_additional
+  imports "HOL-IMP.Complete_Lattice"
+begin
+
+text \<open>
+Exercise 13.1
+
+0:
+  A0: {}
+  A1: {}
+  A2: {}
+  A3: {}
+  A4: {}
+
+1:
+  A0: {<x:=0,y:=2>}
+
+2:
+  A1: {<x:=0,y:=2>}
+
+3:
+  A2: {<x:=0,y:=2>}
+
+4:
+  A3: {<x:=2,y:=1>}
+
+5:
+  A2: {<x:=0,y:=2>, <x:=2,y:=1>}
+
+6:
+  A3: {<x:=2,y:=1>, <x:=3,y:=0>}
+
+7:
+  A4: {<x:=3,y:=0>}
+
+8:
+  Fixpoint reached
+
+Exercise 13.3
+\<close>
+
+context Complete_Lattice
+begin
+
+definition Lub :: "'a set \<Rightarrow> 'a" where
+  "Lub S = Glb {u\<in>L. \<forall>s\<in>S. s \<le> u}"
+
+theorem Lub_greater: "\<lbrakk>A \<subseteq> L; a \<in> A\<rbrakk> \<Longrightarrow> a \<le> Lub A"
+  unfolding Lub_def by (auto intro!: Glb_greatest)
+
+theorem Lub_least: "\<lbrakk>b \<in> L; \<forall>a\<in>A. a \<le> b\<rbrakk> \<Longrightarrow> Lub A \<le> b"
+  unfolding Lub_def by (auto intro!: Glb_lower)
+
+theorem Lub_in_L: "\<lbrakk>A \<subseteq> L\<rbrakk> \<Longrightarrow> Lub A \<in> L"
+  unfolding Lub_def by (auto intro!: Glb_in_L)
+
+end
+
+text \<open>
+Exercise 13.4: The flaw in the argument is that there is no least element
+in the empty set. More generally, there is no greatest lower bound of the
+empty set. For if n is a lower bound of the empty set, then Suc n is a
+greater lower bound of the empty set.
+\<close>
+
+text \<open>13.5: -Inf is a lower bound of any set of extended integers.
+Every number that is not -Inf is an integer or +Inf, and either of these
+are greater than -Inf. If a set does not have an integer glb, or has +Inf as their glb, then -Inf is
+the greatest among its lower bounds.\<close>
+
+text \<open>13.6:
+
+Let P be a set of pre-fixpoints in a complete lattice.
+Show that m = \<Sqinter>P is a pre-fixpoint.
+
+Proof is the same as in 10.27. First, for all p \<in> P, we have
+m \<le> p. By monotonicity, f m \<le> f p, and by pre-fixpoint property of p,
+f p \<le> p. So f m is a lower bound of p. Since m is the greatest lower bound,
+we have f m \<le> m. Thus m is a pre-fixpoint under f.
+
+13.7.1:
+Consider f: x \<mapsto> x - 1 on Z. Then f is monotone and each n is a pre-fixpoint,
+but not a fixpoint.
+
+13.7.2:
+Consider the order with basis {a<b, b<c} on {a, b, c, d}. Then c and d are
+both least fixpoints, but the pre-fixpoints are b, c, d, so that b and d
+are least pre-fixpoints
+
+13.8:
+We show that P is a least fixpoint of f iff P is a least fixpoint of g = \<lambda>S. S \<union> f S. Then
+the least fixpoint of f is also the least fixpoint of g.
+
+First, if f P = P, we have g P = P \<union> f P = P \<union> P = P, so that
+P is a fixpoint of g. So the least fixpoint of g is weakly less than the
+least fixpoint of f.
+
+Suppose that P is the least fixpoint of g. From g P = P we have P = P \<union> f P, so must have
+f P \<subseteq> P. By Theorem 10.29, since f is monotone, the lfp of P is weakly less than P as well,
+that is, the least fixpoint of f is weakly less than the least fixpoint of f.
+
+By antisymmetry, we have lfp f = lfp g.
+\<close>
diff --git a/Chapter13_4.thy b/Chapter13_4.thy
new file mode 100644
index 0000000..dfe779f
--- /dev/null
+++ b/Chapter13_4.thy
@@ -0,0 +1,14 @@
+theory Chapter13_4
+  imports "HOL-IMP.Complete_Lattice"
+begin
+
+text \<open>
+Exercise 13.9
+
+to show: x \<squnion> y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z
+
+Assume x \<squnion> y \<le> z. With x \<le> x \<squnion> y and y \<le> x \<squnion> y, we have
+x \<le> z and y \<le> z.
+
+The other direction follows by definition of leastness.
+\<close>
\ No newline at end of file
diff --git a/Chapter13_5.thy b/Chapter13_5.thy
new file mode 100644
index 0000000..ec50f26
--- /dev/null
+++ b/Chapter13_5.thy
@@ -0,0 +1,116 @@
+theory Chapter13_5
+imports Main "HOL-Library.Lattice_Syntax"
+begin
+
+text \<open>
+0:
+  A1: None
+  A2: None
+  A3: None
+  A4: None
+  A5: None
+
+1:
+  A1: Odd
+
+2:
+  A2: Odd
+
+3:
+  A3: Odd
+
+4:
+  A4: Even
+
+5:
+  A2: Either
+
+6:
+  A3: Either
+  A5: Either
+
+7:
+  A4: Either
+
+8:
+  No change
+\<close>
+
+text\<open>
+\setcounter{exercise}{10}
+
+\begin{exercise}
+Take the Isabelle theories that define commands, big-step semantics,
+annotated commands and the collecting semantics and extend them with a
+nondeterministic choice construct. Start with Exercise~\ref{exe:IMP:OR}
+and extend type @{text com}, then extend type @{text acom} with a
+corresponding construct:
+\begin{alltt}
+  Or "'a acom" "'a acom" 'a     ("_ OR// _//{_}"  [60, 61, 0] 60)
+\end{alltt}
+Finally extend function @{text Step}. Update proofs as well.
+Hint: think of @{text OR} as a nondeterministic conditional without a test.
+\end{exercise}
+
+\exercise
+Prove the following lemmas in a detailed and readable style:
+\<close>
+
+lemma fixes x0 :: "'a :: order"
+assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y"  and  "f q \<le> q"  and  "x0 \<le> q"
+shows "(f ^^ i) x0 \<le> q"
+proof (induction i)
+  case 0
+  then show ?case by (auto simp add: assms(3))
+next
+  case (Suc i)
+  have "(f ^^ Suc i) x0 = f ((f ^^ i) x0)" by auto
+  also have "\<dots> \<le> f q" by (auto intro!: assms(1) simp add: Suc)
+  also from assms(2) have "\<dots> \<le> q" .
+  finally show ?case .
+qed
+
+
+lemma fixes x0 :: "'a :: order"
+assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y" and "x0 \<le> f x0"
+shows "(f ^^ i) x0 \<le> (f ^^ (i+1)) x0"
+proof (induction i)
+case 0
+  then show ?case by (auto simp add: assms(2))
+next
+  case (Suc i)
+  have "(f ^^ Suc i) x0 = f ((f ^^ i) x0)" by auto
+  also have "\<dots> \<le> f ((f ^^ (i + 1)) x0)" by (intro assms(1), rule Suc)
+  also have "\<dots> = (f ^^ (Suc i + 1)) x0" by auto
+  finally show ?case .
+qed
+
+text\<open>
+\endexercise
+
+\exercise% needs Lattice_Syntax
+Let @{typ 'a} be a complete lattice and
+let @{text "f :: 'a \<Rightarrow> 'a"} be a monotone function.
+Give a readable proof that if @{text P} is a set of pre-fixpoints of @{text f}
+then @{text"\<Sqinter>P"} is also a pre-fixpoint of @{text f}:
+\<close>
+
+lemma fixes P :: "'a::complete_lattice set"
+assumes "mono f" and "\<forall>p \<in> P. f p \<le> p"
+shows "f(\<Sqinter> P) \<le> \<Sqinter> P" (is "f ?m \<le> ?m")
+proof (intro Inf_greatest)
+  fix p
+  assume Hp: "p \<in> P"
+  then have "?m \<le> p" by (rule Inf_lower)
+  with assms(1) have "f ?m \<le> f p" unfolding mono_def by simp
+  also from Hp assms(2) have "f p \<le> p" by simp
+  finally show "f ?m \<le> p" .
+qed
+
+text\<open>
+Sledgehammer should give you a proof you can start from.
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter13_7.thy b/Chapter13_7.thy
new file mode 100644
index 0000000..f7e0ee4
--- /dev/null
+++ b/Chapter13_7.thy
@@ -0,0 +1,94 @@
+theory Chapter13_7
+imports "HOL-IMP.Abs_Int2"
+begin
+
+text\<open>
+\setcounter{exercise}{15}
+\exercise
+Give a readable proof that if @{text "\<gamma> ::"} \noquotes{@{typ[source]"'a::lattice \<Rightarrow> 'b::lattice"}}
+is a monotone function, then @{prop "\<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2) \<le> \<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2"}:
+\<close>
+
+lemma fixes \<gamma> :: "'a::lattice \<Rightarrow> 'b :: lattice"
+assumes mono: "\<And>x y. x \<le> y \<Longrightarrow> \<gamma> x \<le> \<gamma> y"
+shows "\<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2) \<le> \<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2" (is "\<gamma> ?m \<le> _")
+proof -
+  have "\<gamma> ?m \<le> \<gamma> a\<^sub>1" by (intro mono, auto)
+  moreover 
+  have "\<gamma> ?m \<le> \<gamma> a\<^sub>2" by (intro mono, auto)
+  ultimately show ?thesis by simp
+qed
+
+text\<open>
+Give an example of two lattices and a monotone @{text \<gamma>}
+where @{prop"\<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2 \<le> \<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2)"} does not hold.
+
+Consider {a, c, t, b} of unique elements with order generated by t being top and b being bottom.
+Let f be identity with codomain {a, c, d, t, b} of unique elements, with order generated by t
+being top, b being bottom, and "d \<le> a", "d \<le> c".
+then \<gamma> (a \<sqinter> c) = b < d = \<gamma> a \<sqinter> \<gamma> c.
+\<close>
+
+text\<open>
+\endexercise
+
+\exercise
+Consider a simple sign analysis based on this abstract domain:
+\<close>
+
+datatype sign = None | Neg | Pos0 | Any
+
+fun \<gamma> :: "sign \<Rightarrow> val set" where
+"\<gamma> None = {}" |
+"\<gamma> Neg = {i. i < 0}" |
+"\<gamma> Pos0 = {i. i \<ge> 0}" |
+"\<gamma> Any = UNIV"
+
+text\<open>
+Define inverse analyses for ``@{text"+"}'' and ``@{text"<"}''
+and prove the required correctness properties:
+\<close>
+
+fun inv_plus' :: "sign \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign" where
+  "inv_plus' None _ _ = (None, None)" |
+  "inv_plus' _ None _ = (None, None)" |
+  "inv_plus' _ _ None = (None, None)" |
+  "inv_plus' Neg Pos0 Pos0 = (None, None)" |
+  "inv_plus' Pos0 Neg Neg = (None, None)" |
+  "inv_plus' Neg Pos0 Any = (Pos0, Neg)" |
+  "inv_plus' Neg Any Pos0 = (Neg, Pos0)" |
+  "inv_plus' Pos0 Neg Any = (Neg, Pos0)" |
+  "inv_plus' Pos0 Any Neg = (Pos0, Neg)" |
+  "inv_plus' _ a b = (a, b)"
+
+lemma
+  "\<lbrakk> inv_plus' a a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; i1+i2 \<in> \<gamma> a \<rbrakk>
+  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2' "
+  by (cases a; cases a1; cases a2) auto
+
+fun inv_less' :: "bool \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign" where
+  "inv_less' _ None _ = (None, None)" |
+  "inv_less' _ _ None = (None, None)" |
+  "inv_less' True Pos0 Neg = (None, None)" |
+  "inv_less' False Neg Pos0 = (None, None)" |
+  "inv_less' True Pos0 Any = (Pos0, Pos0)" |
+  "inv_less' True Any Neg = (Neg, Neg)" |
+  "inv_less' False Neg Any = (Neg, Neg)" |
+  "inv_less' False Any Pos0 = (Pos0, Pos0)" |
+  "inv_less' _ a b = (a, b)"
+
+lemma
+  "\<lbrakk> inv_less' bv a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; (i1<i2) = bv \<rbrakk>
+  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2'"
+  by (cases bv; cases a1; cases a2) auto
+
+text\<open>
+\indent
+For the ambitious: turn the above fragment into a full-blown abstract interpreter
+by replacing the interval analysis in theory @{theory "HOL-IMP.Abs_Int2"}@{text"_ivl"}
+by a sign analysis.
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter13_9.thy b/Chapter13_9.thy
new file mode 100644
index 0000000..9276a3a
--- /dev/null
+++ b/Chapter13_9.thy
@@ -0,0 +1,13 @@
+theory Chapter13_9
+imports "HOL-IMP.Abs_Int3"
+begin
+
+(* 13.19 *)
+value "show_acom (step_up_ivl 3 (steps test3_ivl 4))"
+
+(* 13.20 *)
+value "show_acom ((step_ivl \<top> ^^ 4) (step_up_ivl 3 (steps test3_ivl 4)))"
+value "show_acom (step_down_ivl 4 (step_up_ivl 3 (steps test3_ivl 4)))"
+
+end
+
diff --git a/Chapter2.thy b/Chapter2.thy
new file mode 100644
index 0000000..6d3795b
--- /dev/null
+++ b/Chapter2.thy
@@ -0,0 +1,394 @@
+theory Chapter2
+imports Main
+begin
+
+text \<open>
+\section*{Chapter 2}
+
+\exercise
+Use the \textbf{value} command to evaluate the following expressions:
+\<close>
+
+value "1 + (2::nat)"
+value "1 + (2::int)"
+value "1 - (2::nat)"
+value "1 - (2::int)"
+value "[a,b] @ [c,d]"
+
+text \<open>
+\endexercise
+
+
+\exercise
+Recall the definition of our own addition function on @{typ nat}:
+\<close>
+
+fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+"add 0 n = n" |
+"add (Suc m) n = Suc(add m n)"
+
+text \<open>
+Prove that @{const add} is associative and commutative.
+You will need additional lemmas.
+\<close>
+
+lemma add_assoc: "add (add m n) p = add m (add n p)"
+  apply (induction m)
+   apply auto
+  done
+
+
+lemma add_nil2 [simp]: "add m 0 = m"
+  apply (induction m)
+   apply auto
+  done
+
+lemma add_Suc2 [simp]: "add m (Suc n) = Suc (add m n)"
+  apply (induction m)
+   apply auto
+  done
+
+lemma add_comm: "add m n = add n m"
+  apply (induction m)
+   apply auto
+  done
+
+text \<open> Define a recursive function \<close>
+
+fun double :: "nat \<Rightarrow> nat" where
+  "double 0 = 0" |
+  "double (Suc n) = Suc (Suc (double n))"
+
+text \<open> and prove that \<close>
+
+lemma double_add: "double m = add m m"
+  apply (induction m)
+   apply auto
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise
+Define a function that counts the number of occurrences of
+an element in a list:
+\<close>
+
+fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
+  "count [] _ = 0" |
+  "count (x # xs) y = (if x = y then Suc (count xs y) else count xs y)"
+
+text \<open>
+Test your definition of @{term count} on some examples.
+Prove the following inequality:
+\<close>
+
+theorem "count xs x \<le> length xs"
+  apply (induction xs)
+   apply auto
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise
+Define a function @{text snoc} that appends an element to the end of a list.
+Do not use the existing append operator @{text "@"} for lists.
+\<close>
+
+fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
+  "snoc [] a = [a]" |
+  "snoc (x # xs) a = x # snoc xs a"
+
+text \<open>
+Convince yourself on some test cases that your definition
+of @{term snoc} behaves as expected.
+With the help of @{text snoc} define a recursive function @{text reverse}
+that reverses a list. Do not use the predefined function @{const rev}.
+\<close>
+
+fun reverse :: "'a list \<Rightarrow> 'a list" where
+  "reverse [] = []" |
+  "reverse (x # xs) = snoc (reverse xs) x"
+
+text \<open>
+Prove the following theorem. You will need an additional lemma.
+\<close>
+lemma reverse_snoc [simp]: "reverse (snoc xs x) = x # reverse xs"
+  apply (induction xs)
+   apply auto
+  done
+
+theorem "reverse (reverse xs) = xs"
+  apply (induction xs)
+   apply auto
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise
+The aim of this exercise is to prove the summation formula
+\[ \sum_{i=0}^{n}i = \frac{n(n+1)}{2} \]
+Define a recursive function @{text "sum_upto n = 0 + ... + n"}:
+\<close>
+
+fun sum_upto :: "nat \<Rightarrow> nat" where
+  "sum_upto 0 = 0" |
+  "sum_upto (Suc n) = (Suc n) + (sum_upto n)"
+
+text \<open>
+Now prove the summation formula by induction on @{text "n"}.
+First, write a clear but informal proof by hand following the examples
+in the main text. Then prove the same property in Isabelle:
+\<close>
+
+lemma "sum_upto n = n * (n+1) div 2"
+  apply (induction n)
+   apply auto
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise
+Starting from the type @{text "'a tree"} defined in the text, define
+a function that collects all values in a tree in a list, in any order,
+without removing duplicates.
+\<close>
+
+datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
+
+fun contents :: "'a tree \<Rightarrow> 'a list" where
+  "contents Tip = []" |
+  "contents (Node l x r) = x # contents l @ contents r"
+
+text \<open>
+Then define a function that sums up all values in a tree of natural numbers
+\<close>
+
+fun sum_tree :: "nat tree \<Rightarrow> nat" where
+  "sum_tree Tip = 0" |
+  "sum_tree (Node l n r) = n + sum_tree l + sum_tree r"
+
+text \<open> and prove \<close>
+
+lemma "sum_tree t = sum_list(contents t)"
+  apply (induction t)
+   apply auto
+  done
+
+text \<open>
+\endexercise
+
+\exercise
+Define a new type @{text "'a tree2"} of binary trees where values are also
+stored in the leaves of the tree.  Also reformulate the
+@{text mirror} function accordingly. Define two functions \<close>
+
+datatype 'a tree2 = Tip 'a | Node "'a tree2" 'a "'a tree2"
+
+primrec mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
+  "mirror (Tip a) = (Tip a)" |
+  "mirror (Node l a r) = Node (mirror r) a (mirror l)"
+
+fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
+  "pre_order (Tip a) = [a]" |
+  "pre_order (Node l a r) = a # pre_order l @ pre_order r"
+
+fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
+  "post_order (Tip a) = [a]" |
+  "post_order (Node l a r) = post_order l @ post_order r @ [a]"
+
+text \<open>
+that traverse a tree and collect all stored values in the respective order in
+a list. Prove \<close>
+
+lemma "pre_order (mirror t) = rev (post_order t)"
+  apply (induction t)
+   apply auto
+  done
+
+text \<open>
+\endexercise
+
+\exercise
+Define a recursive function
+\<close>
+
+fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+  "intersperse _ [] = []" |
+  "intersperse _ [x] = [x]" |
+  "intersperse a (x # xs) = x # a # intersperse a xs"
+
+text \<open>
+such that @{text "intersperse a [x\<^sub>1, ..., x\<^sub>n] = [x\<^sub>1, a, x\<^sub>2, a, ..., a, x\<^sub>n]"}.
+Prove
+\<close>
+
+lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
+  apply (induction xs rule: intersperse.induct)
+    apply auto
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise
+Write a tail-recursive variant of the @{text add} function on @{typ nat}:
+\<close>
+
+fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "itadd m 0 = m" |
+  "itadd m (Suc n) = itadd (Suc m) n"
+
+text \<open>
+Tail-recursive means that in the recursive case, @{const itadd} needs to call
+itself directly: \mbox{@{term"itadd (Suc m) n"}} @{text"= itadd \<dots>"}.
+Prove
+\<close>
+
+lemma "itadd m (Suc n) = Suc (add m n)"
+  apply (induction n arbitrary: m)
+   apply auto
+  done
+
+lemma "itadd m n = add m n"
+  apply (induction n arbitrary: m)
+   apply auto
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise\label{exe:tree0}
+Define a datatype @{text tree0} of binary tree skeletons which do not store
+any information, neither in the inner nodes nor in the leaves.
+Define a function that counts the number of all nodes (inner nodes and leaves)
+in such a tree:
+\<close>
+
+datatype tree0 = Tip | Node "tree0" "tree0"
+
+fun nodes :: "tree0 \<Rightarrow> nat" where
+  "nodes Tip = 1" |
+  "nodes (Node l r) = 1 + nodes l + nodes r"
+
+text \<open>
+Consider the following recursive function:
+\<close>
+
+fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
+"explode 0 t = t" |
+"explode (Suc n) t = explode n (Node t t)"
+
+text \<open>
+Experiment how @{text explode} influences the size of a binary tree
+and find an equation expressing the size of a tree after exploding it
+(\noquotes{@{term [source] "nodes (explode n t)"}}) as a function
+of @{term "nodes t"} and @{text n}. Prove your equation.
+You may use the usual arithmetic operations including the exponentiation
+operator ``@{text"^"}''. For example, \noquotes{@{prop [source] "2 ^ 2 = 4"}}.
+
+Hint: simplifying with the list of theorems @{thm[source] algebra_simps}
+takes care of common algebraic properties of the arithmetic operators.
+\endexercise
+\<close>
+
+lemma "nodes (explode n t) = (2 ^ n - 1) + (2 ^ n) * nodes t"
+  apply (induction n arbitrary: t)
+   apply (simp_all add: algebra_simps)
+  done
+
+text \<open>
+
+\exercise
+Define arithmetic expressions in one variable over integers (type @{typ int})
+as a data type:
+\<close>
+
+datatype exp = Var | Const int | Add exp exp | Mult exp exp
+
+text \<open>
+Define a function @{text eval} that evaluates an expression at some value:
+\<close>
+
+fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
+  "eval Var x = x" |
+  "eval (Const c) _ = c" |
+  "eval (Add a b) x = eval a x + eval b x" |
+  "eval (Mult a b) x = eval a x * eval b x"
+
+text \<open>
+For example, @{prop "eval (Add (Mult (Const 2) Var) (Const 3)) i = 2*i+3"}.
+
+A polynomial can be represented as a list of coefficients, starting with
+the constant. For example, @{term "[4, 2, -1, 3::int]"} represents the
+polynomial $4 + 2x - x^2 + 3x^3$.
+Define a function @{text evalp} that evaluates a polynomial at a given value:
+\<close>
+
+fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
+  "evalp [] x = 0" |
+  "evalp (a # as) x = a + x * evalp as x"
+
+text \<open>
+Define a function @{text coeffs} that transforms an expression into a polynomial.
+This will require auxiliary functions.
+\<close>
+
+fun add_list :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
+  "add_list [] ys = ys" |
+  "add_list xs [] = xs" |
+  "add_list (x # xs) (y # ys) = (x + y) # add_list xs ys"
+
+lemma [simp]: "evalp (add_list a b) x = evalp a x + evalp b x"
+  apply (induction a b rule: add_list.induct)
+    apply (auto simp add: algebra_simps)
+  done
+
+definition mul_c_list :: "int list \<Rightarrow> int \<Rightarrow> int list" where
+  "mul_c_list a c = map ((*) c) a"
+
+lemma [simp]: "evalp (mul_c_list a c) x = c * evalp a x"
+  apply (induction a)
+   apply (auto simp add: mul_c_list_def algebra_simps)
+  done
+
+primrec mul_list :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
+  "mul_list [] ys = []" |
+  "mul_list (x # xs) ys = add_list (mul_c_list ys x) (0 # mul_list xs ys)"
+
+lemma [simp]: "evalp (mul_list a b) x = evalp a x * evalp b x"
+  apply (induction a arbitrary: b)
+   apply (auto simp add: algebra_simps)
+  done
+
+fun coeffs :: "exp \<Rightarrow> int list" where
+  "coeffs Var = [0, 1]" |
+  "coeffs (Const c) = [c]" |
+  "coeffs (Add a b) = add_list (coeffs a) (coeffs b)" |
+  "coeffs (Mult a b) = mul_list (coeffs a) (coeffs b)"
+
+text \<open>
+Prove that @{text coeffs} preserves the value of the expression:
+\<close>
+
+theorem evalp_coeffs: "evalp (coeffs e) x = eval e x"
+  apply (induction e)
+     apply auto
+  done
+
+text \<open>
+Hint: consider the hint in Exercise~\ref{exe:tree0}.
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter3.thy b/Chapter3.thy
new file mode 100644
index 0000000..b69e8f7
--- /dev/null
+++ b/Chapter3.thy
@@ -0,0 +1,562 @@
+theory Chapter3
+imports "HOL-IMP.BExp"
+        "HOL-IMP.ASM"
+        (*"Short_Theory_AExp"*)
+        (*"Short_Theory_ASM"*)
+begin
+
+text \<open>
+\section*{Chapter 3}
+
+\exercise
+To show that @{const asimp_const} really folds all subexpressions of the form
+@{term "Plus (N i) (N j)"}, define a function
+\<close>
+
+fun optimal :: "aexp \<Rightarrow> bool" where
+  "optimal (N i) = True" |
+  "optimal (V x) = True" |
+  "optimal (Plus (N i) (N j)) = False" |
+  "optimal (Plus a\<^sub>1 a\<^sub>2) \<longleftrightarrow> optimal a\<^sub>1 \<and> optimal a\<^sub>2"
+
+text \<open>
+that checks that its argument does not contain a subexpression of the form
+@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
+is optimal:
+\<close>
+
+lemma "optimal (asimp_const a)"
+  apply (induction a)
+    apply (auto split: aexp.split)
+  done
+
+text \<open>
+This proof needs the same @{text "split:"} directive as the correctness proof of
+@{const asimp_const}. This increases the chance of nontermination
+of the simplifier. Therefore @{const optimal} should be defined purely by
+pattern matching on the left-hand side,
+without @{text case} expressions on the right-hand side.
+\endexercise
+
+
+\exercise
+In this exercise we verify constant folding for @{typ aexp}
+where we sum up all constants, even if they are not next to each other.
+For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
+@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
+Below we follow a particular solution strategy but there are many others.
+
+First, define a function @{text sumN} that returns the sum of all
+constants in an expression and a function @{text zeroN} that replaces all
+constants in an expression by zeroes (they will be optimized away later):
+\<close>
+
+fun sumN :: "aexp \<Rightarrow> int" where
+  "sumN (N i) = i" |
+  "sumN (V x) = 0" |
+  "sumN (Plus a\<^sub>1 a\<^sub>2) = sumN a\<^sub>1 + sumN a\<^sub>2"
+
+fun zeroN :: "aexp \<Rightarrow> aexp" where
+  "zeroN (N i) = N 0" |
+  "zeroN (V x) = V x" |
+  "zeroN (Plus a\<^sub>1 a\<^sub>2) = Plus (zeroN a\<^sub>1) (zeroN a\<^sub>2)"
+
+text \<open>
+Next, define a function @{text sepN} that produces an arithmetic expression
+that adds the results of @{const sumN} and @{const zeroN}. Prove that
+@{text sepN} preserves the value of an expression.
+\<close>
+
+definition sepN :: "aexp \<Rightarrow> aexp" where
+  "sepN a = Plus (zeroN a) (N (sumN a))"
+
+lemma aval_sepN: "aval (sepN t) s = aval t s"
+  apply (induction t)
+    apply (auto simp add: sepN_def)
+  done
+
+text \<open>
+Finally, define a function @{text full_asimp} that uses @{const asimp}
+to eliminate the zeroes left over by @{const sepN}.
+Prove that it preserves the value of an arithmetic expression.
+\<close>
+
+definition full_asimp :: "aexp \<Rightarrow> aexp" where
+  "full_asimp t = asimp (sepN t)"
+
+lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
+  apply (simp add: full_asimp_def aval_sepN)
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise\label{exe:subst}
+Substitution is the process of replacing a variable
+by an expression in an expression. Define a substitution function
+\<close>
+
+fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
+  "subst _ _ (N i) = N i" |
+  "subst x a (V y) = (if x = y then a else V y)" |
+  "subst x a (Plus e\<^sub>1 e\<^sub>2) = Plus (subst x a e\<^sub>1) (subst x a e\<^sub>2)"
+
+text \<open>
+such that @{term "subst x a e"} is the result of replacing
+every occurrence of variable @{text x} by @{text a} in @{text e}.
+For example:
+@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}
+
+Prove the so-called \concept{substitution lemma} that says that we can either
+substitute first and evaluate afterwards or evaluate with an updated state:
+\<close>
+
+lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
+  apply (induction e)
+    apply auto
+  done
+
+text \<open>
+As a consequence prove that we can substitute equal expressions by equal expressions
+and obtain the same result under evaluation:
+\<close>
+lemma "aval a1 s = aval a2 s
+  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
+  apply (auto simp add: subst_lemma)
+  done
+
+text \<open>
+\endexercise
+
+\exercise
+Take a copy of theory @{text "AExp"} and modify it as follows.
+Extend type @{typ aexp} with a binary constructor @{text Times} that
+represents multiplication. Modify the definition of the functions @{const aval}
+and @{const asimp} accordingly. You can remove @{const asimp_const}.
+Function @{const asimp} should eliminate 0 and 1 from multiplications
+as well as evaluate constant subterms. Update all proofs concerned.
+\<close>
+
+(* See Short_Theory.thy *)
+
+text \<open>
+\endexercise
+
+\exercise
+Define a datatype @{text aexp2} of extended arithmetic expressions that has,
+in addition to the constructors of @{typ aexp}, a constructor for
+modelling a C-like post-increment operation $x{++}$, where $x$ must be a
+variable. Define an evaluation function @{text "aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state"}
+that returns both the value of the expression and the new state.
+The latter is required because post-increment changes the state.
+
+Extend @{text aexp2} and @{text aval2} with a division operation. Model partiality of
+division by changing the return type of @{text aval2} to
+@{typ "(val \<times> state) option"}. In case of division by 0 let @{text aval2}
+return @{const None}. Division on @{typ int} is the infix @{text div}.
+ \<close>
+
+datatype aexp2 = N2 int | V2  vname | Plus2 aexp2 aexp2 | PIncr2 vname | Divide2 aexp2 aexp2
+
+fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
+  "aval2 (N2 i) s = Some (i, s)" |
+  "aval2 (V2 x) s = Some (s x, s)" |
+  "aval2 (Plus2 a\<^sub>1 a\<^sub>2) s =
+    (case aval2 a\<^sub>2 s of
+      Some (v\<^sub>2, s\<^sub>2) \<Rightarrow>
+        (case (aval2 a\<^sub>1 s, aval2 a\<^sub>1 s\<^sub>2) of
+          (Some (v\<^sub>1, _), Some (_, s\<^sub>1)) \<Rightarrow> Some (v\<^sub>1 + v\<^sub>2, s\<^sub>1) |
+          (_, _) \<Rightarrow> None) |
+      _ \<Rightarrow> None)" |
+  "aval2 (PIncr2 x) s = Some (s x, s (x := s x + 1))" |
+  "aval2 (Divide2 a\<^sub>1 a\<^sub>2) s =
+    (case aval2 a\<^sub>2 s of
+      Some (v\<^sub>2, s\<^sub>2) \<Rightarrow>
+        (if v\<^sub>2 = 0 then None else
+          case (aval2 a\<^sub>1 s, aval2 a\<^sub>1 s\<^sub>2) of
+            (Some (v\<^sub>1, _), Some (_, s\<^sub>1)) \<Rightarrow> Some (v\<^sub>1 div v\<^sub>2, s\<^sub>1) |
+            (_, _) \<Rightarrow> None) |
+      _ \<Rightarrow> None)"
+
+text \<open>
+\endexercise
+
+\exercise
+The following type adds a @{text LET} construct to arithmetic expressions:
+ \<close>
+
+datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp
+
+text \<open> The @{const LET} constructor introduces a local variable:
+the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of @{text e\<^sub>2}
+in the state where @{text x} is bound to the value of @{text e\<^sub>1} in the original state.
+Define a function @{text lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
+that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.
+
+Define a conversion @{text inline} @{text"::"} @{typ "lexp \<Rightarrow> aexp"}.
+The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
+the converted form of @{text e\<^sub>1} for @{text x} in the converted form of @{text e\<^sub>2}.
+See Exercise~\ref{exe:subst} for more on substitution.
+Prove that @{text inline} is correct w.r.t.\ evaluation.
+ \<close>
+
+fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
+  "lval (Nl i) _ = i" |
+  "lval (Vl x) s = s x" |
+  "lval (Plusl e\<^sub>1 e\<^sub>2) s = lval e\<^sub>1 s + lval e\<^sub>2 s" |
+  "lval (LET x e\<^sub>1 e\<^sub>2) s = lval e\<^sub>2 (s (x := lval e\<^sub>1 s))"
+
+fun inline :: "lexp \<Rightarrow> aexp" where
+  "inline (Nl i) = N i" |
+  "inline (Vl x) = V x" |
+  "inline (Plusl e\<^sub>1 e\<^sub>2) = Plus (inline e\<^sub>1) (inline e\<^sub>2)" |
+  "inline (LET x e\<^sub>1 e\<^sub>2) = subst x (inline e\<^sub>1) (inline e\<^sub>2)"
+
+lemma "aval (inline e) s = lval e s"
+  apply (induction e arbitrary: s)
+     apply (auto simp add: subst_lemma)
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise
+Show that equality and less-or-equal tests on @{text aexp} are definable
+ \<close>
+
+definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
+  "Le a\<^sub>1 a\<^sub>2 = Not (Less a\<^sub>2 a\<^sub>1)"
+
+definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
+  "Eq a\<^sub>1 a\<^sub>2 = And (Le a\<^sub>1 a\<^sub>2) (Le a\<^sub>2 a\<^sub>1)"
+
+text \<open>
+and prove that they do what they are supposed to:
+ \<close>
+
+lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
+  apply (induction a1 arbitrary: a2)
+    apply (auto simp add: Le_def)
+  done
+
+lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
+  apply (induction a1 arbitrary: a2)
+    apply (auto simp add: Eq_def Le_def)
+  done
+
+text \<open>
+\endexercise
+
+\exercise
+Consider an alternative type of boolean expressions featuring a conditional:  \<close>
+
+datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp
+
+text  \<open>  First define an evaluation function analogously to @{const bval}:  \<close>
+
+fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
+  "ifval (Bc2 b) _ = b" |
+  "ifval (If e\<^sub>1 e\<^sub>2 e\<^sub>3) s = (if ifval e\<^sub>1 s then ifval e\<^sub>2 s else ifval e\<^sub>3 s)" |
+  "ifval (Less2 a\<^sub>1 a\<^sub>2) s \<longleftrightarrow> aval a\<^sub>1 s < aval a\<^sub>2 s"
+(* your definition/proof here *)
+
+text \<open> Then define two translation functions  \<close>
+
+fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
+  "b2ifexp (Bc v) = Bc2 v" |
+  "b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)" |
+  "b2ifexp (And b\<^sub>1 b\<^sub>2) = If (b2ifexp b\<^sub>1) (b2ifexp b\<^sub>2) (Bc2 False)" |
+  "b2ifexp (Less a\<^sub>1 a\<^sub>2) = Less2 a\<^sub>1 a\<^sub>2"
+
+fun if2bexp :: "ifexp \<Rightarrow> bexp" where
+  "if2bexp (Bc2 v) = Bc v" |
+  "if2bexp (If e\<^sub>1 e\<^sub>2 e\<^sub>3) =
+  Not (And (Not (And (if2bexp e\<^sub>1) (if2bexp e\<^sub>2))) (Not (And (Not (if2bexp e\<^sub>1)) (if2bexp e\<^sub>3))))" |
+  "if2bexp (Less2 a\<^sub>1 a\<^sub>2) = Less a\<^sub>1 a\<^sub>2"
+
+text \<open> and prove their correctness:  \<close>
+
+lemma "bval (if2bexp exp) s = ifval exp s"
+  apply (induction exp)
+    apply auto
+  done
+
+lemma "ifval (b2ifexp exp) s = bval exp s"
+  apply (induction exp)
+     apply auto
+  done
+
+text \<open>
+\endexercise
+
+\exercise
+We define a new type of purely boolean expressions without any arithmetic
+ \<close>
+
+datatype pbexp =
+  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp
+
+text \<open>
+where variables range over values of type @{typ bool},
+as can be seen from the evaluation function:
+ \<close>
+
+fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
+"pbval (VAR x) s = s x"  |
+"pbval (NOT b) s = (\<not> pbval b s)" |
+"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
+"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"
+
+text  \<open> Define a function that checks whether a boolean exression is in NNF
+(negation normal form), i.e., if @{const NOT} is only applied directly
+to @{const VAR}s:  \<close>
+
+fun is_nnf :: "pbexp \<Rightarrow> bool" where
+  "is_nnf (VAR _) = True" |
+  "is_nnf (NOT (VAR _)) = True" |
+  "is_nnf (NOT _) = False" |
+  "is_nnf (AND b1 b2) \<longleftrightarrow> is_nnf b1 \<and> is_nnf b2" |
+  "is_nnf (OR b1 b2) \<longleftrightarrow> is_nnf b1 \<and> is_nnf b2"
+
+text \<open>
+Now define a function that converts a @{text bexp} into NNF by pushing
+@{const NOT} inwards as much as possible:
+ \<close>
+
+fun nnf :: "pbexp \<Rightarrow> pbexp" where
+  "nnf (VAR x) = VAR x" |
+  "nnf (NOT (VAR x)) = NOT (VAR x)" |
+  "nnf (NOT (NOT b)) = nnf b" |
+  "nnf (NOT (AND b1 b2)) = OR (nnf (NOT b1)) (nnf (NOT b2))" |
+  "nnf (NOT (OR b1 b2)) = AND (nnf (NOT b1)) (nnf (NOT b2))" |
+  "nnf (AND b1 b2) = AND (nnf b1) (nnf b2)" |
+  "nnf (OR b1 b2) = OR (nnf b1) (nnf b2)"
+
+text \<open>
+Prove that @{const nnf} does what it is supposed to do:
+ \<close>
+
+lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
+  apply (induction b rule: nnf.induct)
+        apply auto
+  done
+
+lemma is_nnf_nnf: "is_nnf (nnf b)"
+  apply (induction b rule: nnf.induct)
+        apply auto
+  done
+
+text \<open>
+An expression is in DNF (disjunctive normal form) if it is in NNF
+and if no @{const OR} occurs below an @{const AND}. Define a corresponding
+test:
+ \<close>
+
+fun is_dnf :: "pbexp \<Rightarrow> bool" where
+  "is_dnf (VAR _) = True" |
+  "is_dnf (NOT (VAR _)) = True" |
+  "is_dnf (NOT _) = False" |
+  "is_dnf (OR e\<^sub>1 e\<^sub>2) \<longleftrightarrow> is_dnf e\<^sub>1 \<and> is_dnf e\<^sub>2" |
+  "is_dnf (AND (OR _ _) _) = False" |
+  "is_dnf (AND _ (OR _ _)) = False" |
+  "is_dnf (AND e\<^sub>1 e\<^sub>2) \<longleftrightarrow> is_dnf e\<^sub>1 \<and> is_dnf e\<^sub>2"
+
+text  \<open>
+An NNF can be converted into a DNF in a bottom-up manner.
+The critical case is the conversion of @{term (sub) "AND b1 b2"}.
+Having converted @{text b\<^sub>1} and @{text b\<^sub>2}, apply distributivity of @{const AND}
+over @{const OR}. If we write @{const OR} as a multi-argument function,
+we can express the distributivity step as follows:
+@{text "dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)"}
+= @{text "OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)"}. Define
+ \<close>
+
+fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
+  "dist_AND (OR e\<^sub>1 e\<^sub>2) e\<^sub>3 = OR (dist_AND e\<^sub>1 e\<^sub>3) (dist_AND e\<^sub>2 e\<^sub>3)" |
+  "dist_AND e\<^sub>1 (OR e\<^sub>2 e\<^sub>3) = OR (dist_AND e\<^sub>1 e\<^sub>2) (dist_AND e\<^sub>1 e\<^sub>3)" |
+  "dist_AND e\<^sub>1 e\<^sub>2 = AND e\<^sub>1 e\<^sub>2"
+
+text  \<open> and prove that it behaves as follows:  \<close>
+
+lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
+  apply (induction b1 b2 rule: dist_AND.induct)
+              apply auto
+  done
+
+lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
+  apply (induction b1 b2 rule: dist_AND.induct)
+              apply auto
+  done
+
+text  \<open> Use @{const dist_AND} to write a function that converts an NNF
+  to a DNF in the above bottom-up manner.
+ \<close>
+
+fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
+  "dnf_of_nnf (VAR x) = VAR x" |
+  "dnf_of_nnf (NOT v) = NOT v" |
+  "dnf_of_nnf (OR e\<^sub>1 e\<^sub>2) = OR (dnf_of_nnf e\<^sub>1) (dnf_of_nnf e\<^sub>2)" |
+  "dnf_of_nnf (AND e\<^sub>1 e\<^sub>2) = dist_AND (dnf_of_nnf e\<^sub>1) (dnf_of_nnf e\<^sub>2)"
+
+text  \<open> Prove the correctness of your function:  \<close>
+
+lemma "pbval (dnf_of_nnf b) s = pbval b s"
+  apply (induction b)
+     apply (auto simp add: pbval_dist)
+  done
+
+lemma nnf_dnf_NOT: "is_nnf (NOT b) \<Longrightarrow> is_dnf (NOT b)"
+  apply (cases b)
+     apply auto
+  done
+
+lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
+  apply (induction b)
+     apply (auto simp add: is_dnf_dist nnf_dnf_NOT)
+  done
+
+text \<open>
+\endexercise
+
+
+\exercise\label{exe:stack-underflow}
+A \concept{stack underflow} occurs when executing an @{text ADD}
+instruction on a stack of size less than 2. In our semantics
+a term @{term "exec1 ADD s stk"} where @{prop "length stk < 2"}
+is simply some unspecified value, not an error or exception --- HOL does not have those concepts.
+Modify theory @{text "ASM"}
+such that stack underflow is modelled by @{const None}
+and normal execution by @{text Some}, i.e., the execution functions
+have return type @{typ "stack option"}. Modify all theorems and proofs
+accordingly.
+Hint: you may find @{text"split: option.split"} useful in your proofs.
+ \<close>
+
+(* See Short_Theory_ASM.thy *)
+
+text \<open>
+\endexercise
+
+\exercise\label{exe:register-machine}
+This exercise is about a register machine
+and compiler for @{typ aexp}. The machine instructions are
+ \<close>
+type_synonym reg = nat
+datatype instr = LDI val reg | LD vname reg | ADD reg reg
+
+text  \<open>
+where type @{text reg} is a synonym for @{typ nat}.
+Instruction @{term "LDI i r"} loads @{text i} into register @{text r},
+@{term "LD x r"} loads the value of @{text x} into register @{text r},
+and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds register @{text r\<^sub>2} to register @{text r\<^sub>1}.
+
+Define the execution of an instruction given a state and a register state;
+the result is the new register state:  \<close>
+
+type_synonym rstate = "reg \<Rightarrow> val"
+
+fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
+  "exec1 (LDI i r) _ rs = rs (r := i)" |
+  "exec1 (LD x r) s rs = rs (r := s x)" |
+  "exec1 (ADD r\<^sub>1 r\<^sub>2) s rs = rs (r\<^sub>1 := rs r\<^sub>1 + rs r\<^sub>2)"
+
+fun exec :: "instr list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
+  "exec [] _ rs = rs" |
+  "exec (i # is) s rs = exec is s (exec1 i s rs)"
+
+text \<open>
+Define the execution @{const[source] exec} of a list of instructions as for the stack machine.
+
+The compiler takes an arithmetic expression @{text a} and a register @{text r}
+and produces a list of instructions whose execution places the value of @{text a}
+into @{text r}. The registers @{text "> r"} should be used in a stack-like fashion
+for intermediate results, the ones @{text "< r"} should be left alone.
+Define the compiler and prove it correct:
+ \<close>
+
+lemma exec_app: "exec (is\<^sub>1 @ is\<^sub>2) s rs r = exec is\<^sub>2 s (exec is\<^sub>1 s rs) r"
+  apply (induction is\<^sub>1 arbitrary: rs r)
+   apply auto
+  done
+
+fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
+  "comp (N i) r = [LDI i r]" |
+  "comp (V x) r = [LD x r]" |
+  "comp (Plus a\<^sub>1 a\<^sub>2) r = comp a\<^sub>1 r @ comp a\<^sub>2 (Suc r) @ [ADD r (Suc r)]"
+
+lemma exec_comp_inacc: "r < r\<^sub>1 \<Longrightarrow> exec (comp a r\<^sub>1) s rs r = rs r"
+  apply (induction a arbitrary: r\<^sub>1 rs)
+    apply (auto simp add: exec_app)
+  done
+
+theorem "exec (comp a r) s rs r = aval a s"
+  apply (induction a arbitrary: r rs)
+    apply (auto simp add: exec_app exec_comp_inacc)
+  done
+
+text \<open>
+\endexercise
+
+\exercise\label{exe:accumulator}
+This exercise is a variation of the previous one
+with a different instruction set:
+ \<close>
+
+datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg
+
+text \<open>
+All instructions refer implicitly to register 0 as a source or target:
+@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
+copies the value in register 0 into register @{text r}, and @{term "ADD0 r"}
+adds the value in register @{text r} to the value in register 0;
+@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
+ \<close>
+
+fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
+  "exec01 (LDI0 i) _ rs = rs (0 := i)" |
+  "exec01 (LD0 x) s rs = rs (0 := s x)" |
+  "exec01 (MV0 r) _ rs = rs (r := rs 0)" |
+  "exec01 (ADD0 r) _ rs = rs (0 := rs 0 + rs r)"
+
+fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
+  "exec0 [] _ rs = rs" |
+  "exec0 (i # is) s rs = exec0 is s (exec01 i s rs)"
+
+lemma exec0_app: "exec0 (is\<^sub>1 @ is\<^sub>2) s rs r = exec0 is\<^sub>2 s (exec0 is\<^sub>1 s rs) r"
+  apply (induction is\<^sub>1 arbitrary: rs r)
+   apply auto
+  done
+
+text \<open>
+and @{const exec0} for instruction lists.
+
+The compiler takes an arithmetic expression @{text a} and a register @{text r}
+and produces a list of instructions whose execution places the value of @{text a}
+into register 0. The registers @{text "> r"} should be used in a stack-like fashion
+for intermediate results, the ones @{text "\<le> r"} should be left alone
+(with the exception of 0). Define the compiler and prove it correct:
+ \<close>
+
+fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
+  "comp0 (N i) _ = [LDI0 i]" |
+  "comp0 (V x) _ = [LD0 x]" |
+  "comp0 (Plus a\<^sub>1 a\<^sub>2) r = comp0 a\<^sub>1 (Suc r) @ MV0 (Suc r) # comp0 a\<^sub>2 (Suc (Suc r)) @ [ADD0 (Suc r)]"
+
+lemma exec0_comp0_inacc: "0 < r \<Longrightarrow> r < r\<^sub>1 \<Longrightarrow> exec0 (comp0 a r\<^sub>1) s rs r = rs r"
+  apply (induction a arbitrary: r r\<^sub>1 rs)
+    apply (auto simp add: exec0_app)
+  done
+
+lemma exec0_comp0: "exec0 (comp0 a r) s rs 0 = aval a s"
+  apply (induction a arbitrary: r rs)
+    apply (auto simp add: exec0_app exec0_comp0_inacc)
+  done
+
+text \<open>
+\endexercise
+ \<close>
+
+end
+
diff --git a/Chapter4.thy b/Chapter4.thy
new file mode 100644
index 0000000..89e4bdc
--- /dev/null
+++ b/Chapter4.thy
@@ -0,0 +1,354 @@
+theory Chapter4
+imports "HOL-IMP.ASM"
+begin
+
+inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
+refl:  "star r x x" |
+step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
+
+text \<open>
+\section*{Chapter 4}
+
+\exercise
+Start from the data type of binary trees defined earlier:
+\<close>
+
+datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
+
+text \<open>
+An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
+@{text l} and @{text r} are ordered
+and all values in @{text l} are @{text "< i"}
+and all values in @{text r} are @{text "> i"}.
+Define a function that returns the elements in a tree and one
+the tests if a tree is ordered:
+\<close>
+
+fun set :: "'a tree \<Rightarrow> 'a set"  where
+  "set Tip = {}" |
+  "set (Node l a r) = \<Union> {set l, {a}, set r}"
+
+fun ord :: "int tree \<Rightarrow> bool"  where
+  "ord Tip = True" |
+  "ord (Node l a r) \<longleftrightarrow> ord l \<and> ord r \<and> (\<forall> x \<in> set l. x < a) \<and> (\<forall> x \<in> set r. a < x)"
+
+text \<open> Hint: use quantifiers.
+
+Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
+while maintaining the order of the tree. If the element is already in the tree, the
+same tree should be returned.
+\<close>
+
+fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
+  "ins x Tip = Node Tip x Tip" |
+  "ins x (Node l a r) =
+    (if x < a
+      then Node (ins x l) a r
+      else if a < x
+        then Node l a (ins x r)
+        else Node l a r)"
+
+text \<open> Prove correctness of @{const ins}: \<close>
+
+lemma set_ins: "set (ins x t) = {x} \<union> set t"
+  apply (induction t)
+   apply auto
+  done
+
+theorem ord_ins: "ord t \<Longrightarrow> ord (ins i t)"
+  apply (induction t)
+   apply (auto simp add: set_ins)
+  done
+
+text \<open>
+\endexercise
+
+\exercise
+Formalize the following definition of palindromes
+\begin{itemize}
+\item The empty list and a singleton list are palindromes.
+\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
+\end{itemize}
+as an inductive predicate
+\<close>
+
+inductive palindrome :: "'a list \<Rightarrow> bool" where
+  palindrome_Nil: "palindrome []" |
+  palindrome_singleton: "palindrome [a]" |
+  palindrome_circumfix: "palindrome as \<Longrightarrow> palindrome (a # as @ [a])"
+
+text  \<open> and prove \<close>
+
+lemma "palindrome xs \<Longrightarrow> rev xs = xs"
+  apply (induction rule: palindrome.induct)
+    apply auto
+  done
+
+text \<open>
+\endexercise
+
+\exercise
+We could also have defined @{const star} as follows:
+\<close>
+
+inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
+refl': "star' r x x" |
+step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"
+
+text \<open>
+The single @{text r} step is performed after rather than before the @{text star'}
+steps. Prove
+\<close>
+
+lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
+  apply (induction rule: star.induct)
+   apply assumption
+  by (rule step) (* alternatively, apply (metis step) done *)
+
+lemma "star' r x y \<Longrightarrow> star r x y"
+  apply (induction rule: star'.induct)
+  by (auto simp add: refl step intro: star_trans)
+
+(* limitation: no way to change order of premises, induction works
+  only on first premise *)
+lemma star'_trans: "star' r y z \<Longrightarrow> star' r x y \<Longrightarrow> star' r x z"
+  apply (induction rule: star'.induct)
+   apply assumption
+  by (rule step')
+
+lemma "star r x y \<Longrightarrow> star' r x y"
+  apply (induction rule: star.induct)
+   apply (auto intro: refl' step')
+  by (blast intro: refl' step' star'_trans)
+
+text \<open>
+You may need lemmas. Note that rule induction fails
+if the assumption about the inductive predicate
+is not the first assumption.
+\endexercise
+
+\exercise\label{exe:iter}
+Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
+of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
+such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
+all @{prop"i < n"}:
+\<close>
+
+inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
+iter0: "iter r 0 x x" |
+iterS: "\<lbrakk>r x y; iter r n y z \<rbrakk> \<Longrightarrow> iter r (Suc n) x z"
+
+text \<open>
+Correct and prove the following claim:
+\<close>
+
+lemma "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
+  apply (induction rule: star.induct)
+  apply (blast intro: iter0)
+  by (blast intro: iterS)
+
+text \<open>
+\endexercise
+
+\exercise\label{exe:cfg}
+A context-free grammar can be seen as an inductive definition where each
+nonterminal $A$ is an inductively defined predicate on lists of terminal
+symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
+For example, the production $S \to aSb$ can be viewed as the implication
+@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
+i.e., elements of some alphabet. The alphabet can be defined as a datatype:
+\<close>
+
+datatype alpha = alphaa | alphab
+
+text \<open>
+If you think of @{const alphaa} and @{const alphab} as ``@{text "("}'' and  ``@{text ")"}'',
+the following two grammars both generate strings of balanced parentheses
+(where $\varepsilon$ is the empty word):
+\[
+\begin{array}{r@ {\quad}c@ {\quad}l}
+S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
+T &\to& \varepsilon \quad\mid\quad TaTb
+\end{array}
+\]
+Define them as inductive predicates and prove their equivalence:
+\<close>
+
+inductive S :: "alpha list \<Rightarrow> bool" where
+S_\<epsilon>: "S []" |
+S_aSb: "S w \<Longrightarrow> S (alphaa # w @ [alphab])" |
+S_SS: "\<lbrakk> S v; S w \<rbrakk> \<Longrightarrow> S (v @ w)"
+
+inductive T :: "alpha list \<Rightarrow> bool" where
+T_\<epsilon>: "T []" |
+T_TaTb: "\<lbrakk> T v; T w \<rbrakk> \<Longrightarrow> T (v @ [alphaa] @ w @ [alphab])"
+
+lemma TS: "T w \<Longrightarrow> S w"
+  apply (induction rule: T.induct)
+  by (auto intro: S_\<epsilon> S_SS S_aSb)
+
+lemma ST_aux_1: "[] @ [alphaa] @ w @ [alphab] = alphaa # w @ [alphab]"
+  by simp
+
+lemma ST_aux_2: "T v \<Longrightarrow> T w \<Longrightarrow> T (w @ v)"
+  apply (induction rule: T.induct)
+  apply simp
+  by (subst append_assoc [THEN sym], blast intro: T_TaTb)
+
+lemma ST: "S w \<Longrightarrow> T w"
+  apply (induction rule: S.induct)
+    apply (rule T_\<epsilon>)
+   apply (subst ST_aux_1 [THEN sym], rule T_TaTb, rule T_\<epsilon>, assumption)
+  by (rule ST_aux_2)
+
+corollary SeqT: "S w \<longleftrightarrow> T w"
+  by (auto intro: TS ST)
+
+text \<open>
+\endexercise
+\<close>
+
+text \<open>
+\exercise
+In Chapter 3 we defined a recursive evaluation function
+@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
+Define an inductive evaluation predicate and prove that it agrees with
+the recursive function:
+\<close>
+
+inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
+aval_N: "aval_rel (N i) s i" |
+aval_V: "aval_rel (V x) s (s x)" |
+aval_Plus: "\<lbrakk> aval_rel e\<^sub>1 s v\<^sub>1; aval_rel e\<^sub>2 s v\<^sub>2 \<rbrakk> \<Longrightarrow> aval_rel (Plus e\<^sub>1 e\<^sub>2) s (v\<^sub>1 + v\<^sub>2)"
+
+lemma aval_rel_aval: "aval_rel e s v \<Longrightarrow> aval e s = v"
+  apply (induction rule: aval_rel.induct)
+  by auto
+
+lemma aval_aval_rel: "aval e s = v \<Longrightarrow> aval_rel e s v"
+  apply (induction e arbitrary: v)
+  by (auto simp add: aval_N aval_V aval_Plus)
+
+corollary "aval_rel e s v \<longleftrightarrow> aval e s = v"
+  by (blast intro: aval_rel_aval aval_aval_rel)
+
+text \<open>
+\endexercise
+
+\exercise
+Consider the stack machine from Chapter~3
+and recall the concept of \concept{stack underflow}
+from Exercise~\ref{exe:stack-underflow}.
+Define an inductive predicate
+\<close>
+
+inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
+ok_Nil: "ok 0 [] 0" |
+ok_Pad: "ok n is n' \<Longrightarrow> ok (Suc n) is (Suc n')" |
+ok_LOADI: "ok (Suc n) is n' \<Longrightarrow> ok n (LOADI i # is) n'" |
+ok_LOAD: "ok (Suc n) is n' \<Longrightarrow> ok n (LOAD x # is) n'" |
+ok_ADD: "ok (Suc n) is n' \<Longrightarrow> ok (Suc (Suc n)) (ADD # is) n'"
+
+
+text \<open>
+such that @{text "ok n is n'"} means that with any initial stack of length
+@{text n} the instructions @{text "is"} can be executed
+without stack underflow and that the final stack has length @{text n'}.
+
+Using the introduction rules for @{const ok},
+prove the following special cases: \<close>
+
+lemma "ok 0 [LOAD x] (Suc 0)"
+  by (auto intro: ok_Nil ok_Pad ok_LOAD)
+
+lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
+  apply (rule ok_LOAD)
+  apply (rule ok_LOADI)
+  apply (rule ok_ADD)
+  apply (rule ok_Pad)
+  by (rule ok_Nil)
+
+lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
+  apply (rule ok_LOAD)
+  apply (rule ok_ADD)
+  apply (rule ok_ADD)
+  apply (rule ok_LOAD)
+  apply (rule ok_Pad)
+  apply (rule ok_Pad)
+  by (rule ok_Nil)
+
+text  \<open> Prove that @{text ok} correctly computes the final stack size: \<close>
+
+(* near impossible (probably impossible) without _tac and without using Isar *)
+
+(* because of ok_Pad, inversion rules need to induct over that case *)
+lemma ok_Nil_inv_aux: "\<lbrakk>ok n j n'; j = []\<rbrakk> \<Longrightarrow> n = n'"
+  apply (induction rule: ok.induct)
+  by auto
+
+lemma ok_Nil_inv: "ok n [] n' \<Longrightarrow> n = n'"
+  by (simp add: ok_Nil_inv_aux)
+
+lemma ok_LOADI_inv_aux: "\<lbrakk>ok n j n'; j = LOADI i # iss\<rbrakk> \<Longrightarrow> ok (Suc n) iss n'"
+  apply (induction rule: ok.induct)
+  by (auto simp add: ok.ok_Pad)
+
+lemma ok_LOADI_inv: "ok n (LOADI i # iss) n' \<Longrightarrow> ok (Suc n) iss n'"
+  by (simp add: ok_LOADI_inv_aux)
+
+lemma ok_LOAD_inv_aux: "\<lbrakk>ok n j n'; j = LOAD x # iss\<rbrakk> \<Longrightarrow> ok (Suc n) iss n'"
+  apply (induction rule: ok.induct)
+  by (auto simp add: ok.ok_Pad)
+
+lemma ok_LOAD_inv: "ok n (LOAD x # iss) n' \<Longrightarrow> ok (Suc n) iss n'"
+  by (simp add: ok_LOAD_inv_aux)
+
+lemma ok_ADD_inv_aux: "\<lbrakk>ok n j n'; j = ADD # iss\<rbrakk> \<Longrightarrow> \<exists> k. ok (Suc k) iss n' \<and> n = (Suc (Suc k))"
+  apply (induction rule: ok.induct)
+  by (auto simp add: ok.ok_Pad)
+
+lemma ok_ADD_inv: "ok n (ADD # iss) n' \<Longrightarrow> \<exists> k. ok (Suc k) iss n' \<and> n = (Suc (Suc k))"
+  by (auto simp add: ok_ADD_inv_aux)
+
+lemma "\<lbrakk>ok n inss n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec inss s stk) = n'"
+proof (induct inss arbitrary: n n' stk)
+  case Nil
+  thus ?case by (simp add: ok_Nil_inv)
+next
+  case (Cons a inss)
+  note H = this
+  thus ?case
+  proof (cases a)
+    case (LOADI i)
+    thus ?thesis using Cons.hyps H(2) H(3) ok_LOADI_inv by fastforce
+  next
+    case (LOAD x)
+    note Hx = this
+    thus ?thesis using Cons.hyps H(2) H(3) ok_LOAD_inv by fastforce
+  next
+    case ADD
+    note Ha = this
+    from H(2) obtain k where H2': "ok (Suc k) inss n'" and H2eq: "n = (Suc (Suc k))" using Ha ok_ADD_inv by blast
+    from H(3) H2eq have H3': "length stk = Suc (Suc k)" by simp
+    then obtain x y stkr where Hstk: "stk = x # y # stkr" by (metis Suc_length_conv)
+    hence H3'': "length ((y + x) # stkr) = Suc k" using H3' by simp
+    from Ha Hstk have "length (exec (a # inss) s stk) = length (exec (ADD # inss) s (x # y # stkr))" by simp
+    also have "\<dots> = length (exec inss s ((y + x) # stkr))" by simp
+    also
+    from H(1) H2' H3'' have "\<dots> = n'" by simp
+    finally show ?thesis .
+  qed
+qed
+
+text  \<open>
+Lemma @{thm [source] length_Suc_conv} may come in handy.
+
+Prove that instruction sequences generated by @{text comp}
+cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
+some suitable value of @{text "?"}.
+\endexercise
+\<close>
+
+
+end
+
diff --git a/Chapter5.thy b/Chapter5.thy
new file mode 100644
index 0000000..afcef3e
--- /dev/null
+++ b/Chapter5.thy
@@ -0,0 +1,517 @@
+theory Chapter5
+imports Main
+begin
+
+inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
+refl:  "star r x x" |
+step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
+
+inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
+iter_0: "iter r 0 x x" |
+iter_Suc: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"
+
+text \<open>
+\section*{Chapter 5}
+
+\exercise
+Give a readable, structured proof of the following lemma:
+\<close>
+
+lemma
+  assumes T: "\<forall>x y. T x y \<or> T y x"
+    and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
+    and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
+  shows "T x y"
+proof -
+  have "T x y \<or> T y x" using T by blast
+  thus "T x y"
+  proof
+    assume "T x y"
+    thus ?thesis by assumption
+  next
+    assume "T y x"
+    hence "A y x" using TA by blast
+    hence "x = y" using A and `A x y` by blast
+    thus "T x y" using `T y x` by blast
+  qed
+qed
+
+text\<open>
+Each step should use at most one of the assumptions @{text T}, @{text A}
+or @{text TA}.
+\endexercise
+
+\exercise
+Give a readable, structured proof of the following lemma:
+\<close>
+lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
+      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
+proof -
+  have "even (length xs) \<or> odd (length xs)" by simp
+  thus ?thesis
+  proof
+    assume "even (length xs)"
+    hence "\<exists> k. k + k = length xs" by arith
+    then obtain k where Hk: "k + k = length xs" by auto
+    let ?ys = "take k xs"
+    let ?zs = "drop k xs"
+    have "xs = ?ys @ ?zs" (is ?Heq) by simp
+    moreover from Hk have "length ?ys = length ?zs" (is ?Hlen) by auto
+    ultimately have "?Heq \<and> ?Hlen" by simp
+    thus ?thesis by blast
+  next
+    assume "odd (length xs)"
+    hence "\<exists> k. (k + 1) + k = length xs" by arith
+    then obtain k where Hk: "(k + 1) + k = length xs" by auto
+    let ?ys = "take (k + 1) xs"
+    let ?zs = "drop (k + 1) xs"
+    have "xs = ?ys @ ?zs" (is ?Heq) by simp
+    moreover from Hk have "length ?ys = length ?zs + 1" (is ?Hlen) by auto
+    ultimately have "?Heq \<and> ?Hlen" by simp
+    thus ?thesis by blast
+  qed
+qed
+
+text\<open>
+Hint: There are predefined functions @{const take} and {const drop} of type
+@{typ "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"} such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"}
+and @{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
+the relevant @{const take} and @{const drop} lemmas for you.
+\endexercise
+
+\exercise
+Give a structured proof by rule inversion:
+\<close>
+inductive ev :: "nat \<Rightarrow> bool" where
+ev0: "ev 0" |
+evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"
+
+lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
+proof (cases "Suc (Suc n)" rule: ev.cases)
+  case ev0
+  from a show ?case by assumption
+next
+  case evSS
+  assume "ev n"
+  then show ?thesis by assumption
+qed
+
+text\<open>
+\exercise
+Give a structured proof by rule inversions:
+\<close>
+
+lemma "\<not> ev(Suc(Suc(Suc 0)))" (is "\<not> ?P")
+proof
+  assume "?P"
+  thus False
+  proof (cases "Suc (Suc (Suc 0))")
+    case evSS
+    thus False by cases
+  qed
+qed
+
+text\<open>
+If there are no cases to be proved you can close
+a proof immediateley with \isacom{qed}.
+\endexercise
+
+\exercise
+Recall predicate @{const star} from Section 4.5 and @{const iter}
+from Exercise~\ref{exe:iter}.
+\<close>
+
+lemma "iter r n x y \<Longrightarrow> star r x y"
+proof (induct rule: iter.induct)
+  case (iter_0 x)
+  show ?case by (simp add: refl)
+next
+  case (iter_Suc x y n z)
+  thus ?case by (simp add: step)
+qed
+
+text\<open>
+Prove this lemma in a structured style, do not just sledgehammer each case of the
+required induction.
+\endexercise
+
+\exercise
+Define a recursive function
+\<close>
+
+fun elems :: "'a list \<Rightarrow> 'a set" where
+  "elems [] = {}" |
+  "elems (x # xs) = {x} \<union> elems xs"
+
+text\<open> that collects all elements of a list into a set. Prove \<close>
+
+lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
+proof (induct xs)
+  case Nil
+  hence False by simp
+  thus ?case by simp
+next
+  case (Cons a xs)
+  hence HxUn: "x \<in> {a} \<union> elems xs" by simp
+  consider (xa) "x \<in> {a}" | (nxa) "x \<notin> {a}" by blast
+  thus ?case
+  proof cases
+    case xa
+    hence "x = a" ..
+    hence "a # xs = x # xs" by simp
+    also have "\<dots> = [] @ x # xs" by simp
+    finally have "a # xs = [] @ x # xs" by simp
+    moreover have "x \<notin> {}" by simp
+    hence "x \<notin> elems []" by simp
+    ultimately show ?thesis by blast
+  next
+    case nxa
+    from HxUn
+    show ?thesis
+    proof
+      assume "x \<in> {a}"
+      thus ?thesis using nxa by simp
+    next
+      assume "x \<in> elems xs"
+      then obtain ys zs where "xs = ys @ x # zs" and "x \<notin> elems ys" using Cons.hyps by blast
+      hence "a # xs = (a # ys) @ x # zs" and "x \<notin> elems ys" by auto
+      hence "a # xs = (a # ys) @ x # zs" and "x \<notin> elems (a # ys)" using nxa by auto
+      thus ?thesis by blast
+    qed
+  qed
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+Extend Exercise~\ref{exe:cfg} with a function that checks if some
+\mbox{@{text "alpha list"}} is a balanced
+string of parentheses. More precisely, define a recursive function \<close>
+
+datatype alpha = alphaa | alphab
+
+inductive S :: "alpha list \<Rightarrow> bool" where
+S_\<epsilon>: "S []" |
+S_aSb: "S w \<Longrightarrow> S (alphaa # w @ [alphab])" |
+S_SS: "\<lbrakk> S v; S w \<rbrakk> \<Longrightarrow> S (v @ w)"
+
+fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
+  "balanced 0 [] = True" |
+  "balanced (Suc _) [] = False" | (* too many a's *)
+  "balanced n (alphaa # as) = balanced (Suc n) as" |
+  "balanced 0 (alphab # as) = False" | (* too many b's *)
+  "balanced (Suc n) (alphab # as) = balanced n as"
+
+text\<open> such that @{term"balanced n w"}
+is true iff (informally) @{text"a\<^sup>n @ w \<in> S"}. Formally, prove \<close>
+
+lemma balanced_r: "balanced n as \<Longrightarrow> balanced (Suc n) (as @ [alphab])"
+proof (induction n as rule: balanced.induct)
+  case 1
+  thus ?case by simp
+next
+  case (2 uu)
+  thus ?case by simp
+next
+  case (3 n as)
+  from 3(2) have "balanced (Suc n) as" by simp
+  thus ?case using 3(1) by simp
+next
+  case (4 as)
+  then show ?case by simp
+next
+  case (5 n as)
+  from 5(2) have "balanced n as" by simp
+  thus ?case using 5(1) by simp
+qed
+
+lemma balanced_app: "\<lbrakk>balanced m as; balanced n bs\<rbrakk> \<Longrightarrow> balanced (m + n) (as @ bs)"
+proof (induct m as arbitrary: n bs rule: balanced.induct)
+  case 1
+  then show ?case by simp
+next
+  case (2 uu)
+  then show ?case by simp
+next
+  case (3 nn as)
+  from 3(2) have "balanced (Suc nn) as" by simp
+  with 3(1, 3) have "balanced (Suc nn + n) (as @ bs)" by simp
+  hence "balanced (Suc (nn + n)) (as @ bs)" by simp
+  thus ?case by simp
+next
+  case (4 as)
+  then show ?case by simp
+next
+  case (5 nn as)
+  from 5(2) have "balanced nn as" by simp
+  with 5(1, 3) have "balanced (nn + n) (as @ bs)" by simp
+  hence "balanced (Suc (nn + n)) (alphab # as @ bs)" by simp
+  thus ?case by simp
+qed
+
+lemma S_ends: "S w \<Longrightarrow> w = [] \<or> (\<exists> v. w = alphaa # v @ [alphab])"
+proof (induct w rule: S.induct)
+  case S_\<epsilon>
+  have "[] = []" by simp
+  thus ?case by blast
+next
+  case (S_aSb w)
+  have "alphaa # w @ [alphab] = alphaa # w @ [alphab]" by simp
+  thus ?case by blast
+next
+  case (S_SS v w)
+  from S_SS(2) show ?case
+  proof
+    assume Hv: "v = []"
+    from S_SS(4) show ?thesis
+    proof
+      assume "w = []"
+      with Hv have "v @ w = []" by simp
+      thus ?thesis by blast
+    next
+      assume "\<exists>u. w = alphaa # u @ [alphab]"
+      then obtain u where "w = alphaa # u @ [alphab]" ..
+      with Hv have "v @ w = alphaa # u @ [alphab]" by simp
+      thus ?thesis by blast
+    qed
+  next
+    assume "\<exists>u. v = alphaa # u @ [alphab]"
+    then obtain n where Hv: "v = alphaa # n @ [alphab]" ..
+    from S_SS(4) show ?thesis
+    proof
+      assume "w = []"
+      with Hv have "v @ w = alphaa # n @ [alphab]" by simp
+      thus ?thesis by blast
+    next
+      assume "\<exists>u. w = alphaa # u @ [alphab]"
+      then obtain m where "w = alphaa # m @ [alphab]" ..
+      with Hv have "v @ w = alphaa # n @ [alphab] @ alphaa # m @ [alphab]" by simp
+      hence "v @ w = alphaa # (n @ [alphab] @ alphaa # m) @ [alphab]" by simp
+      thus ?thesis by blast
+    qed
+  qed
+qed
+
+lemma S_replicate: "\<lbrakk>S (alphaa # v); v @ w = replicate n alphaa @ x\<rbrakk> \<Longrightarrow> \<exists> u. v = replicate n alphaa @ u"
+proof -
+  assume Hvw: "v @ w = replicate n alphaa @ x"
+  assume Sav: "S (alphaa # v)"
+  hence "\<exists> vv. alphaa # v = alphaa # vv @ [alphab]"
+  proof -
+    assume "S (alphaa # v)"
+    with S_ends have "alphaa # v = [] \<or> (\<exists> vv. alphaa # v = alphaa # vv @ [alphab])" by auto
+    thus "\<exists>vv. alphaa # v = alphaa # vv @ [alphab]"
+    proof
+      assume "alphaa # v = []"
+      thus ?thesis by simp
+    next
+      assume "\<exists>vv. alphaa # v = alphaa # vv @ [alphab]"
+      thus ?thesis by simp
+    qed
+  qed
+  then obtain vv where "alphaa # v = alphaa # vv @ [alphab]" ..
+  hence Hv: "v = vv @ [alphab]" by simp
+  hence Hvvw: "vv @ [alphab] @ w = replicate n alphaa @ x" using Hvw by simp
+  hence "\<exists> xx. vv @ [alphab] = replicate n alphaa @ xx"
+  proof (induct n arbitrary: x)
+    case 0
+    have "vv @ [alphab] = replicate 0 alphaa @ vv @ [alphab]" by simp
+    thus ?case by simp
+  next
+    case (Suc n)
+    from Suc(2) have Suc2s: "vv @ [alphab] @ w = replicate n alphaa @ alphaa # x" by (simp add: replicate_app_Cons_same)
+    hence "\<exists>xx. vv @ [alphab] = replicate n alphaa @ xx" using Suc(1) by simp
+    then obtain xx where Hxx1: "vv @ [alphab] = replicate n alphaa @ xx" ..
+    hence "\<exists> xl. vv @ [alphab] = replicate n alphaa @ xl @ [alphab]"
+      by (metis alpha.distinct(1) append_butlast_last_id empty_replicate last_append last_replicate last_snoc self_append_conv2)
+    then obtain xl where Hvvb: "vv @ [alphab] = replicate n alphaa @ xl @ [alphab]" ..
+    hence Hxl1: "vv = replicate n alphaa @ xl" by simp
+    with Suc2s have "replicate n alphaa @ xl @ [alphab] @ w = replicate n alphaa @ alphaa # x" by simp
+    hence Hxx: "xl @ [alphab] @ w = alphaa # x" by simp
+    hence "\<exists> xlr. xl = alphaa # xlr"
+      by (metis alpha.distinct(1) append_eq_Cons_conv list.sel(1))
+    then obtain xlr where "xl = alphaa # xlr" ..
+    with Hvvb have "vv @ [alphab] = replicate n alphaa @ alphaa # xlr @ [alphab]" by simp
+    hence "vv @ [alphab] = replicate (Suc n) alphaa @ xlr @ [alphab]" by (simp add: replicate_app_Cons_same)
+    then show ?case by blast
+  qed
+  thus ?thesis using Hv by simp
+qed
+
+corollary "balanced n w \<longleftrightarrow> S (replicate n alphaa @ w)" (is "?P \<longleftrightarrow> ?Q")
+proof
+  assume ?P
+  thus ?Q
+  proof (induct n w rule: balanced.induct)
+    case 1 show ?case by (auto intro: S.S_\<epsilon>)
+  next case (2 uu) thus ?case by simp
+  next
+    case (3 n as)
+    moreover from this have "balanced (Suc n) as" by simp
+    ultimately have "S (replicate (Suc n) alphaa @ as)" by simp
+    hence "S ((replicate n alphaa @ [alphaa]) @ as)" by (simp add: replicate_append_same)
+    thus ?case by auto
+  next case (4 as) thus ?case by simp
+  next
+    case (5 n as)
+    moreover from this have "balanced n as" by simp
+    ultimately have "S (replicate n alphaa @ as)" by simp
+    then show ?case
+    proof (induct "replicate n alphaa @ as" arbitrary: n as rule: S.induct)
+      case S_\<epsilon>
+      from S_\<epsilon> have Hn: "replicate n alphaa = []" by simp
+      from S_\<epsilon> have Has: "as = []" by simp
+      from Hn have Hl: "replicate (Suc n) alphaa = [alphaa]" by simp
+      from S.S_\<epsilon> have "S []" by simp
+      with S.S_aSb have "S (alphaa # [] @ [alphab])" by blast
+      with Hl Has show ?case by auto
+    next
+      case (S_aSb w)
+      then show ?case
+      proof (cases "rev as")
+        case Nil
+        hence "alphaa # w @ [alphab] = replicate n alphaa @ []" using S_aSb(3) by simp
+        thus ?thesis
+          by (metis Nil_is_append_conv alpha.distinct(1) append_Nil2 empty_replicate last.simps last_replicate last_snoc list.discI)
+      next
+        case (Cons a al)
+        hence Has: "as = rev al @ [a]" by simp
+        hence Ha: "a = alphab" using S_aSb(3) by auto
+        from S_aSb(3) Has Ha have Haw: "alphaa # w = replicate n alphaa @ rev al" by auto
+        have "S (replicate (Suc n) alphaa @ alphab # rev al @ [a])"
+        proof (cases n)
+          case 0
+          with Haw have "alphaa # w @ [alphab] = rev al @ [alphab]" by simp
+          with S_aSb(1) S.S_aSb have "S (rev al @ [alphab])" by metis
+          moreover 
+          from S.S_\<epsilon> have "S []" by simp
+          with S.S_aSb have "S (alphaa # [] @ [alphab])" by blast
+          hence "S ([alphaa, alphab])" by simp
+          ultimately have "S ([alphaa, alphab] @ rev al @ [alphab])" using S.S_SS by blast
+          hence "S ([alphaa] @ alphab # rev al @ [alphab])" by auto
+          with 0 Ha show ?thesis by auto
+        next
+          case (Suc m)
+          with Haw have Hw: "w = replicate m alphaa @ rev al" by simp
+          with S_aSb(2) have "S (replicate (Suc m) alphaa @ alphab # rev al)" by blast
+          with S.S_aSb have "S (alphaa # (replicate (Suc m) alphaa @ alphab # rev al) @ [alphab])" by blast
+          hence "S (replicate (Suc (Suc m)) alphaa @ alphab # rev al @ [alphab])" by auto
+          thus ?thesis using Suc Ha by simp
+        qed
+        thus ?thesis using Has by simp
+      qed
+    next
+      case (S_SS v w)
+      from \<open>S v\<close> have "v = [] \<or> (\<exists> k. v = alphaa # k @ [alphab])" using S_ends by simp
+      then show ?case
+      proof
+        assume "v = []"
+        with S_SS(5) have "w = replicate n alphaa @ as" by simp
+        with S_SS(4) show ?thesis by simp
+      next
+        assume "\<exists>k. v = alphaa # k @ [alphab]"
+        then obtain k where Hk: "v = alphaa # k @ [alphab]" ..
+        show ?thesis
+        proof (cases n)
+          case 0
+          with S_SS(5) have "v @ w = as" by simp
+          with S.S_SS S_SS(1,3) have "S as" by blast
+          moreover
+          from S.S_\<epsilon> have "S []" by simp
+          with S.S_aSb have "S (alphaa # [] @ [alphab])" by blast
+          hence "S ([alphaa] @ [alphab])" by auto
+          ultimately have "S (([alphaa] @ [alphab]) @ as)" using S.S_SS by blast
+          thus ?thesis using 0 by auto
+        next
+          case (Suc m)
+          have "S (alphaa # k @ [alphab])" using \<open>S v\<close> and Hk by simp
+          moreover
+          from this Suc S_SS(5) have "v @ w = alphaa # replicate m alphaa @ as" by simp
+          with Hk have "k @ [alphab] @ w = replicate m alphaa @ as" by simp
+          ultimately have "\<exists> u. k @ [alphab] = replicate m alphaa @ u" using S_replicate by simp
+          then obtain u where "k @ [alphab] = replicate m alphaa @ u" ..
+          hence "v = alphaa # replicate m alphaa @ u" using Hk by simp
+          hence Hv: "v = replicate n alphaa @ u" using Suc by simp
+          hence Svv: "S (replicate (Suc n) alphaa @ alphab # u)" using S_SS(2) by simp
+          from Hv S_SS(5) have Has: "as = u @ w" by simp
+          from Svv S_SS(3) S.S_SS have "S ((replicate (Suc n) alphaa @ alphab # u) @ w)" by blast
+          with Has show ?thesis by auto
+        qed
+      qed
+    qed
+  qed
+next
+  assume ?Q
+  thus ?P
+  proof (induct "replicate n alphaa @ w" arbitrary: n w rule: S.induct)
+    case S_\<epsilon>
+    hence "replicate n alphaa = []" by simp
+    hence "n = 0" by simp
+    moreover from S_\<epsilon> have "w = []" by simp
+    ultimately show ?case by simp
+  next
+    case (S_aSb ww)
+    then show ?case
+    proof (cases n)
+      case 0
+      with S_aSb have Hw: "w = alphaa # ww @ [alphab]" by simp
+      from S_aSb(2) have "balanced 0 ww" by auto
+      hence "balanced (Suc 0) (ww @ [alphab])" using balanced_r by simp
+      hence "balanced 0 (alphaa # ww @ [alphab])" by simp
+      with 0 Hw show ?thesis by simp
+    next
+      case (Suc m)
+      with S_aSb(3) have Hwwb: "ww @ [alphab] = replicate m alphaa @ w" by simp
+      hence "\<exists> wl. ww @ [alphab] = replicate m alphaa @ wl @ [alphab]"
+        by (metis alpha.distinct(1) append_butlast_last_id empty_replicate last_append last_replicate last_snoc self_append_conv2)
+      then obtain wl where Hww: "ww = replicate m alphaa @ wl" by auto
+      with S_aSb(2) have Bwl: "balanced m wl" by blast
+      from Hwwb Hww have Hw: "w = wl @ [alphab]" by simp
+      from Bwl balanced_r have "balanced (Suc m) (wl @ [alphab])" by simp
+      thus ?thesis using Hw Suc by simp
+    qed
+  next
+    case (S_SS vv ww)
+    from S_SS(1) S_ends have "vv = [] \<or> (\<exists>vvv. vv = alphaa # vvv @ [alphab])" by simp
+    thus ?case
+    proof
+      assume "vv = []"
+      with S_SS(5) have "ww = replicate n alphaa @ w" by simp
+      with S_SS(4) show ?thesis by simp
+    next
+      assume "\<exists>vvv. vv = alphaa # vvv @ [alphab]"
+      then obtain vvv where Hvv: "vv = alphaa # vvv @ [alphab]" ..
+      hence Svv: "S (alphaa # vvv @ [alphab])" using S_SS(1) by simp
+      show ?thesis
+      proof (cases n)
+        case 0
+        with S_SS(5) have Hw: "w = vv @ ww" by simp
+        from S_SS(2) have Hvv: "balanced 0 vv" by simp
+        from S_SS(4) have Hww: "balanced 0 ww" by simp
+        from Hvv Hww balanced_app Hw have "balanced (0 + 0) w" by blast
+        with 0 show ?thesis by simp
+      next
+        case (Suc m)
+        hence H: "vvv @ [alphab] @ ww = replicate m alphaa @ w" using Hvv S_SS(5) by auto
+        hence "\<exists> u. vvv @ [alphab] = replicate m alphaa @ u" using Svv S_replicate by auto
+        then obtain u where Hu: "vvv @ [alphab] = replicate m alphaa @ u" ..
+        hence "vv = replicate n alphaa @ u" using Hvv Suc by auto
+        with S_SS(2) have Hbu: "balanced n u" by simp
+        from H have H': "(vvv @ [alphab]) @ ww = replicate m alphaa @ w" by simp
+        from Hu H' have "replicate m alphaa @ u @ ww = replicate m alphaa @ w" by auto 
+        from Hu H' have Hw: "u @ ww = w" by auto
+        from S_SS(3, 4) have Hbww: "balanced 0 ww" by simp
+        hence "balanced (n + 0) (u @ ww)" using Hbu balanced_app by blast
+        thus ?thesis using Hw by auto
+      qed
+    qed
+  qed
+qed
+
+text\<open> where @{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
+and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
+\<close>
+
+end
+
diff --git a/Chapter7.thy b/Chapter7.thy
new file mode 100644
index 0000000..a0d287f
--- /dev/null
+++ b/Chapter7.thy
@@ -0,0 +1,395 @@
+theory Chapter7
+imports "HOL-IMP.Small_Step"
+begin
+
+text\<open>
+\section*{Chapter 7}
+
+\exercise
+Define a function that computes the set of variables that are assigned to
+in a command:
+\<close>
+
+(* We use static analysis semantics for the notion of "assigned".
+  A more precise semantics will use an auxillary function that reasons in terms
+  of states, and take the union of assignments among its terminating states.
+*)
+fun assigned :: "com \<Rightarrow> vname set" where
+  "assigned SKIP = {}" |
+  "assigned (x ::= _) = {x}" |
+  "assigned (c\<^sub>1;;c\<^sub>2) = assigned c\<^sub>1 \<union> assigned c\<^sub>2" |
+  "assigned (IF _ THEN c\<^sub>1 ELSE c\<^sub>2) = assigned c\<^sub>1 \<union> assigned c\<^sub>2" | 
+  "assigned (WHILE _ DO c) = assigned c"
+
+text\<open>
+Prove that if some variable is not assigned to in a command,
+then that variable is never modified by the command:
+\<close>
+
+lemma "\<lbrakk> (c, s) \<Rightarrow> t; x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = t x"
+  by (induct rule: big_step_induct) auto
+
+text \<open>
+\endexercise
+
+\exercise
+Define a recursive function that determines if a command behaves like @{const SKIP}
+and prove its correctness:
+\<close>
+
+(* Honestly, the skip property is better captured by reasoning about states,
+which does not require the function to be defined recursively.
+*)
+fun skip :: "com \<Rightarrow> bool" where
+  "skip SKIP \<longleftrightarrow> True" |
+  "skip (_ ::= _) \<longleftrightarrow> False" |
+  "skip (c\<^sub>1;;c\<^sub>2) \<longleftrightarrow> skip c\<^sub>1 \<and> skip c\<^sub>2" |
+  "skip (IF _ THEN c\<^sub>1 ELSE c\<^sub>2) \<longleftrightarrow> skip c\<^sub>1 \<and> skip c\<^sub>2" |
+  "skip (WHILE _ DO c) \<longleftrightarrow> False"
+  (* equivalence requires that the while loop terminates. The while loop terminates
+  without mutating state IFF the bexp is contradictory. (Otherwise, there is a state
+  that either never terminates, or gets mutated in order to eventually fail the
+  guard and proceed. In conventional static analysis semantics, which I presume
+  the question means by "behaves like", this means that while loops never
+  behaves like skip.
+ *)
+
+(* because we have written off while, we can simply induct on the
+  inductive definition of c
+  *)
+lemma "skip c \<Longrightarrow> c \<sim> SKIP"
+proof (intro allI)
+  fix s t
+  assume "skip c"
+  then have Hs: "(c, s) \<Rightarrow> s" by (induct c) auto
+  show "(c, s) \<Rightarrow> t = (SKIP, s) \<Rightarrow> t"
+  proof
+    assume "(c, s) \<Rightarrow> t"
+    with Hs have "s = t" using big_step_determ by simp
+    then show "(SKIP, s) \<Rightarrow> t" using Skip by simp
+  next
+    assume "(SKIP, s) \<Rightarrow> t"
+    moreover have "(SKIP, s) \<Rightarrow> s" by auto
+    ultimately have "s = t" using big_step_determ by simp
+    with Hs show "(c, s) \<Rightarrow> t" by simp
+  qed
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+Define a recursive function
+\<close>
+
+fun deskip :: "com \<Rightarrow> com" where
+  "deskip (SKIP;;c) = c" |
+  "deskip (c;;SKIP) = c" |
+  "deskip (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = IF b THEN deskip c\<^sub>1 ELSE deskip c\<^sub>2" |
+  "deskip (WHILE b DO c) = WHILE b DO deskip c" |
+  "deskip c = c"
+
+text\<open>
+that eliminates as many @{const SKIP}s as possible from a command. For example:
+@{prop[display]"deskip (SKIP;; WHILE b DO (x::=a;; SKIP)) = WHILE b DO x::=a"}
+Prove its correctness by induction on @{text c}: \<close>
+
+lemma "deskip c \<sim> c"
+  by (induct c rule: deskip.induct) (auto simp add: sim_while_cong)
+
+text\<open>
+Remember lemma @{thm[source]sim_while_cong} for the @{text WHILE} case.
+\endexercise
+
+\exercise
+A small-step semantics for the evaluation of arithmetic expressions
+can be defined like this:
+\<close>
+
+inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
+"(V x, s) \<leadsto> N (s x)" |
+"(Plus (N i) (N j), s) \<leadsto> N (i + j)" |
+"(a\<^sub>1, s) \<leadsto> a\<^sub>1' \<Longrightarrow> (Plus a\<^sub>1 a\<^sub>2, s) \<leadsto> Plus a\<^sub>1' a\<^sub>2" |
+"(a\<^sub>2, s) \<leadsto> a\<^sub>2' \<Longrightarrow> (Plus (N i) a\<^sub>2, s) \<leadsto> Plus (N i) a\<^sub>2'"
+
+text\<open>
+Complete the definition with two rules for @{const Plus}
+that model a left-to-right evaluation strategy:
+reduce the first argument with @{text"\<leadsto>"} if possible,
+reduce the second argument with @{text"\<leadsto>"} if the first argument is a number.
+Prove that each @{text"\<leadsto>"} step preserves the value of the expression:
+\<close>
+
+lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
+proof (induction rule: astep.induct [split_format (complete)])
+  fix x s
+  show "aval (V x) s = aval (N (s x)) s" by simp
+next
+  fix i j s
+  show "aval (Plus (N i) (N j)) s = aval (N (i + j)) s" by simp
+next
+  fix a\<^sub>1 s a\<^sub>1' a\<^sub>2
+  assume "(a\<^sub>1, s) \<leadsto> a\<^sub>1'" "aval a\<^sub>1 s = aval a\<^sub>1' s"
+  then show "aval (Plus a\<^sub>1 a\<^sub>2) s = aval (Plus a\<^sub>1' a\<^sub>2) s" by simp
+next
+  fix a\<^sub>2 s a\<^sub>2' i
+  assume "(a\<^sub>2, s) \<leadsto> a\<^sub>2'" "aval a\<^sub>2 s = aval a\<^sub>2' s"
+  then show "aval (Plus (N i) a\<^sub>2) s = aval (Plus (N i) a\<^sub>2') s" by simp
+qed
+
+text\<open>
+Do not use the \isacom{case} idiom but write down explicitly what you assume
+and show in each case: \isacom{fix} \dots \isacom{assume} \dots \isacom{show} \dots.
+\endexercise
+
+\exercise
+Prove or disprove (by giving a counterexample):
+\<close>
+
+lemma "IF And b\<^sub>1 b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 \<sim>
+          IF b\<^sub>1 THEN IF b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 ELSE c\<^sub>2"
+proof (intro allI)
+  fix s t
+  show "(IF And b\<^sub>1 b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t =
+           (IF b\<^sub>1 THEN IF b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 ELSE c\<^sub>2, s) \<Rightarrow> t"
+  proof
+    assume "(IF And b\<^sub>1 b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t"
+    then show "(IF b\<^sub>1 THEN IF b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 ELSE c\<^sub>2, s) \<Rightarrow> t"
+    proof
+      assume Hb: "\<not>bval (And b\<^sub>1 b\<^sub>2) s"
+      show "(c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> ?thesis"
+      proof (cases "bval b\<^sub>1 s")
+        case True
+        with Hb have "\<not>bval b\<^sub>2 s" by auto
+        with True show "(c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> ?thesis" by auto
+      qed auto
+    qed auto
+  qed auto
+qed
+
+lemma "\<exists> b\<^sub>1 b\<^sub>2 c. ~WHILE And b\<^sub>1 b\<^sub>2 DO c \<sim> WHILE b\<^sub>1 DO WHILE b\<^sub>2 DO c"
+proof (intro exI notI)
+  let ?b\<^sub>1 = "(Less (V ''a'') (N 1))"
+  let ?b\<^sub>2 = "(Less (V ''b'') (N 2))"
+  let ?c  = "''a'' ::= (Plus (V ''a'') (N 1));; ''b'' ::= (Plus (V ''b'') (N 1))"
+  assume Hc: "WHILE And ?b\<^sub>1 ?b\<^sub>2 DO ?c \<sim> WHILE ?b\<^sub>1 DO WHILE ?b\<^sub>2 DO ?c"
+  let ?s = "<>"
+  let ?t\<^sub>1 = "<''a'':=1,''b'':=1>"
+  let ?t\<^sub>2 = "<''a'':=2,''b'':=2>"
+  have H1: "(WHILE And ?b\<^sub>1 ?b\<^sub>2 DO ?c, ?s) \<Rightarrow> ?t\<^sub>1"
+  proof (rule WhileTrue)
+    show "bval (And ?b\<^sub>1 ?b\<^sub>2) <>" by (auto simp add: null_state_def)
+    show "(?c, <>) \<Rightarrow> ?t\<^sub>1" by (auto simp add: assign_simp null_state_def)
+    show "(WHILE And ?b\<^sub>1 ?b\<^sub>2 DO ?c, ?t\<^sub>1) \<Rightarrow> ?t\<^sub>1" by (rule WhileFalse) (auto simp add: null_state_def)
+  qed
+  with Hc have H1: "(WHILE ?b\<^sub>1 DO WHILE ?b\<^sub>2 DO ?c, ?s) \<Rightarrow> ?t\<^sub>1" by auto
+  moreover have H2: "(WHILE ?b\<^sub>1 DO WHILE ?b\<^sub>2 DO ?c, ?s) \<Rightarrow> ?t\<^sub>2"
+  proof (rule WhileTrue)
+    show "bval ?b\<^sub>1 ?s" by (auto simp add: null_state_def)
+    show "(WHILE ?b\<^sub>2 DO ?c, ?s) \<Rightarrow> ?t\<^sub>2"
+    proof (rule WhileTrue)
+      show "bval ?b\<^sub>2 ?s" by (auto simp add: null_state_def)
+      show "(?c, ?s) \<Rightarrow> ?t\<^sub>1" by (auto simp add: assign_simp null_state_def)
+      show "(WHILE ?b\<^sub>2 DO ?c, ?t\<^sub>1) \<Rightarrow> ?t\<^sub>2"
+      proof
+        show "bval ?b\<^sub>2 ?t\<^sub>1" by auto
+        show "(?c, ?t\<^sub>1) \<Rightarrow> ?t\<^sub>2" by (auto simp add: assign_simp)
+        show "(WHILE ?b\<^sub>2 DO ?c, ?t\<^sub>2) \<Rightarrow> ?t\<^sub>2" by (rule WhileFalse) (auto)
+      qed
+    qed
+    show "(WHILE ?b\<^sub>1 DO WHILE ?b\<^sub>2 DO ?c, ?t\<^sub>2) \<Rightarrow> ?t\<^sub>2" by (rule WhileFalse) (auto)
+  qed
+  show False using big_step_determ [OF H1 H2, THEN fun_cong, of "''a''"] by simp
+qed
+
+definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
+"Or b\<^sub>1 b\<^sub>2 = Not (And (Not b\<^sub>1) (Not b\<^sub>2))"
+
+lemma while_inv: "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> \<not> bval b t"
+  by (induct "WHILE b DO c" s t arbitrary: b c rule: big_step_induct) simp
+
+lemma "WHILE Or b\<^sub>1 b\<^sub>2 DO c \<sim>
+          WHILE Or b\<^sub>1 b\<^sub>2 DO c;; WHILE b\<^sub>1 DO c"
+proof (intro allI)
+  fix s t
+  show "(WHILE Or b\<^sub>1 b\<^sub>2 DO c, s) \<Rightarrow> t =
+             (WHILE Or b\<^sub>1 b\<^sub>2 DO c;; WHILE b\<^sub>1 DO c, s) \<Rightarrow> t"
+  proof
+    assume HW: "(WHILE Or b\<^sub>1 b\<^sub>2 DO c, s) \<Rightarrow> t"
+    show "(WHILE Or b\<^sub>1 b\<^sub>2 DO c;; WHILE b\<^sub>1 DO c, s) \<Rightarrow> t"
+    proof (rule Seq)
+      from HW show "(WHILE Or b\<^sub>1 b\<^sub>2 DO c, s) \<Rightarrow> t" .
+      from HW while_inv have "\<not> bval (Or b\<^sub>1 b\<^sub>2) t" by simp
+      then have "\<not> bval b\<^sub>1 t" using Or_def by auto
+      then show "(WHILE b\<^sub>1 DO c, t) \<Rightarrow> t" by auto
+    qed
+  next
+    assume "(WHILE Or b\<^sub>1 b\<^sub>2 DO c;; WHILE b\<^sub>1 DO c, s) \<Rightarrow> t"
+    then obtain s' where H1: "(WHILE Or b\<^sub>1 b\<^sub>2 DO c, s) \<Rightarrow> s'" and H2: "(WHILE b\<^sub>1 DO c, s') \<Rightarrow> t" by auto
+    from H1 while_inv have "\<not> bval (Or b\<^sub>1 b\<^sub>2) s'" by simp
+    then have "\<not> bval b\<^sub>1 s'" using Or_def by auto
+    then have "s' = t" using H2 big_step_determ by auto
+    with H1 show "(WHILE Or b\<^sub>1 b\<^sub>2 DO c, s) \<Rightarrow> t" by simp
+  qed
+qed
+
+text\<open>
+\endexercise
+
+\exercise
+Define a new loop construct @{text "DO c WHILE b"} (where @{text c} is
+executed once before @{text b} is tested) in terms of the
+existing constructs in @{typ com}:
+\<close>
+
+definition Do :: "com \<Rightarrow> bexp \<Rightarrow> com" ("DO _ WHILE _"  [0, 61] 61) where
+  "DO c WHILE b = c;; WHILE b DO c"
+
+text\<open>
+Define a translation on commands that replaces all @{term "WHILE b DO c"}
+by suitable commands that use @{term "DO c WHILE b"} instead:
+\<close>
+
+fun dewhile :: "com \<Rightarrow> com" where
+  "dewhile (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = IF b THEN dewhile c\<^sub>1 ELSE dewhile c\<^sub>2" |
+  "dewhile (WHILE b DO c) = IF b THEN DO dewhile c WHILE b ELSE SKIP" |
+  "dewhile c = c"
+
+text\<open> Prove that your translation preserves the semantics: \<close>
+
+lemma sim_seq_cong: "\<lbrakk>c\<^sub>1 \<sim> c\<^sub>1'; c\<^sub>2 \<sim> c\<^sub>2'\<rbrakk> \<Longrightarrow> c\<^sub>1 ;; c\<^sub>2 \<sim> c\<^sub>1' ;; c\<^sub>2'" by blast
+lemma sim_if_cong: "\<lbrakk>c\<^sub>1 \<sim> c\<^sub>1'; c\<^sub>2 \<sim> c\<^sub>2'\<rbrakk> \<Longrightarrow> IF b THEN c\<^sub>1 ELSE c\<^sub>2 \<sim> IF b THEN c\<^sub>1' ELSE c\<^sub>2'" by blast
+
+declare sim_trans [trans add]
+
+lemma "dewhile c \<sim> c"
+proof (induct rule: dewhile.induct)
+  case (2 b c)
+  have "dewhile (WHILE b DO c) \<sim>
+    IF b THEN dewhile c;; WHILE b DO dewhile c ELSE SKIP" using Do_def by simp
+  also have "IF b THEN dewhile c;; WHILE b DO dewhile c ELSE SKIP \<sim>
+    IF b THEN c;; WHILE b DO c ELSE SKIP" using 2 by (auto simp add: sim_if_cong sim_seq_cong sim_while_cong)
+  also have "IF b THEN c;; WHILE b DO c ELSE SKIP \<sim> WHILE b DO c" by blast
+  finally show ?case .
+qed auto
+
+declare sim_trans [trans del]
+
+text\<open>
+\endexercise
+
+\exercise
+Let @{text "C :: nat \<Rightarrow> com"} be an infinite sequence of commands and
+@{text "S :: nat \<Rightarrow> state"} an infinite sequence of states such that
+@{prop"C(0::nat) = c;;d"} and \mbox{@{prop"\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"}}.
+Then either all @{text"C n"} are of the form \mbox{@{term"c\<^sub>n;;d"}}
+and it is always @{text c\<^sub>n} that is reduced or @{text c\<^sub>n} eventually becomes @{const SKIP}.
+Prove
+\<close>
+
+lemma assumes H0: "C 0 = c;;d" and HI: "\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"
+shows "(\<forall>n. \<exists>c\<^sub>1 c\<^sub>2. C n = c\<^sub>1;;d \<and> C(Suc n) = c\<^sub>2;;d \<and>
+                         (c\<^sub>1, S n) \<rightarrow> (c\<^sub>2, S(Suc n)))
+     \<or> (\<exists>k. C k = SKIP;;d)" (is "(\<forall>i. ?P i) \<or> ?Q")
+proof (cases ?Q)
+  assume HnSKIP: "\<not>?Q"
+  have "\<forall>i. ?P i"
+  proof
+    fix i
+    show "?P i"
+    proof (induct i)
+      case 0
+      from HI have "(C 0, S 0) \<rightarrow> (C (Suc 0), S (Suc 0))" by blast
+      with H0 have "(c;;d, S 0) \<rightarrow> (C (Suc 0), S (Suc 0))" by simp
+      then show ?case
+      proof (cases rule: small_step.cases)
+        case Seq1
+        then have "C 0 = SKIP;; d" using H0 by simp
+        with HnSKIP show ?thesis by blast
+      next
+        case (Seq2 c\<^sub>1')
+        with H0 show ?thesis by simp
+      qed
+    next
+      case (Suc i)
+      then obtain c\<^sub>1 c\<^sub>2 where Hi: "C i = c\<^sub>1;; d"
+        and HSi: "C (Suc i) = c\<^sub>2;; d"
+        and HSS: "(c\<^sub>1, S i) \<rightarrow> (c\<^sub>2, S (Suc i))" by blast+
+      from HI have "(C (Suc i), S (Suc i)) \<rightarrow> (C (Suc (Suc i)), S (Suc (Suc i)))" by blast
+      with HSi have "(c\<^sub>2;; d, S (Suc i)) \<rightarrow> (C (Suc (Suc i)), S (Suc (Suc i)))" by simp
+      then show ?case using HSi HnSKIP by (cases rule: small_step.cases) auto
+    qed
+  qed
+  then show ?thesis by simp
+qed simp
+
+text\<open>
+\endexercise
+\bigskip
+
+For the following exercises copy theories
+@{short_theory "Com"}, @{short_theory "Big_Step"} and @{short_theory "Small_Step"}
+and modify them as required. Those parts of the theories
+that do not contribute to the results required in the exercise can be discarded.
+If there are multiple proofs of the same result, you may update any one of them.
+
+\begin{exercise}\label{exe:IMP:REPEAT}
+Extend IMP with a @{text "REPEAT c UNTIL b"} command by adding the constructor
+\begin{alltt}
+  Repeat com bexp   ("(REPEAT _/ UNTIL _)"  [0, 61] 61)
+\end{alltt}
+to datatype @{typ com}.
+Adjust the definitions of big-step and small-step semantics,
+the proof that the big-step semantics is deterministic and
+the equivalence proof between the two semantics.
+\end{exercise}
+
+\begin{exercise}\label{exe:IMP:OR}
+Extend IMP with a new command @{text "c\<^sub>1 OR c\<^sub>2"} that is a
+nondeterministic choice: it may execute either @{text
+"c\<^sub>1"} or @{text "c\<^sub>2"}. Add the constructor
+\begin{alltt}
+  Or com com   ("_ OR/ _" [60, 61] 60)
+\end{alltt}
+to datatype @{typ com}. Adjust the definitions of big-step
+and small-step semantics, prove @{text"(c\<^sub>1 OR c\<^sub>2) \<sim> (c\<^sub>2 OR c\<^sub>1)"}
+and update the equivalence proof between the two semantics.
+\end{exercise}
+
+\begin{exercise}
+Extend IMP with exceptions. Add two constructors @{text THROW} and
+@{text "TRY c\<^sub>1 CATCH c\<^sub>2"} to datatype @{typ com}:
+\begin{alltt}
+  THROW  |  Try com com   ("(TRY _/ CATCH _)"  [0, 61] 61)
+\end{alltt}
+Command @{text THROW} throws an exception. The only command that can
+catch an execption is @{text "TRY c\<^sub>1 CATCH c\<^sub>2"}: if an execption
+is thrown by @{text c\<^sub>1}, execution continues with @{text c\<^sub>2},
+otherwise @{text c\<^sub>2} is ignored.
+Adjust the definitions of big-step and small-step semantics as follows.
+
+The big-step semantics is now of type @{typ "com \<times> state \<Rightarrow> com \<times> state"}.
+In a big step @{text "(c,s) \<Rightarrow> (x,t)"}, @{text x} can only be @{term SKIP}
+(signalling normal termination) or @{text THROW} (signalling that an exception
+was thrown but not caught).
+
+The small-step semantics is of the same type as before. There are two final
+configurations now, @{term "(SKIP, t)"} and @{term "(THROW, t)"}.
+Exceptions propagate upwards until an enclosing handler is found.
+That is, until a configuration @{text "(TRY THROW CATCH c, s)"}
+is reached and @{text THROW} can be caught.
+
+Adjust the equivalence proof between the two semantics such that you obtain
+@{text "cs \<Rightarrow> (SKIP,t)  \<longleftrightarrow>  cs \<rightarrow>* (SKIP,t)"}
+and @{text "cs \<Rightarrow> (THROW,t)  \<longleftrightarrow>  cs \<rightarrow>* (THROW,t)"}.
+Also revise the proof of
+\noquotes{@{prop [source] "(\<exists>cs'. cs \<Rightarrow> cs')  \<longleftrightarrow>  (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"}}.
+\end{exercise}
+\<close>
+
+(* Short_Theory_7_8.thy *)
+(* Short_Theory_7_9.thy *)
+(* Short_Theory_7_10.thy *)
+
+end
+
diff --git a/Chapter8.thy b/Chapter8.thy
new file mode 100644
index 0000000..05112a9
--- /dev/null
+++ b/Chapter8.thy
@@ -0,0 +1,75 @@
+theory Chapter8
+imports "HOL-IMP.Compiler"
+begin
+
+text{*
+\section*{Chapter 8}
+
+For the following exercises copy and adjust theory @{short_theory "Compiler"}.
+Intrepid readers only should attempt to adjust theory @{text Compiler2} too.
+
+\begin{exercise}
+A common programming idiom is @{text "IF b THEN c"}, i.e.,
+the @{text ELSE}-branch is a @{term SKIP} command.
+Look at how, for example, the command @{term "IF Less (V ''x'') (N 5) THEN ''y'' ::= N 3 ELSE SKIP"}
+is compiled by @{const ccomp} and identify a possible compiler optimization.
+Modify the definition of @{const ccomp} such that it generates fewer instructions
+for commands of the form @{term "IF b THEN c ELSE SKIP"}.
+Ideally the proof of theorem @{thm[source] ccomp_bigstep} should still work;
+otherwise adapt it.
+\end{exercise}
+
+\begin{exercise}
+Building on Exercise~\ref{exe:IMP:REPEAT}, extend the compiler @{const ccomp}
+and its correctness theorem @{thm[source] ccomp_bigstep} to @{text REPEAT}
+loops. Hint: the recursion pattern of the big-step semantics
+and the compiler for @{text REPEAT} should match.
+\end{exercise}
+
+\begin{exercise}\label{exe:COMP:addresses}
+Modify the machine language such that instead of variable names to values,
+the machine state maps addresses (integers) to values. Adjust the compiler
+and its proof accordingly.
+
+In the simple version of this exercise, assume the existence of a globally
+bijective function @{term "addr_of :: vname => int"} with @{term "bij addr_of"}
+to adjust the compiler. Use the @{text find_theorems} search to find applicable
+theorems for bijectivte functions.
+
+For the more advanced version and a slightly larger project, only assume that
+the function works on a finite set of variables: those that occur in the
+program. For the other, unused variables, it should return a suitable default
+address. In this version, you may want to split the work into two parts:
+first, update the compiler and machine language, assuming the existence of
+such a function and the (partial) inverse it provides. Second, separately
+construct this function from the input program, having extracted the
+properties needed for it in the first part. In the end, rearrange you theory
+file to combine both into a final theorem.
+\end{exercise}
+
+\begin{exercise}
+This is a slightly more challenging project. Based on
+\autoref{exe:COMP:addresses}, and similarly to \autoref{exe:register-machine}
+and \autoref{exe:accumulator}, define a second machine language that does not
+possess a built-in stack, but instead, in addition to the program counter, a
+stack pointer register. Operations that previously worked on the stack now
+work on memory, accessing locations based on the stack pointer.
+
+For instance, let @{term "(pc, s, sp)"} be a configuration of this new machine consisting of
+program counter, store, and stack pointer. Then the configuration after an @{const ADD} instruction
+is \mbox{@{term "(pc + 1::int, s(sp + 1 := s (sp + 1::int) + s sp), sp + 1)"}}, that is, @{const ADD} dereferences
+the memory at @{term "sp + 1::int"} and @{term sp}, adds these two values and stores them at
+@{term "sp + 1::int"}, updating the values on the stack. It also increases the stack pointer by one
+to pop one value from the stack and leave the result at the top of the stack. This means the stack grows downwards.
+
+Modify the compiler from \autoref{exe:COMP:addresses} to work on this new machine language. Reformulate and reprove the easy direction of compiler correctness.
+
+\emph{Hint:} Let the stack start below @{text 0}, growing downwards, and use type @{typ nat} for addressing variable in @{const LOAD} and @{const STORE} instructions, so that it is clear by type that these instructions do not interfere with the stack.
+
+\emph{Hint:} When the new machine pops a value from the stack, this now unused value is left behind in the store. This means, even after executing a purely arithmetic expression, the values in initial and final stores are not all equal. But: they are equal above a given address. Define an abbreviation for this concept and use it to express the intermediate correctness statements.
+
+\end{exercise}
+
+*}
+end
+
diff --git a/Chapter9_1.thy b/Chapter9_1.thy
new file mode 100644
index 0000000..3e57b25
--- /dev/null
+++ b/Chapter9_1.thy
@@ -0,0 +1,117 @@
+theory Chapter9_1
+imports "HOL-IMP.Types"
+begin
+
+text\<open>
+\section*{Chapter 9}
+
+\exercise
+Reformulate the inductive predicates \ @{prop"\<Gamma> \<turnstile> a : \<tau>"},
+\ @{prop"\<Gamma> \<turnstile> (b::bexp)"} \
+and \ \mbox{@{prop"\<Gamma> \<turnstile> (c::com)"}} \ as three recursive functions
+\<close>
+
+fun atype :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty option" where
+  "atype _ (Ic i) = Some Ity" |
+  "atype _ (Rc r) = Some Rty" |
+  "atype \<Gamma> (V x) = Some (\<Gamma> x)" |
+  "atype \<Gamma> (Plus a1 a2) = (if
+    atype \<Gamma> a1 = atype \<Gamma> a2
+    then (atype \<Gamma> a1)
+    else None)"
+
+fun bok :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" where
+  "bok _ (Bc v) = True" |
+  "bok \<Gamma> (Not b) = bok \<Gamma> b" |
+  "bok \<Gamma> (And b1 b2) \<longleftrightarrow> bok \<Gamma> b1 \<and> bok \<Gamma> b2" |
+  "bok \<Gamma> (Less a1 a2) \<longleftrightarrow> atype \<Gamma> a1 = atype \<Gamma> a2 \<and> atype \<Gamma> a1 \<noteq> None"
+
+fun cok :: "tyenv \<Rightarrow> com \<Rightarrow> bool" where
+  "cok \<Gamma> SKIP = True" |
+  "cok \<Gamma> (x ::= a) \<longleftrightarrow> atype \<Gamma> a = Some (\<Gamma> x)" |
+  "cok \<Gamma> (c1;; c2) \<longleftrightarrow> cok \<Gamma> c1 \<and> cok \<Gamma> c2" |
+  "cok \<Gamma> (IF b THEN c1 ELSE c2) \<longleftrightarrow> bok \<Gamma> b \<and> cok \<Gamma> c1 \<and> cok \<Gamma> c2" |
+  "cok \<Gamma> (WHILE b DO c) \<longleftrightarrow> bok \<Gamma> b \<and> cok \<Gamma> c"
+
+text\<open> and prove \<close>
+
+lemma atyping_atype: "(\<Gamma> \<turnstile> a : \<tau>) = (atype \<Gamma> a = Some \<tau>)"
+  by (induct a) auto
+
+lemma btyping_bok: "(\<Gamma> \<turnstile> b) = bok \<Gamma> b"
+  by (induct b) (auto iff add: atyping_atype)
+
+lemma ctyping_cok: "(\<Gamma> \<turnstile> c) = cok \<Gamma> c"
+  by (induct c) (auto iff add: atyping_atype btyping_bok)
+
+text\<open>
+\endexercise
+
+\exercise
+Modify the evaluation and typing of @{typ aexp} by allowing @{typ int}s to be coerced
+to @{typ real}s with the predefined coercion function
+\noquotes{@{term[source] "real_of_int :: int \<Rightarrow> real"}} where necessary.
+Now every @{typ aexp} has a value. Define an evaluation function:
+\<close>
+
+fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
+  "aval (Ic i) _ = Iv i" |
+  "aval (Rc r) _ = Rv r" |
+  "aval (V x) s = s x" |
+  "aval (Plus a1 a2) s = (case
+    (aval a1 s, aval a2 s) of
+    (Iv i1, Iv i2) \<Rightarrow> Iv (i1 + i2) |
+    (Iv i, Rv r) \<Rightarrow> Rv (i + r) |
+    (Rv r, Iv i) \<Rightarrow> Rv (r + i) |
+    (Rv r1, Rv r2) \<Rightarrow> Rv (r1 + r2))"
+
+text\<open>
+Similarly, every @{typ aexp} has a type.
+Define a function that computes the type of an @{typ aexp}
+\<close>
+
+fun atyp :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty" where
+  "atyp _ (Ic i) = Ity" |
+  "atyp _ (Rc r) = Rty" |
+  "atyp \<Gamma> (V x) = \<Gamma> x" |
+  "atyp \<Gamma> (Plus a1 a2) = (if
+    atyp \<Gamma> a1 = Ity
+    then atyp \<Gamma> a2
+    else Rty)"
+    
+
+text\<open> and prove that it computes the correct type: \<close>
+
+lemma  "\<Gamma> \<turnstile> s \<Longrightarrow> atyp \<Gamma> a = type (aval a s)"
+  unfolding styping_def
+  by (induct a) (auto split: val.split)
+
+text\<open>
+Note that Isabelle inserts the coercion @{typ real} automatically.
+For example, if you write @{term "Rv(i+r)"} where @{text"i :: int"} and
+@{text "r :: real"} then it becomes @{term "Rv(real i + x)"}.
+\endexercise
+\bigskip
+
+For the following two exercises copy theory @{short_theory "Types"} and modify it as required.
+
+\begin{exercise}
+Add a @{text REPEAT} loop (see Exercise~\ref{exe:IMP:REPEAT}) to the typed version of IMP
+and update the type soundness proof.
+\end{exercise}
+
+\begin{exercise}
+Modify the typed version of IMP as follows. Values are now either integers or booleans.
+Thus variables can have boolean values too. Merge the two expressions types
+@{typ aexp} and @{typ bexp} into one new type @{text exp} of expressions
+that has the constructors of both types (of course without real constants).
+Combine @{const taval} and @{const tbval} into one evaluation predicate
+@{text "eval :: exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}. Similarly combine the two typing predicates
+into one: @{text "\<Gamma> \<turnstile> e : \<tau>"} where @{text "e :: exp"} and the IMP-type @{text \<tau>} can
+be one of @{text Ity} or @{text Bty}.
+Adjust the small-step semantics and the type soundness proof.
+\end{exercise}
+\<close>
+
+end
+
diff --git a/Chapter9_2.thy b/Chapter9_2.thy
new file mode 100644
index 0000000..4bf4bd7
--- /dev/null
+++ b/Chapter9_2.thy
@@ -0,0 +1,310 @@
+theory Chapter9_2
+imports "HOL-IMP.Sec_Typing"
+begin
+
+text \<open>
+\exercise
+Reformulate the inductive predicate @{const sec_type}
+as a recursive function and prove the equivalence of the two formulations:
+\<close>
+
+fun ok :: "level \<Rightarrow> com \<Rightarrow> bool" where
+  "ok l SKIP = True" |
+  "ok l (x ::= a) \<longleftrightarrow> sec x \<ge> sec a \<and> sec x \<ge> l" |
+  "ok l (c\<^sub>1;; c\<^sub>2) \<longleftrightarrow> ok l c\<^sub>1 \<and> ok l c\<^sub>2" |
+  "ok l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) \<longleftrightarrow> ok (max (sec b) l) c\<^sub>1 \<and> ok (max (sec b) l) c\<^sub>2" |
+  "ok l (WHILE b DO c) = ok (max (sec b) l) c"
+
+thm sec_type.intros
+theorem "(l \<turnstile> c) = ok l c"
+proof
+  assume "l \<turnstile> c"
+  then show "ok l c" by (induct rule: sec_type.induct) auto
+next
+  assume "ok l c"
+  then show "l \<turnstile> c" by (induct l c rule: ok.induct) (auto intro: sec_type.intros)
+qed
+
+text\<open>
+Try to reformulate the bottom-up system @{prop "\<turnstile> c : l"}
+as a function that computes @{text l} from @{text c}. What difficulty do you face?
+\endexercise
+\<close>
+
+(* "Problem": need to use quantifiers *)
+
+text\<open>
+\exercise
+Define a bottom-up termination insensitive security type system
+@{text"\<turnstile>' c : l"} with subsumption rule:
+\<close>
+
+inductive sec_type2' :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile>' _ : _)" [0,0] 50) where
+Skip2': "\<turnstile>' SKIP : l" |
+Assign2': "sec x \<ge> sec a \<Longrightarrow> \<turnstile>' x ::= a : sec x" |
+Seq2': "\<lbrakk>\<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l\<rbrakk> \<Longrightarrow> \<turnstile>' c\<^sub>1;;c\<^sub>2 : l" |
+If2': "\<lbrakk>sec b \<le> l;  \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l\<rbrakk>
+  \<Longrightarrow> \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2 : l" |
+While2': "\<lbrakk>sec b \<le> l;  \<turnstile>' c : l\<rbrakk> \<Longrightarrow> \<turnstile>' WHILE b DO c : l" |
+anti_mono2': "\<lbrakk>\<turnstile>' c : l; l' \<le> l\<rbrakk> \<Longrightarrow> \<turnstile>' c : l'"
+
+text\<open>
+Prove equivalence with the bottom-up system @{prop "\<turnstile> c : l"}
+without subsumption rule:
+\<close>
+
+lemma "\<turnstile> c : l \<Longrightarrow> \<turnstile>' c : l"
+proof (induct rule: sec_type2.induct)
+  case (Seq2 c\<^sub>1 l\<^sub>1 c\<^sub>2 l\<^sub>2)
+  from Seq2(2, 4) have "\<turnstile>' c\<^sub>1 : min l\<^sub>1 l\<^sub>2" and "\<turnstile>' c\<^sub>2 : min l\<^sub>1 l\<^sub>2" by (auto intro: sec_type2'.intros)
+  then show ?case by (auto intro: sec_type2'.intros)
+next
+  case (If2 b l\<^sub>1 l\<^sub>2 c\<^sub>1 c\<^sub>2)
+  from If2(3, 5) have "\<turnstile>' c\<^sub>1 : min l\<^sub>1 l\<^sub>2" and "\<turnstile>' c\<^sub>2 : min l\<^sub>1 l\<^sub>2" by (auto intro: sec_type2'.intros)
+  with If2(1) show ?case by (auto intro: sec_type2'.intros)
+qed (auto intro: sec_type2'.intros)
+
+lemma "\<turnstile>' c : l \<Longrightarrow> \<exists>l' \<ge> l. \<turnstile> c : l'"
+proof (induct rule: sec_type2'.induct)
+  case (Seq2' c\<^sub>1 l c\<^sub>2)
+  then show ?case by (auto intro: sec_type2.intros min.boundedI)
+next
+  case (If2' b l c\<^sub>1 c\<^sub>2)
+  then show ?case by (auto dest: le_trans intro: sec_type2.intros min.boundedI)
+next
+  case (While2' b l c)
+  then show ?case by (auto dest: le_trans intro: sec_type2.intros)
+next
+  case (anti_mono2' c l l')
+  then show ?case by (auto dest: le_trans)
+qed (auto intro: sec_type2.intros)
+
+text\<open>
+\endexercise
+
+\exercise
+Define a function that erases those parts of a command that
+contain variables above some security level: \<close>
+
+fun erase :: "level \<Rightarrow> com \<Rightarrow> com" where
+  "erase l SKIP = SKIP" |
+  "erase l (x ::= a) = (if sec x < l then (x ::= a) else SKIP)" |
+  "erase l (c\<^sub>1;; c\<^sub>2) = erase l c\<^sub>1;; erase l c\<^sub>2" |
+  "erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (if sec b < l then IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2 else SKIP)" |
+  "erase l (WHILE b DO c) = (if sec b < l then WHILE b DO erase l c else SKIP)"
+
+text\<open>
+Function @{term "erase l"} should replace all assignments to variables with
+security level @{text"\<ge> l"} by @{const SKIP}.
+It should also erase certain @{text IF}s and @{text WHILE}s,
+depending on the security level of the boolean condition. Now show
+that @{text c} and @{term "erase l c"} behave the same on the variables up
+to level @{text l}: \<close>
+
+lemma aval_eq_if_eq_less: "\<lbrakk> s\<^sub>1 = s\<^sub>2 (< l);  sec a < l \<rbrakk> \<Longrightarrow> aval a s\<^sub>1 = aval a s\<^sub>2"
+  by (induct a) auto
+
+lemma bval_eq_if_eq_less: "\<lbrakk> s\<^sub>1 = s\<^sub>2 (< l);  sec b < l \<rbrakk> \<Longrightarrow> bval b s\<^sub>1 = bval b s\<^sub>2"
+  by (induct b) (auto simp add: aval_eq_if_eq_less)
+
+theorem erase_correct: "\<lbrakk>(c,s) \<Rightarrow> s'; (erase l c, t) \<Rightarrow> t'; 0 \<turnstile> c; s = t (< l)\<rbrakk>
+   \<Longrightarrow> s' = t' (< l)"
+proof (induct arbitrary: t t' rule: big_step_induct)
+  case (Skip s)
+  then show ?case by auto
+next
+  case (Assign x a s)
+  then show ?case by (cases "sec x < l") (auto intro!: aval_eq_if_eq_less)
+next
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  then show ?case by fastforce
+next
+  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
+  from IfTrue(5) have Hsec: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
+  show ?case
+  proof (cases "sec b < l")
+    case True
+    from True IfTrue(6) have "s = t (< sec b)" by simp
+    moreover from True IfTrue(1, 6) have "bval b t" by (auto simp add: bval_eq_if_eq_less)
+    ultimately show ?thesis using True IfTrue(4, 6) Hsec(1)
+      by (intro IfTrue(3)) (auto dest: anti_mono)
+  next
+    case False
+    with IfTrue(4) have Htt': "t = t'" by auto
+    thm anti_mono [of "sec b" _ l]
+    with False Hsec have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
+      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
+    with IfTrue(1, 2) have "s = s' (< l)" by (auto dest: confinement)
+    with IfTrue(4, 6) Htt' show ?thesis by auto
+  qed
+next
+  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
+  from IfFalse(5) have Hsecc: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
+  show ?case
+  proof (cases "sec b < l")
+    case True
+    from True IfFalse(6) have "s = t (< sec b)" by simp
+    moreover from True IfFalse(1, 6) have "\<not> bval b t" by (auto simp add: bval_eq_if_eq_less)
+    ultimately show ?thesis using True IfFalse(4, 6) Hsecc(2)
+      by (intro IfFalse(3)) (auto dest: anti_mono)
+  next
+    case False
+    with IfFalse(4) have Htt': "t = t'" by auto
+    thm anti_mono [of "sec b" _ l]
+    with False Hsecc have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
+      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
+    with IfFalse(1, 2) have "s = s' (< l)" by (auto dest: confinement)
+    with IfFalse(4, 6) Htt' show ?thesis by auto
+  qed
+next
+  case (WhileFalse b s c)
+  then show ?case by (cases "sec b < l") (auto simp add: bval_eq_if_eq_less)
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  from WhileTrue(7) have Hsecc: "sec b \<turnstile> c" by auto
+  then show ?case
+  proof (cases "sec b < l")
+    case True
+    with WhileTrue(1, 8) have "bval b t" by (auto simp add: bval_eq_if_eq_less)
+    with True WhileTrue(6) obtain ti where H: "(erase l c, t) \<Rightarrow> ti" "(WHILE b DO erase l c, ti) \<Rightarrow> t'" by auto
+    from this(1) Hsecc WhileTrue(8) have "s\<^sub>2 = ti (< l)" by (intro WhileTrue(3)) (auto intro: anti_mono)
+    with True H(2) WhileTrue(7) show ?thesis by (intro WhileTrue(5)) auto
+  next
+    case False
+    with WhileTrue(2) Hsecc have H1: "s\<^sub>1 = s\<^sub>2 (< l)" by (auto dest: confinement)
+    from False Hsecc have "l \<turnstile> WHILE b DO c" by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
+    with WhileTrue(4) have H2: "s\<^sub>2 = s\<^sub>3 (< l)" by (simp add: confinement)
+    from False WhileTrue(6) have "t = t'" by auto
+    with WhileTrue(8) H1 H2 show ?thesis by simp
+  qed
+qed
+
+text\<open> This theorem looks remarkably like the noninterference lemma from
+theory \mbox{@{theory "HOL-IMP.Sec_Typing"}} (although @{text"\<le>"} has been replaced by @{text"<"}).
+You may want to start with that proof and modify it.
+The structure should remain the same. You may also need one or
+two simple additional lemmas.
+
+In the theorem above we assume that both @{term"(c,s)"}
+and @{term "(erase l c,t)"} terminate. How about the following two properties: \<close>
+
+(* Idea: only problem is with loops whose conditional decides on confidential
+  data. But these loops get erased so that the erased program always terminates
+  once the original program terminates
+*)
+lemma "\<lbrakk> (c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
+  \<Longrightarrow> \<exists>t'. (erase l c, t) \<Rightarrow> t' \<and> s' = t' (< l)"
+proof (induct arbitrary: t rule: big_step_induct)
+  case (Skip s)
+  then show ?case by auto
+next
+  case (Assign x a s)
+  then show ?case
+  proof (cases "sec x < l")
+    case True
+    then have H1: "(erase l (x ::= a), t) \<Rightarrow> t(x := aval a t)" by auto
+    moreover have H2: "(x ::= a, s) \<Rightarrow> s(x := aval a s)" by auto
+    ultimately show ?thesis using Assign by (meson erase_correct)
+  qed auto
+next
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  then show ?case by fastforce
+next
+  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
+  from IfTrue(4) have Hsecc: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
+  show ?case
+  proof (cases "sec b < l")
+    case True
+    with IfTrue(1, 5) have H1: "bval b t" by (auto simp add: bval_eq_if_eq_less)
+    from IfTrue(3, 5) Hsecc(1) obtain t' where H2: "(erase l c\<^sub>1, t) \<Rightarrow> t'" "s' = t' (< l)" by (meson zero_le anti_mono)
+    from H1 H2(1) have "((IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2), t) \<Rightarrow> t'" by auto
+    with True H2(2) show ?thesis by auto
+  next
+    case False
+    then have "(erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2), t) \<Rightarrow> t" by auto
+    moreover
+    from False Hsecc have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
+      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
+    with IfTrue(1, 2) have "s = s' (< l)" by (auto dest: confinement)
+    with IfTrue(5) have "s' = t (< l)" by auto
+    ultimately show ?thesis by blast
+  qed
+next
+  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
+  from IfFalse(4) have Hsecc: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
+  show ?case
+  proof (cases "sec b < l")
+    case True
+    with IfFalse(1, 5) have H1: "\<not>bval b t" by (auto simp add: bval_eq_if_eq_less)
+    from IfFalse(3, 5) Hsecc(2) obtain t' where H2: "(erase l c\<^sub>2, t) \<Rightarrow> t'" "s' = t' (< l)" by (meson zero_le anti_mono)
+    from H1 H2(1) have "((IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2), t) \<Rightarrow> t'" by auto
+    with True H2(2) show ?thesis by auto
+  next
+    case False
+    then have "(erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2), t) \<Rightarrow> t" by auto
+    moreover
+    from False Hsecc have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
+      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
+    with IfFalse(1, 2) have "s = s' (< l)" by (auto dest: confinement)
+    with IfFalse(5) have "s' = t (< l)" by auto
+    ultimately show ?thesis by blast
+  qed
+next
+  case (WhileFalse b s c)
+  then show ?case by (cases "sec b < l") (auto simp add: bval_eq_if_eq_less)
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  from WhileTrue(6) have Hsecc: "sec b \<turnstile> c" by auto
+  then show ?case
+  proof (cases "sec b < l")
+    case True
+    with WhileTrue(1, 7) have Hb: "bval b t" by (auto simp add: bval_eq_if_eq_less)
+    from Hsecc WhileTrue(3, 7) obtain ti where H1: "(erase l c, t) \<Rightarrow> ti" "s\<^sub>2 = ti (< l)" by (force intro: anti_mono)
+    from WhileTrue(5, 6) H1(2) obtain t' where H2: "(erase l (WHILE b DO c), ti) \<Rightarrow> t'" "s\<^sub>3 = t' (< l)" by meson
+    with True Hb H1(1) show ?thesis by auto
+  next
+    case False
+    with WhileTrue(2) Hsecc have H1: "s\<^sub>1 = s\<^sub>2 (< l)" by (auto dest: confinement)
+    from False Hsecc have "l \<turnstile> WHILE b DO c" by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
+    with WhileTrue(4) have H2: "s\<^sub>2 = s\<^sub>3 (< l)" by (simp add: confinement)
+    from False have "(erase l (WHILE b DO c), t) \<Rightarrow> t" by auto
+    with WhileTrue(7) H1 H2 show ?thesis by auto
+  qed
+qed
+
+lemma "\<not>(\<forall> l c s s' t. (erase l c, s) \<Rightarrow> s' \<longrightarrow> 0 \<turnstile> c \<longrightarrow> s = t (< l) \<longrightarrow> (\<exists>t'. (c,t) \<Rightarrow> t' \<and> s' = t' (< l)))"
+proof
+  let ?l = "2 :: nat"
+  let ?b = "Less (N 0) (V ''ab'')"
+  let ?w = "WHILE ?b DO SKIP"
+  let ?a = "''a'' ::= (N 0)"
+  let ?c = "?w;; ?a"
+  let ?s = "(\<lambda> _. 1) :: state"
+  let ?s' = "?s (''a'' := 0)"
+  have [simp]: "sec ''ab'' = 2" using sec_list_def [of "''ab''"] by simp
+  have [simp]: "sec ''a'' = 1" using sec_list_def [of "''a''"] by simp
+  have "(erase ?l ?w, ?s) \<Rightarrow> ?s" by auto
+  moreover have "(?a, ?s) \<Rightarrow> ?s (''a'' := aval (N 0) ?s)" by blast
+  then have "(erase ?l ?a, ?s) \<Rightarrow> ?s'" by auto
+  ultimately have "(erase ?l ?w;; erase ?l ?a, ?s) \<Rightarrow> ?s'" by blast
+  then have H1: "(erase ?l ?c, ?s) \<Rightarrow> ?s'" by simp
+  have "?l \<turnstile> ?w" by (auto intro: sec_type.intros)
+  then have "0 \<turnstile> ?w" by (intro anti_mono [of 2 _ 0]) auto
+  moreover have "1 \<turnstile> ?a" by (auto intro: sec_type.intros)
+  then have "0 \<turnstile> ?a" by (intro anti_mono [of 1 _ 0]) auto
+  ultimately have H2: "0 \<turnstile> ?c" by (auto intro: sec_type.intros)
+  have H3: "?s = ?s (< ?l)" by auto
+  assume "\<forall>l c s s' t. (erase l c, s) \<Rightarrow> s' \<longrightarrow> 0 \<turnstile> c \<longrightarrow> s = t (< l) \<longrightarrow> (\<exists>t'. (c, t) \<Rightarrow> t' \<and> s' = t' (< l))"
+  then obtain HC: "\<And>l c s s' t. \<lbrakk>(erase l c, s) \<Rightarrow> s'; 0 \<turnstile> c; s = t (< l)\<rbrakk> \<Longrightarrow> (\<exists>t'. (c, t) \<Rightarrow> t' \<and> s' = t' (< l))" by blast
+  from HC [OF H1 H2 H3] obtain t' where "(?c, ?s) \<Rightarrow> t'" by blast
+  then obtain ti where "(?w, ?s) \<Rightarrow> ti" by blast
+  then show False
+  by (induct ?w ?s ti rule: big_step_induct) auto
+qed
+
+text\<open> Give proofs or counterexamples.
+\endexercise
+\<close>
+
+end
+
diff --git a/Chapter_13_11/ACom.thy b/Chapter_13_11/ACom.thy
new file mode 100644
index 0000000..16257c9
--- /dev/null
+++ b/Chapter_13_11/ACom.thy
@@ -0,0 +1,226 @@
+theory ACom
+  imports Com
+begin
+
+text \<open>acom is the type of annotated commands (wrt. a type of annotation)\<close>
+datatype 'a acom =
+  SKIP 'a                           ("SKIP {_}" 61) |
+  Assign vname aexp 'a              ("(_ ::= _/ {_})" [1000, 61, 0] 61) |
+  Seq "('a acom)" "('a acom)"       ("_;;//_"  [60, 61] 60) |
+  If bexp 'a "'a acom" 'a "'a acom" 'a
+    ("(IF _/ THEN ({_}/ _)/ ELSE ({_}/ _)//{_})"  [0, 0, 0, 61, 0, 0] 61) |
+  Or "'a acom" "'a acom" 'a
+    ("_ OR// _//{_}" [60, 61, 0] 60) |
+  While 'a bexp 'a "'a acom" 'a
+    ("({_}//WHILE _//DO ({_}//_)//{_})"  [0, 0, 0, 61, 0] 61)
+
+notation com.SKIP ("SKIP")
+
+text \<open>strip maps acoms back to the original commands\<close>
+text_raw\<open>\snip{stripdef}{1}{1}{%\<close>
+fun strip :: "'a acom \<Rightarrow> com" where
+"strip (SKIP {P}) = SKIP" |
+"strip (x ::= e {P}) = x ::= e" |
+"strip (C\<^sub>1;;C\<^sub>2) = strip C\<^sub>1;; strip C\<^sub>2" |
+"strip (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {P}) =
+  IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2" |
+"strip (C\<^sub>1 OR C\<^sub>2 {P}) = strip C\<^sub>1 OR strip C\<^sub>2" |
+"strip ({I} WHILE b DO {P} C {Q}) = WHILE b DO strip C"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>asize counts the number of annotations that a com admits\<close>
+text_raw\<open>\snip{asizedef}{1}{1}{%\<close>
+fun asize :: "com \<Rightarrow> nat" where
+"asize SKIP = 1" |
+"asize (x ::= e) = 1" |
+"asize (C\<^sub>1;;C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2" |
+"asize (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 3" |
+"asize (C\<^sub>1 OR C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 1" |
+"asize (WHILE b DO C) = asize C + 3"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>shift eats the first n elements of a sequence\<close>
+text_raw\<open>\snip{annotatedef}{1}{1}{%\<close>
+definition shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
+"shift f n = (\<lambda>p. f(p+n))"
+
+text \<open>Defined in terms of shift, annotate annotates a command c with a sequence of annotations\<close>
+fun annotate :: "(nat \<Rightarrow> 'a) \<Rightarrow> com \<Rightarrow> 'a acom" where
+"annotate f SKIP = SKIP {f 0}" |
+"annotate f (x ::= e) = x ::= e {f 0}" |
+"annotate f (c\<^sub>1;;c\<^sub>2) = annotate f c\<^sub>1;; annotate (shift f (asize c\<^sub>1)) c\<^sub>2" |
+"annotate f (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
+  IF b THEN {f 0} annotate (shift f 1) c\<^sub>1
+  ELSE {f(asize c\<^sub>1 + 1)} annotate (shift f (asize c\<^sub>1 + 2)) c\<^sub>2
+  {f(asize c\<^sub>1 + asize c\<^sub>2 + 2)}" |
+"annotate f (c\<^sub>1 OR c\<^sub>2) =
+  annotate f c\<^sub>1 OR annotate (shift f (asize c\<^sub>1)) c\<^sub>2 {f (asize c\<^sub>1 + asize c\<^sub>2)}" |
+"annotate f (WHILE b DO c) =
+  {f 0} WHILE b DO {f 1} annotate (shift f 2) c {f(asize c + 2)}"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>annos collects a command's annotations into a list\<close>
+text_raw\<open>\snip{annosdef}{1}{1}{%\<close>
+fun annos :: "'a acom \<Rightarrow> 'a list" where
+"annos (SKIP {P}) = [P]" |
+"annos (x ::= e {P}) = [P]" |
+"annos (C\<^sub>1;;C\<^sub>2) = annos C\<^sub>1 @ annos C\<^sub>2" |
+"annos (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
+  P\<^sub>1 # annos C\<^sub>1 @  P\<^sub>2 # annos C\<^sub>2 @ [Q]" |
+"annos (C\<^sub>1 OR C\<^sub>2 {P}) = annos C\<^sub>1 @ annos C\<^sub>2 @ [P]" |
+"annos ({I} WHILE b DO {P} C {Q}) = I # P # annos C @ [Q]"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>anno retrives the pth annotation of a command, by first collecting its annotations then
+indexing into the pth list element\<close>
+definition anno :: "'a acom \<Rightarrow> nat \<Rightarrow> 'a" where
+"anno C p = annos C ! p"
+
+text \<open>post retrieves the last annotation of a command, by first collecting its annotations\<close>
+definition post :: "'a acom \<Rightarrow>'a" where
+"post C = last(annos C)"
+
+text \<open>map_acom maps the annotations of an acom\<close>
+text_raw\<open>\snip{mapacomdef}{1}{2}{%\<close>
+fun map_acom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a acom \<Rightarrow> 'b acom" where
+"map_acom f (SKIP {P}) = SKIP {f P}" |
+"map_acom f (x ::= e {P}) = x ::= e {f P}" |
+"map_acom f (C\<^sub>1;;C\<^sub>2) = map_acom f C\<^sub>1;; map_acom f C\<^sub>2" |
+"map_acom f (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
+  IF b THEN {f P\<^sub>1} map_acom f C\<^sub>1 ELSE {f P\<^sub>2} map_acom f C\<^sub>2
+  {f Q}" |
+"map_acom f (C\<^sub>1 OR C\<^sub>2 {P}) = map_acom f C\<^sub>1 OR map_acom f C\<^sub>2 {f P}" |
+"map_acom f ({I} WHILE b DO {P} C {Q}) =
+  {f I} WHILE b DO {f P} map_acom f C {f Q}"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>the list of annotations for any command is always nonempty\<close>
+lemma annos_ne: "annos C \<noteq> []"
+by(induction C) auto
+
+text \<open>stripping a command that has been annotated recovers it\<close>
+lemma strip_annotate[simp]: "strip(annotate f c) = c"
+by(induction c arbitrary: f) auto
+
+text \<open>the list of annotations of a com, once annotated, is as large as the number of annotations it admits\<close>
+lemma length_annos_annotate[simp]: "length (annos (annotate f c)) = asize c"
+by(induction c arbitrary: f) auto
+
+text \<open>the size of the list of annotations of a command is as large as the number of annotations its underlying com admits\<close>
+lemma size_annos: "size(annos C) = asize(strip C)"
+by(induction C)(auto)
+
+text \<open>if two acom share the same com, then they have the same number of annotations\<close>
+lemma size_annos_same: "strip C1 = strip C2 \<Longrightarrow> size(annos C1) = size(annos C2)"
+apply(induct C2 arbitrary: C1)
+apply(case_tac C1, simp_all)+
+done
+
+lemmas size_annos_same2 = eqTrueI[OF size_annos_same]
+
+text \<open>dually, the pth annotation is the pth element of the annotating sequence\<close>
+lemma anno_annotate[simp]: "p < asize c \<Longrightarrow> anno (annotate f c) p = f p"
+proof (induction c arbitrary: f p)
+  case SKIP
+  then show ?case by (auto simp: anno_def)
+next
+  case (Assign x1 x2)
+  then show ?case by (auto simp: anno_def)
+next
+  case (Seq c1 c2)
+  then show ?case by (auto simp: anno_def nth_append shift_def)
+next
+  case (If x1 c1 c2)
+  then show ?case
+    by (auto simp: anno_def nth_append nth_Cons shift_def split: nat.split,
+        metis add_Suc_right add_diff_inverse add.commute,
+        rule_tac f=f in arg_cong,
+        arith)
+next
+  case (Or c1 c2)
+  then show ?case
+    by (auto simp: anno_def nth_append shift_def,
+        rule_tac f=f in arg_cong,
+        arith)
+next
+case (While x1 c)
+  then show ?case
+    by (auto simp: anno_def nth_append nth_Cons shift_def
+        split: nat.split, rule_tac f=f in arg_cong,
+        arith)
+qed
+
+text \<open>two acoms are equal iff they have the same underlying command and same list of annotations\<close>
+text \<open>Proof is by inductive definiton of acom, and list lemmas / annos lemmas\<close>
+lemma eq_acom_iff_strip_annos:
+  "C1 = C2 \<longleftrightarrow> strip C1 = strip C2 \<and> annos C1 = annos C2"
+apply(induction C1 arbitrary: C2)
+apply(case_tac C2, auto simp: size_annos_same2)+
+done
+
+text \<open>two acoms are equal iff they have the same underlying command and same sublist of annotations\<close>
+lemma eq_acom_iff_strip_anno:
+  "C1=C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p = anno C2 p)"
+by(auto simp add: eq_acom_iff_strip_annos anno_def
+     list_eq_iff_nth_eq size_annos_same2)
+
+text \<open>the last annotation after mapping through f is exactly the last annotation, then mapping it by f\<close>
+lemma post_map_acom[simp]: "post(map_acom f C) = f(post C)"
+by (induction C) (auto simp: post_def last_append annos_ne)
+
+text \<open>the underlying command is unchanged by map_acom\<close>
+lemma strip_map_acom[simp]: "strip (map_acom f C) = strip C"
+by (induction C) auto
+
+text \<open>the pth annotation after mapping through f is exactly the pth annotation, then mapping it by f\<close>
+lemma anno_map_acom: "p < size(annos C) \<Longrightarrow> anno (map_acom f C) p = f(anno C p)"
+apply(induction C arbitrary: p)
+apply(auto simp: anno_def nth_append nth_Cons' size_annos)
+done
+
+text \<open>inversion lemma for strip C\<close>
+
+lemma strip_eq_SKIP:
+  "strip C = SKIP \<longleftrightarrow> (\<exists>P. C = SKIP {P})"
+by (cases C) simp_all
+
+lemma strip_eq_Assign:
+  "strip C = x::=e \<longleftrightarrow> (\<exists>P. C = x::=e {P})"
+by (cases C) simp_all
+
+lemma strip_eq_Seq:
+  "strip C = c1;;c2 \<longleftrightarrow> (\<exists>C1 C2. C = C1;;C2 & strip C1 = c1 & strip C2 = c2)"
+by (cases C) simp_all
+
+lemma strip_eq_If:
+  "strip C = IF b THEN c1 ELSE c2 \<longleftrightarrow>
+  (\<exists>P1 P2 C1 C2 Q. C = IF b THEN {P1} C1 ELSE {P2} C2 {Q} & strip C1 = c1 & strip C2 = c2)"
+by (cases C) simp_all
+
+lemma strip_eq_Or:
+  "strip C = c1 OR c2 \<longleftrightarrow>
+  (\<exists>C1 C2 P. C = C1 OR C2 {P} & strip C1 = c1 & strip C2 = c2)"
+by (cases C) simp_all
+
+lemma strip_eq_While:
+  "strip C = WHILE b DO c1 \<longleftrightarrow>
+  (\<exists>I P C1 Q. C = {I} WHILE b DO {P} C1 {Q} & strip C1 = c1)"
+by (cases C) simp_all
+
+text \<open>shifting a constant sequence does nothing\<close>
+lemma [simp]: "shift (\<lambda>p. a) n = (\<lambda>p. a)"
+by(simp add:shift_def)
+
+text \<open>the set of all members of an acom created by annotate with a constant sequence on that annotation is a singleton\<close>
+lemma set_annos_anno[simp]: "set (annos (annotate (\<lambda>p. a) c)) = {a}"
+  by(induction c) simp_all
+
+text \<open>the last annotation of an acom is in the set of list of annotations of that acom\<close>
+lemma post_in_annos: "post C \<in> set(annos C)"
+by(auto simp: post_def annos_ne)
+
+text \<open>the last annotation of C is the last element of the list of annotations generated from C.\<close>
+lemma post_anno_asize: "post C = anno C (size(annos C) - 1)"
+  by(simp add: post_def last_conv_nth[OF annos_ne] anno_def)
+
+end
\ No newline at end of file
diff --git a/Chapter_13_11/Big_Step.thy b/Chapter_13_11/Big_Step.thy
new file mode 100644
index 0000000..31b7818
--- /dev/null
+++ b/Chapter_13_11/Big_Step.thy
@@ -0,0 +1,159 @@
+theory Big_Step
+  imports Com
+begin
+
+inductive
+  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
+  where
+    Skip: "(SKIP, s) \<Rightarrow> s" |
+    Assign: "(x ::= a, s) \<Rightarrow> s(x := aval a s)" |
+    Seq: "\<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    IfFalse: "\<lbrakk>\<not>bval b s;  (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk>bval b s\<^sub>1; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    OrLeft: "(c\<^sub>1,s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t" |
+    OrRight: "(c\<^sub>2,s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t"
+
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE [elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE [elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE [elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE [elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE [elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_Or [elim!]: "\<lbrakk>(c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t; (c\<^sub>1, s) \<Rightarrow> t \<Longrightarrow> P; (c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
+by blast
+
+lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
+shows "t = s"
+proof-
+  from assms show ?thesis
+  proof cases  \<comment> \<open>inverting assms\<close>
+    case IfTrue thm IfTrue
+    thus ?thesis by blast
+  next
+    case IfFalse thus ?thesis by blast
+  qed
+qed
+
+lemma assign_simp:
+  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
+  by auto
+lemma Seq_assoc:
+  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
+proof
+  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
+  then obtain s1 s2 where
+    c1: "(c1, s) \<Rightarrow> s1" and
+    c2: "(c2, s1) \<Rightarrow> s2" and
+    c3: "(c3, s2) \<Rightarrow> s'" by auto
+  from c2 c3
+  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
+  with c1
+  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
+next
+  \<comment> \<open>The other direction is analogous\<close>
+  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
+  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
+qed
+
+abbreviation equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
+  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
+lemma unfold_while:
+  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
+proof -
+  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
+  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
+  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
+      case WhileFalse
+      thus ?thesis by blast
+    next
+      case WhileTrue
+      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
+      \<comment> \<open>first, the body of the True-branch:\<close>
+      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
+      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
+    qed
+  qed
+  moreover
+  \<comment> \<open>now the other direction:\<close>
+  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
+      case IfFalse
+      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
+      thus ?thesis using \<open>\<not>bval b s\<close> by blast
+    next
+      case IfTrue
+      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
+      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
+    qed
+  qed
+  ultimately
+  show ?thesis by blast
+qed
+
+lemma while_unfold:
+  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
+by blast
+
+lemma triv_if:
+  "(IF b THEN c ELSE c) \<sim> c"
+by blast
+
+lemma commute_if:
+  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2) 
+   \<sim> 
+   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
+by blast
+
+lemma sim_while_cong_aux:
+  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
+apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
+ apply blast
+apply blast
+done
+
+lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
+by (metis sim_while_cong_aux)
+
+text \<open>Command equivalence is an equivalence relation, i.e.\ it is
+reflexive, symmetric, and transitive. Because we used an abbreviation
+above, Isabelle derives this automatically.\<close>
+
+lemma sim_refl:  "c \<sim> c" by simp
+lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
+lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto
+
+end
\ No newline at end of file
diff --git a/Chapter_13_11/Collecting.thy b/Chapter_13_11/Collecting.thy
new file mode 100644
index 0000000..838f257
--- /dev/null
+++ b/Chapter_13_11/Collecting.thy
@@ -0,0 +1,269 @@
+theory Collecting
+  imports ACom Big_Step "HOL-IMP.Complete_Lattice"
+begin
+
+notation
+  sup (infixl "\<squnion>" 65) and
+  inf (infixl "\<sqinter>" 70) and
+  bot ("\<bottom>") and
+  top ("\<top>")
+
+context
+  fixes f :: "vname \<Rightarrow> aexp \<Rightarrow> 'a \<Rightarrow> 'a::sup"
+  fixes g :: "bexp \<Rightarrow> 'a \<Rightarrow> 'a"
+begin
+fun Step :: "'a \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
+"Step S (SKIP {Q}) = (SKIP {S})" |
+"Step S (x ::= e {Q}) =
+  x ::= e {f x e S}" |
+"Step S (C1;; C2) = Step S C1;; Step (post C1) C2" |
+"Step S (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) =
+  IF b THEN {g b S} Step P1 C1 ELSE {g (Not b) S} Step P2 C2
+  {post C1 \<squnion> post C2}" |
+"Step S (C1 OR C2 {P}) =
+  Step S C1 OR Step S C2
+  {post C1 \<squnion> post C2}" |
+"Step S ({I} WHILE b DO {P} C {Q}) =
+  {S \<squnion> post C} WHILE b DO {g b I} Step P C {g (Not b) I}"
+end
+
+
+text \<open>Step does not change the underlying command\<close>
+lemma strip_Step[simp]: "strip(Step f g S C) = strip C"
+by(induct C arbitrary: S) auto
+
+
+subsubsection "Annotated commands as a complete lattice"
+
+text \<open>We define an order on acom in terms of an order on 'a\<close>
+instantiation acom :: (order) order
+begin
+
+text \<open>The order is as thus: C1 \<le> C2 once they are on the same base command and all annotations on
+C1 \<le> respective annotations on C2\<close>
+definition less_eq_acom :: "('a::order)acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
+"C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p \<le> anno C2 p)"
+
+text \<open>We define strict < in terms of our above definition \<le> and equality\<close>
+definition less_acom :: "'a acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
+"less_acom x y = (x \<le> y \<and> \<not> y \<le> x)"
+
+text \<open>We show that our definitions satisfy order axioms\<close>
+instance
+proof (standard, goal_cases)
+  case 1 show ?case by(simp add: less_acom_def)
+next
+  case 2 thus ?case by(auto simp: less_eq_acom_def)
+next
+  case 3 thus ?case by(fastforce simp: less_eq_acom_def size_annos)
+next
+  case 4 thus ?case
+    by(fastforce simp: le_antisym less_eq_acom_def size_annos
+         eq_acom_iff_strip_anno)
+qed
+
+end
+
+text \<open>In terms of list_all2 instead of explicit indexing\<close>
+lemma less_eq_acom_annos:
+  "C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> list_all2 (\<le>) (annos C1) (annos C2)"
+by(auto simp add: less_eq_acom_def anno_def list_all2_conv_all_nth size_annos_same2)
+
+text \<open>Inversion of order when we know the command of the left operand, inferring the command of the
+right operand and annotation constraints\<close>
+
+lemma SKIP_le[simp]: "SKIP {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = SKIP {S'} \<and> S \<le> S')"
+by (cases c) (auto simp:less_eq_acom_def anno_def)
+
+lemma Assign_le[simp]: "x ::= e {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = x ::= e {S'} \<and> S \<le> S')"
+by (cases c) (auto simp:less_eq_acom_def anno_def)
+
+lemma Seq_le[simp]: "C1;;C2 \<le> C \<longleftrightarrow> (\<exists>C1' C2'. C = C1';;C2' \<and> C1 \<le> C1' \<and> C2 \<le> C2')"
+apply (cases C)
+apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
+done
+
+lemma If_le[simp]: "IF b THEN {p1} C1 ELSE {p2} C2 {S} \<le> C \<longleftrightarrow>
+  (\<exists>p1' p2' C1' C2' S'. C = IF b THEN {p1'} C1' ELSE {p2'} C2' {S'} \<and>
+     p1 \<le> p1' \<and> p2 \<le> p2' \<and> C1 \<le> C1' \<and> C2 \<le> C2' \<and> S \<le> S')"
+apply (cases C)
+apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
+done
+
+lemma Or_le[simp]: "C1 OR C2 {P} \<le> C \<longleftrightarrow>
+  (\<exists>C1' C2' P'. C = C1' OR C2' {P'} \<and>
+     C1 \<le> C1' \<and> C2 \<le> C2' \<and> P \<le> P')"
+apply (cases C)
+apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
+done
+
+lemma While_le[simp]: "{I} WHILE b DO {p} C {P} \<le> W \<longleftrightarrow>
+  (\<exists>I' p' C' P'. W = {I'} WHILE b DO {p'} C' {P'} \<and> C \<le> C' \<and> p \<le> p' \<and> I \<le> I' \<and> P \<le> P')"
+apply (cases W)
+apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
+done
+
+text \<open>obtaining the last annotation is monotonic\<close>
+lemma mono_post: "C \<le> C' \<Longrightarrow> post C \<le> post C'"
+using annos_ne[of C']
+by(auto simp: post_def less_eq_acom_def last_conv_nth[OF annos_ne] anno_def
+     dest: size_annos_same)
+
+text \<open>Inf_acom c M is the infimum among all the annotated commands in M once such an infimum exists\<close>
+definition Inf_acom :: "com \<Rightarrow> 'a::complete_lattice acom set \<Rightarrow> 'a acom" where
+"Inf_acom c M = annotate (\<lambda>p. INF C\<in>M. anno C p) c"
+
+text \<open>expose the Complete_Lattice theorems conditioned on c (annotated commands form a complete lattice
+for each c), once the lemmas are satisfied, where The greatest lower bound for M is Inf_acom c M\<close>
+global_interpretation
+  Complete_Lattice "{C. strip C = c}" "Inf_acom c" for c
+proof (standard, goal_cases)
+  case 1 thus ?case
+    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_lower)
+next
+  case 2 thus ?case
+    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_greatest)
+next
+  case 3 thus ?case by(auto simp: Inf_acom_def)
+qed
+
+
+subsubsection "Collecting semantics"
+
+text \<open>step is Step, partially applied to the assignment and bval semantics of the collecting semantics\<close>
+definition "step = Step (\<lambda>x e S. {s(x := aval e s) |s. s \<in> S}) (\<lambda>b S. {s:S. bval b s})"
+
+text \<open>The collecting semantics of a command is its annotation with the smallest set of states that
+are invariant under stepping through starting from UNIV\<close>
+definition CS :: "com \<Rightarrow> state set acom" where
+"CS c = lfp c (step UNIV)"
+
+text \<open>once the assignment and bval semantics are mono, stepping through is mono\<close>
+lemma mono2_Step: fixes C1 C2 :: "'a::semilattice_sup acom"
+  assumes "!!x e S1 S2. S1 \<le> S2 \<Longrightarrow> f x e S1 \<le> f x e S2"
+          "!!b S1 S2. S1 \<le> S2 \<Longrightarrow> g b S1 \<le> g b S2"
+  shows "C1 \<le> C2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> Step f g S1 C1 \<le> Step f g S2 C2"
+proof(induction S1 C1 arbitrary: C2 S2 rule: Step.induct)
+  case 1 thus ?case by(auto)
+next
+  case 2 thus ?case by (auto simp: assms(1))
+next
+  case 3 thus ?case by(auto simp: mono_post)
+next
+  case 4 thus ?case
+    by(auto simp: subset_iff assms(2))
+      (metis mono_post le_supI1 le_supI2)+
+next
+  case (5 S C1 C2 P CE) thus ?case
+    by auto (metis mono_post le_supI1 le_supI2)+
+next
+  case 6 thus ?case
+    by(auto simp: subset_iff assms(2))
+      (metis mono_post le_supI1 le_supI2)+
+qed
+
+text \<open>and so the same for the step for collecting semantics\<close>
+lemma mono2_step: "C1 \<le> C2 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> step S1 C1 \<le> step S2 C2"
+unfolding step_def by(rule mono2_Step) auto
+
+text \<open>As a corollary, step is mono for fixed S\<close>
+lemma mono_step: "mono (step S)"
+by(blast intro: monoI mono2_step)
+
+text \<open>stepping does not change the underlying command\<close>
+lemma strip_step: "strip(step S C) = strip C"
+by (induction C arbitrary: S) (auto simp: step_def)
+
+text \<open>with step being mono, we know that stepping on a fixed S has an lfp\<close>
+lemma lfp_cs_unfold: "lfp c (step S) = step S (lfp c (step S))"
+apply(rule lfp_unfold[OF _  mono_step])
+apply(simp add: strip_step)
+done
+
+text \<open>hence CS is a fixpoint with respect to stepping through UNIV\<close>
+lemma CS_unfold: "CS c = step UNIV (CS c)"
+by (metis CS_def lfp_cs_unfold)
+
+text \<open>CS also has the same underlying c, by closure\<close>
+lemma strip_CS[simp]: "strip(CS c) = c"
+by(simp add: CS_def index_lfp[simplified])
+
+
+subsubsection "Relation to big-step semantics"
+
+text \<open>the number of annotations any com admits is nonzero\<close>
+lemma asize_nz: "asize(c::com) \<noteq> 0"
+by (metis length_0_conv length_annos_annotate annos_ne)
+
+text \<open>The last annotation of the infimum of a set M of annotated commands on c is exactly the
+infimum among the annotations. By definition, since infimum is pointwise with respect to the
+annotations\<close>
+lemma post_Inf_acom:
+  "\<forall>C\<in>M. strip C = c \<Longrightarrow> post (Inf_acom c M) = \<Inter>(post ` M)"
+apply(subgoal_tac "\<forall>C\<in>M. size(annos C) = asize c")
+ apply(simp add: post_anno_asize Inf_acom_def asize_nz neq0_conv[symmetric])
+apply(simp add: size_annos)
+done
+
+text \<open>Hence similarly for the lfp of f on c\<close>
+lemma post_lfp: "post(lfp c f) = (\<Inter>{post C|C. strip C = c \<and> f C \<le> C})"
+by(auto simp add: lfp_def post_Inf_acom)
+
+text \<open>our step semantics are correct, so step maps a state in the input state s to satisfying its
+last annotation once we know that C is stable under stepping i.e. has (with step S C \<le> C)
+(reasoning: step maps each state satisfying annotation to the satisfying the next annotation in
+step S C, and by (pointwise) stability, it satisfies that same annotation in C. Then repeat by
+stepping through again.)
+
+As for why we use the last annotation, it comes from the big-step semantics that s is the state
+before execution of c and t is the state after execution of C\<close>
+lemma big_step_post_step:
+  "\<lbrakk> (c, s) \<Rightarrow> t;  strip C = c;  s \<in> S;  step S C \<le> C \<rbrakk> \<Longrightarrow> t \<in> post C"
+proof(induction arbitrary: C S rule: big_step_induct)
+  case Skip thus ?case by(auto simp: strip_eq_SKIP step_def post_def)
+next
+  case Assign thus ?case
+    by(fastforce simp: strip_eq_Assign step_def post_def)
+next
+  case Seq thus ?case
+    by(fastforce simp: strip_eq_Seq step_def post_def last_append annos_ne)
+next
+  case IfTrue thus ?case apply(auto simp: strip_eq_If step_def post_def)
+    by (metis (lifting,full_types) mem_Collect_eq subsetD)
+next
+  case IfFalse thus ?case apply(auto simp: strip_eq_If step_def post_def)
+    by (metis (lifting,full_types) mem_Collect_eq subsetD)
+next
+  case OrLeft thus ?case apply(auto simp: strip_eq_Or step_def post_def)
+    by (metis (lifting,full_types) subsetD)
+next
+  case OrRight thus ?case apply(auto simp: strip_eq_Or step_def post_def)
+    by (metis (lifting,full_types) subsetD)
+next
+  case (WhileTrue b s1 c' s2 s3)
+  from WhileTrue.prems(1) obtain I P C' Q where "C = {I} WHILE b DO {P} C' {Q}" "strip C' = c'"
+    by(auto simp: strip_eq_While)
+  from WhileTrue.prems(3) \<open>C = _\<close>
+  have "step P C' \<le> C'"  "{s \<in> I. bval b s} \<le> P"  "S \<le> I"  "step (post C') C \<le> C"
+    by (auto simp: step_def post_def)
+  have "step {s \<in> I. bval b s} C' \<le> C'"
+    by (rule order_trans[OF mono2_step[OF order_refl \<open>{s \<in> I. bval b s} \<le> P\<close>] \<open>step P C' \<le> C'\<close>])
+  have "s1 \<in> {s\<in>I. bval b s}" using \<open>s1 \<in> S\<close> \<open>S \<subseteq> I\<close> \<open>bval b s1\<close> by auto
+  note s2_in_post_C' = WhileTrue.IH(1)[OF \<open>strip C' = c'\<close> this \<open>step {s \<in> I. bval b s} C' \<le> C'\<close>]
+  from WhileTrue.IH(2)[OF WhileTrue.prems(1) s2_in_post_C' \<open>step (post C') C \<le> C\<close>]
+  show ?case .
+next
+  case (WhileFalse b s1 c') thus ?case
+    by (force simp: strip_eq_While step_def post_def)
+qed
+
+text \<open>Thus t is also in the the least fixpoint of stepping wrt an S and c\<close>
+lemma big_step_lfp: "\<lbrakk> (c,s) \<Rightarrow> t;  s \<in> S \<rbrakk> \<Longrightarrow> t \<in> post(lfp c (step S))"
+by(auto simp add: post_lfp intro: big_step_post_step)
+
+text \<open>And so also with UNIV.\<close>
+lemma big_step_CS: "(c,s) \<Rightarrow> t \<Longrightarrow> t \<in> post(CS c)"
+by(simp add: CS_def big_step_lfp)
+
+
+end
\ No newline at end of file
diff --git a/Chapter_13_11/Com.thy b/Chapter_13_11/Com.thy
new file mode 100644
index 0000000..9bae85d
--- /dev/null
+++ b/Chapter_13_11/Com.thy
@@ -0,0 +1,13 @@
+theory Com
+  imports "HOL-IMP.BExp"
+begin
+
+datatype
+  com = SKIP 
+      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
+      | Or     com com          ("_/ OR _" [60, 61] 61)
+      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+
+end
\ No newline at end of file
diff --git a/Chapter_13_18/Abs_Int0.thy b/Chapter_13_18/Abs_Int0.thy
new file mode 100644
index 0000000..554f262
--- /dev/null
+++ b/Chapter_13_18/Abs_Int0.thy
@@ -0,0 +1,490 @@
+(* Author: Tobias Nipkow *)
+
+subsection "Abstract Interpretation"
+
+theory Abs_Int0
+imports "HOL-IMP.Abs_Int_init"
+begin
+
+subsubsection "Orderings"
+
+text\<open>The basic type classes \<^class>\<open>order\<close>, \<^class>\<open>semilattice_sup\<close> and \<^class>\<open>order_top\<close> are
+defined in \<^theory>\<open>Main\<close>, more precisely in theories \<^theory>\<open>HOL.Orderings\<close> and \<^theory>\<open>HOL.Lattices\<close>.
+If you view this theory with jedit, just click on the names to get there.\<close>
+
+class semilattice_sup_top = semilattice_sup + order_top
+
+
+instance "fun" :: (type, semilattice_sup_top) semilattice_sup_top ..
+
+instantiation option :: (order)order
+begin
+
+fun less_eq_option where
+"Some x \<le> Some y = (x \<le> y)" |
+"None \<le> y = True" |
+"Some _ \<le> None = False"
+
+definition less_option where "x < (y::'a option) = (x \<le> y \<and> \<not> y \<le> x)"
+
+lemma le_None[simp]: "(x \<le> None) = (x = None)"
+by (cases x) simp_all
+
+lemma Some_le[simp]: "(Some x \<le> u) = (\<exists>y. u = Some y \<and> x \<le> y)"
+by (cases u) auto
+
+instance
+proof (standard, goal_cases)
+  case 1 show ?case by(rule less_option_def)
+next
+  case (2 x) show ?case by(cases x, simp_all)
+next
+  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, auto)
+next
+  case (4 x y) thus ?case by(cases y, simp, cases x, auto)
+qed
+
+end
+
+instantiation option :: (sup)sup
+begin
+
+fun sup_option where
+"Some x \<squnion> Some y = Some(x \<squnion> y)" |
+"None \<squnion> y = y" |
+"x \<squnion> None = x"
+
+lemma sup_None2[simp]: "x \<squnion> None = x"
+by (cases x) simp_all
+
+instance ..
+
+end
+
+instantiation option :: (semilattice_sup_top)semilattice_sup_top
+begin
+
+definition top_option where "\<top> = Some \<top>"
+
+instance
+proof (standard, goal_cases)
+  case (4 a) show ?case by(cases a, simp_all add: top_option_def)
+next
+  case (1 x y) thus ?case by(cases x, simp, cases y, simp_all)
+next
+  case (2 x y) thus ?case by(cases y, simp, cases x, simp_all)
+next
+  case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
+qed
+
+end
+
+lemma [simp]: "(Some x < Some y) = (x < y)"
+by(auto simp: less_le)
+
+instantiation option :: (order)order_bot
+begin
+
+definition bot_option :: "'a option" where
+"\<bottom> = None"
+
+instance
+proof (standard, goal_cases)
+  case 1 thus ?case by(auto simp: bot_option_def)
+qed
+
+end
+
+
+definition bot :: "com \<Rightarrow> 'a option acom" where
+"bot c = annotate (\<lambda>p. None) c"
+
+lemma bot_least: "strip C = c \<Longrightarrow> bot c \<le> C"
+by(auto simp: bot_def less_eq_acom_def)
+
+lemma strip_bot[simp]: "strip(bot c) = c"
+by(simp add: bot_def)
+
+
+subsubsection "Pre-fixpoint iteration"
+
+definition pfp :: "(('a::order) \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
+"pfp f = while_option (\<lambda>x. \<not> f x \<le> x) f"
+
+lemma pfp_pfp: assumes "pfp f x0 = Some x" shows "f x \<le> x"
+using while_option_stop[OF assms[simplified pfp_def]] by simp
+
+lemma while_least:
+fixes q :: "'a::order"
+assumes "\<forall>x\<in>L.\<forall>y\<in>L. x \<le> y \<longrightarrow> f x \<le> f y" and "\<forall>x. x \<in> L \<longrightarrow> f x \<in> L"
+and "\<forall>x \<in> L. b \<le> x" and "b \<in> L" and "f q \<le> q" and "q \<in> L"
+and "while_option P f b = Some p"
+shows "p \<le> q"
+using while_option_rule[OF _  assms(7)[unfolded pfp_def],
+                        where P = "%x. x \<in> L \<and> x \<le> q"]
+by (metis assms(1-6) order_trans)
+
+lemma pfp_bot_least:
+assumes "\<forall>x\<in>{C. strip C = c}.\<forall>y\<in>{C. strip C = c}. x \<le> y \<longrightarrow> f x \<le> f y"
+and "\<forall>C. C \<in> {C. strip C = c} \<longrightarrow> f C \<in> {C. strip C = c}"
+and "f C' \<le> C'" "strip C' = c" "pfp f (bot c) = Some C"
+shows "C \<le> C'"
+by(rule while_least[OF assms(1,2) _ _ assms(3) _ assms(5)[unfolded pfp_def]])
+  (simp_all add: assms(4) bot_least)
+
+lemma pfp_inv:
+  "pfp f x = Some y \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P(f x)) \<Longrightarrow> P x \<Longrightarrow> P y"
+unfolding pfp_def by (blast intro: while_option_rule)
+
+lemma strip_pfp:
+assumes "\<And>x. g(f x) = g x" and "pfp f x0 = Some x" shows "g x = g x0"
+using pfp_inv[OF assms(2), where P = "%x. g x = g x0"] assms(1) by simp
+
+
+subsubsection "Abstract Interpretation"
+
+definition \<gamma>_fun :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b)set" where
+"\<gamma>_fun \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(F x)}"
+
+fun \<gamma>_option :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a option \<Rightarrow> 'b set" where
+"\<gamma>_option \<gamma> None = {}" |
+"\<gamma>_option \<gamma> (Some a) = \<gamma> a"
+
+text\<open>The interface for abstract values:\<close>
+
+locale Val_semilattice =
+fixes \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
+  assumes mono_gamma: "a \<le> b \<Longrightarrow> \<gamma> a \<le> \<gamma> b"
+  and gamma_Top[simp]: "\<gamma> \<top> = UNIV"
+fixes num' :: "val \<Rightarrow> 'av"
+  and plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av"
+  and less' :: "'av \<Rightarrow> 'av \<Rightarrow> bool option"
+assumes gamma_num': "i \<in> \<gamma>(num' i)"
+  and gamma_plus': "\<lbrakk>i1 \<in> \<gamma> a1; i2 \<in> \<gamma> a2\<rbrakk> \<Longrightarrow> i1+i2 \<in> \<gamma>(plus' a1 a2)"
+  and gamma_less': "\<lbrakk>i1 \<in> \<gamma> a1; i2 \<in> \<gamma> a2\<rbrakk> \<Longrightarrow> less' a1 a2 = None \<or> less' a1 a2 = Some (i1 < i2)"
+
+type_synonym 'av st = "(vname \<Rightarrow> 'av)"
+
+text\<open>The for-clause (here and elsewhere) only serves the purpose of fixing
+the name of the type parameter \<^typ>\<open>'av\<close> which would otherwise be renamed to
+\<^typ>\<open>'a\<close>.\<close>
+
+locale Abs_Int_fun = Val_semilattice where \<gamma>=\<gamma>
+  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
+begin
+
+fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
+"aval' (N i) S = num' i" |
+"aval' (V x) S = S x" |
+"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"
+
+definition "asem x e S = (case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(S(x := aval' e S)))"
+
+definition "step' = Step asem (\<lambda>b S. S)"
+
+lemma strip_step'[simp]: "strip(step' S C) = strip C"
+by(simp add: step'_def)
+
+definition AI :: "com \<Rightarrow> 'av st option acom option" where
+"AI c = pfp (step' \<top>) (bot c)"
+
+
+abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
+where "\<gamma>\<^sub>s == \<gamma>_fun \<gamma>"
+
+abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
+where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"
+
+abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
+where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"
+
+lemma gamma_s_Top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
+by(simp add: top_fun_def \<gamma>_fun_def)
+
+lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
+by (simp add: top_option_def)
+
+lemma mono_gamma_s: "f1 \<le> f2 \<Longrightarrow> \<gamma>\<^sub>s f1 \<subseteq> \<gamma>\<^sub>s f2"
+by(auto simp: le_fun_def \<gamma>_fun_def dest: mono_gamma)
+
+lemma mono_gamma_o:
+  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
+by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)
+
+lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
+by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])
+
+text\<open>Correctness:\<close>
+
+lemma aval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> aval a s \<in> \<gamma>(aval' a S)"
+by (induct a) (auto simp: gamma_num' gamma_plus' \<gamma>_fun_def)
+
+lemma in_gamma_update: "\<lbrakk> s \<in> \<gamma>\<^sub>s S; i \<in> \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) \<in> \<gamma>\<^sub>s(S(x := a))"
+by(simp add: \<gamma>_fun_def)
+
+lemma gamma_Step_subcomm:
+  assumes "\<And>x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"  "\<And>b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
+  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
+by (induction C arbitrary: S) (auto simp: mono_gamma_o assms)
+
+lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
+unfolding step_def step'_def
+by(rule gamma_Step_subcomm)
+  (auto simp: aval'_correct in_gamma_update asem_def split: option.splits)
+
+lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
+proof(simp add: CS_def AI_def)
+  assume 1: "pfp (step' \<top>) (bot c) = Some C"
+  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
+  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  \<comment> \<open>transfer the pfp'\<close>
+  proof(rule order_trans)
+    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
+    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
+  qed
+  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
+  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
+    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
+  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
+qed
+
+end
+
+
+subsubsection "Monotonicity"
+
+locale Abs_Int_fun_mono = Abs_Int_fun +
+assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
+begin
+
+lemma mono_aval': "S \<le> S' \<Longrightarrow> aval' e S \<le> aval' e S'"
+by(induction e)(auto simp: le_fun_def mono_plus')
+
+lemma mono_update: "a \<le> a' \<Longrightarrow> S \<le> S' \<Longrightarrow> S(x := a) \<le> S'(x := a')"
+by(simp add: le_fun_def)
+
+lemma mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
+unfolding step'_def
+by(rule mono2_Step)
+  (auto simp: mono_update mono_aval' asem_def split: option.split)
+
+lemma mono_step'_top: "C \<le> C' \<Longrightarrow> step' \<top> C \<le> step' \<top> C'"
+by (metis mono_step' order_refl)
+
+lemma AI_least_pfp: assumes "AI c = Some C" "step' \<top> C' \<le> C'" "strip C' = c"
+shows "C \<le> C'"
+by(rule pfp_bot_least[OF _ _ assms(2,3) assms(1)[unfolded AI_def]])
+  (simp_all add: mono_step'_top)
+
+end
+
+
+instantiation acom :: (type) vars
+begin
+
+definition "vars_acom = vars o strip"
+
+instance ..
+
+end
+
+lemma finite_Cvars: "finite(vars(C::'a acom))"
+by(simp add: vars_acom_def)
+
+
+subsubsection "Termination"
+
+lemma pfp_termination:
+fixes x0 :: "'a::order" and m :: "'a \<Rightarrow> nat"
+assumes mono: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
+and m: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x < y \<Longrightarrow> m x > m y"
+and I: "\<And>x y. I x \<Longrightarrow> I(f x)" and "I x0" and "x0 \<le> f x0"
+shows "\<exists>x. pfp f x0 = Some x"
+proof(simp add: pfp_def, rule wf_while_option_Some[where P = "%x. I x & x \<le> f x"])
+  show "wf {(y,x). ((I x \<and> x \<le> f x) \<and> \<not> f x \<le> x) \<and> y = f x}"
+    by(rule wf_subset[OF wf_measure[of m]]) (auto simp: m I)
+next
+  show "I x0 \<and> x0 \<le> f x0" using \<open>I x0\<close> \<open>x0 \<le> f x0\<close> by blast
+next
+  fix x assume "I x \<and> x \<le> f x" thus "I(f x) \<and> f x \<le> f(f x)"
+    by (blast intro: I mono)
+qed
+
+lemma le_iff_le_annos: "C1 \<le> C2 \<longleftrightarrow>
+  strip C1 = strip C2 \<and> (\<forall> i<size(annos C1). annos C1 ! i \<le> annos C2 ! i)"
+by(simp add: less_eq_acom_def anno_def)
+
+locale Measure1_fun =
+fixes m :: "'av::top \<Rightarrow> nat"
+fixes h :: "nat"
+assumes h: "m x \<le> h"
+begin
+
+definition m_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>s") where
+"m_s S X = (\<Sum> x \<in> X. m(S x))"
+
+lemma m_s_h: "finite X \<Longrightarrow> m_s S X \<le> h * card X"
+by(simp add: m_s_def) (metis mult.commute of_nat_id sum_bounded_above[OF h])
+
+fun m_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>o") where
+"m_o (Some S) X = m_s S X" |
+"m_o None X = h * card X + 1"
+
+lemma m_o_h: "finite X \<Longrightarrow> m_o opt X \<le> (h*card X + 1)"
+by(cases opt)(auto simp add: m_s_h le_SucI dest: m_s_h)
+
+definition m_c :: "'av st option acom \<Rightarrow> nat" ("m\<^sub>c") where
+"m_c C = sum_list (map (\<lambda>a. m_o a (vars C)) (annos C))"
+
+text\<open>Upper complexity bound:\<close>
+lemma m_c_h: "m_c C \<le> size(annos C) * (h * card(vars C) + 1)"
+proof-
+  let ?X = "vars C" let ?n = "card ?X" let ?a = "size(annos C)"
+  have "m_c C = (\<Sum>i<?a. m_o (annos C ! i) ?X)"
+    by(simp add: m_c_def sum_list_sum_nth atLeast0LessThan)
+  also have "\<dots> \<le> (\<Sum>i<?a. h * ?n + 1)"
+    apply(rule sum_mono) using m_o_h[OF finite_Cvars] by simp
+  also have "\<dots> = ?a * (h * ?n + 1)" by simp
+  finally show ?thesis .
+qed
+
+end
+
+
+locale Measure_fun = Measure1_fun where m=m
+  for m :: "'av::semilattice_sup_top \<Rightarrow> nat" +
+assumes m2: "x < y \<Longrightarrow> m x > m y"
+begin
+
+text\<open>The predicates \<open>top_on_ty a X\<close> that follow describe that any abstract
+state in \<open>a\<close> maps all variables in \<open>X\<close> to \<^term>\<open>\<top>\<close>.
+This is an important invariant for the termination proof where we argue that only
+the finitely many variables in the program change. That the others do not change
+follows because they remain \<^term>\<open>\<top>\<close>.\<close>
+
+fun top_on_st :: "'av st \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>s") where
+"top_on_st S X = (\<forall>x\<in>X. S x = \<top>)"
+
+fun top_on_opt :: "'av st option \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>o") where
+"top_on_opt (Some S) X = top_on_st S X" |
+"top_on_opt None X = True"
+
+definition top_on_acom :: "'av st option acom \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>c") where
+"top_on_acom C X = (\<forall>a \<in> set(annos C). top_on_opt a X)"
+
+lemma top_on_top: "top_on_opt \<top> X"
+by(auto simp: top_option_def)
+
+lemma top_on_bot: "top_on_acom (bot c) X"
+by(auto simp add: top_on_acom_def bot_def)
+
+lemma top_on_post: "top_on_acom C X \<Longrightarrow> top_on_opt (post C) X"
+by(simp add: top_on_acom_def post_in_annos)
+
+lemma top_on_acom_simps:
+  "top_on_acom (SKIP {Q}) X = top_on_opt Q X"
+  "top_on_acom (x ::= e {Q}) X = top_on_opt Q X"
+  "top_on_acom (C1;;C2) X = (top_on_acom C1 X \<and> top_on_acom C2 X)"
+  "top_on_acom (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) X =
+   (top_on_opt P1 X \<and> top_on_acom C1 X \<and> top_on_opt P2 X \<and> top_on_acom C2 X \<and> top_on_opt Q X)"
+  "top_on_acom ({I} WHILE b DO {P} C {Q}) X =
+   (top_on_opt I X \<and> top_on_acom C X \<and> top_on_opt P X \<and> top_on_opt Q X)"
+by(auto simp add: top_on_acom_def)
+
+lemma top_on_sup:
+  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<squnion> o2) X"
+apply(induction o1 o2 rule: sup_option.induct)
+apply(auto)
+done
+
+lemma top_on_Step: fixes C :: "'av st option acom"
+assumes "!!x e S. \<lbrakk>top_on_opt S X; x \<notin> X; vars e \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (f x e S) X"
+        "!!b S. top_on_opt S X \<Longrightarrow> vars b \<subseteq> -X \<Longrightarrow> top_on_opt (g b S) X"
+shows "\<lbrakk> vars C \<subseteq> -X; top_on_opt S X; top_on_acom C X \<rbrakk> \<Longrightarrow> top_on_acom (Step f g S C) X"
+proof(induction C arbitrary: S)
+qed (auto simp: top_on_acom_simps vars_acom_def top_on_post top_on_sup assms)
+
+lemma m1: "x \<le> y \<Longrightarrow> m x \<ge> m y"
+by(auto simp: le_less m2)
+
+lemma m_s2_rep: assumes "finite(X)" and "S1 = S2 on -X" and "\<forall>x. S1 x \<le> S2 x" and "S1 \<noteq> S2"
+shows "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
+proof-
+  from assms(3) have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S2 x)" by (simp add: m1)
+  from assms(2,3,4) have "\<exists>x\<in>X. S1 x < S2 x"
+    by(simp add: fun_eq_iff) (metis Compl_iff le_neq_trans)
+  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S2 x)" by (metis m2)
+  from sum_strict_mono_ex1[OF \<open>finite X\<close> 1 2]
+  show "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))" .
+qed
+
+lemma m_s2: "finite(X) \<Longrightarrow> S1 = S2 on -X \<Longrightarrow> S1 < S2 \<Longrightarrow> m_s S1 X > m_s S2 X"
+apply(auto simp add: less_fun_def m_s_def)
+apply(simp add: m_s2_rep le_fun_def)
+done
+
+lemma m_o2: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
+  o1 < o2 \<Longrightarrow> m_o o1 X > m_o o2 X"
+proof(induction o1 o2 rule: less_eq_option.induct)
+  case 1 thus ?case by (auto simp: m_s2 less_option_def)
+next
+  case 2 thus ?case by(auto simp: less_option_def le_imp_less_Suc m_s_h)
+next
+  case 3 thus ?case by (auto simp: less_option_def)
+qed
+
+lemma m_o1: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
+  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
+by(auto simp: le_less m_o2)
+
+
+lemma m_c2: "top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2) \<Longrightarrow>
+  C1 < C2 \<Longrightarrow> m_c C1 > m_c C2"
+proof(auto simp add: le_iff_le_annos size_annos_same[of C1 C2] vars_acom_def less_acom_def)
+  let ?X = "vars(strip C2)"
+  assume top: "top_on_acom C1 (- vars(strip C2))"  "top_on_acom C2 (- vars(strip C2))"
+  and strip_eq: "strip C1 = strip C2"
+  and 0: "\<forall>i<size(annos C2). annos C1 ! i \<le> annos C2 ! i"
+  hence 1: "\<forall>i<size(annos C2). m_o (annos C1 ! i) ?X \<ge> m_o (annos C2 ! i) ?X"
+    apply (auto simp: all_set_conv_all_nth vars_acom_def top_on_acom_def)
+    by (metis (lifting, no_types) finite_cvars m_o1 size_annos_same2)
+  fix i assume i: "i < size(annos C2)" "\<not> annos C2 ! i \<le> annos C1 ! i"
+  have topo1: "top_on_opt (annos C1 ! i) (- ?X)"
+    using i(1) top(1) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
+  have topo2: "top_on_opt (annos C2 ! i) (- ?X)"
+    using i(1) top(2) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
+  from i have "m_o (annos C1 ! i) ?X > m_o (annos C2 ! i) ?X" (is "?P i")
+    by (metis 0 less_option_def m_o2[OF finite_cvars topo1] topo2)
+  hence 2: "\<exists>i < size(annos C2). ?P i" using \<open>i < size(annos C2)\<close> by blast
+  have "(\<Sum>i<size(annos C2). m_o (annos C2 ! i) ?X)
+         < (\<Sum>i<size(annos C2). m_o (annos C1 ! i) ?X)"
+    apply(rule sum_strict_mono_ex1) using 1 2 by (auto)
+  thus ?thesis
+    by(simp add: m_c_def vars_acom_def strip_eq sum_list_sum_nth atLeast0LessThan size_annos_same[OF strip_eq])
+qed
+
+end
+
+
+locale Abs_Int_fun_measure =
+  Abs_Int_fun_mono where \<gamma>=\<gamma> + Measure_fun where m=m
+  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"
+begin
+
+lemma top_on_step': "top_on_acom C (-vars C) \<Longrightarrow> top_on_acom (step' \<top> C) (-vars C)"
+unfolding step'_def
+by(rule top_on_Step)
+  (auto simp add: top_option_def asem_def split: option.splits)
+
+lemma AI_Some_measure: "\<exists>C. AI c = Some C"
+unfolding AI_def
+apply(rule pfp_termination[where I = "\<lambda>C. top_on_acom C (- vars C)" and m="m_c"])
+apply(simp_all add: m_c2 mono_step'_top bot_least top_on_bot)
+using top_on_step' apply(auto simp add: vars_acom_def)
+done
+
+end
+
+text\<open>Problem: not executable because of the comparison of abstract states,
+i.e. functions, in the pre-fixpoint computation.\<close>
+
+end
diff --git a/Chapter_13_18/Abs_Int1.thy b/Chapter_13_18/Abs_Int1.thy
new file mode 100644
index 0000000..f662d4b
--- /dev/null
+++ b/Chapter_13_18/Abs_Int1.thy
@@ -0,0 +1,98 @@
+(* Author: Tobias Nipkow *)
+
+subsection "Computable Abstract Interpretation"
+
+theory Abs_Int1
+imports Abs_State
+begin
+
+text\<open>Abstract interpretation over type \<open>st\<close> instead of functions.\<close>
+
+context Gamma_semilattice
+begin
+
+fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
+  "aval' (N i) S = num' i" |
+  "aval' (V x) S = fun S x" |
+  "aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"
+
+lemma aval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> aval a s \<in> \<gamma>(aval' a S)"
+  by (induction a) (auto simp: gamma_num' gamma_plus' \<gamma>_st_def)
+
+fun bval' :: "bexp \<Rightarrow> 'av st \<Rightarrow> bool option" where
+  "bval' (Bc v) _ = Some v" |
+  "bval' (Not b) S = (case bval' b S of None \<Rightarrow> None | Some v' \<Rightarrow> Some (\<not>v'))" |
+  "bval' (And b\<^sub>1 b\<^sub>2) S = (case (bval' b\<^sub>1 S, bval' b\<^sub>2 S) of
+    (Some False, _) \<Rightarrow> Some False |
+    (_, Some False) \<Rightarrow> Some False |
+    (None, _) \<Rightarrow> None |
+    (_, None) \<Rightarrow> None |
+    (Some True, Some True) \<Rightarrow> Some True)" |
+  "bval' (Less a\<^sub>1 a\<^sub>2) S = less' (aval' a\<^sub>1 S) (aval' a\<^sub>2 S)"
+
+lemma bval'_correct: "s \<in> \<gamma>\<^sub>s S \<Longrightarrow> bval' b S = None \<or> bval' b S = Some (bval b s)"
+  by (induct b) (auto simp: gamma_less' aval'_correct split: bool.split_asm)
+
+lemma gamma_Step_subcomm: fixes C1 C2 :: "'a::semilattice_sup acom"
+  assumes "!!x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"
+          "!!b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
+  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
+proof(induction C arbitrary: S)
+qed (auto simp: assms intro!: mono_gamma_o sup_ge1 sup_ge2)
+
+lemma in_gamma_update: "\<lbrakk> s \<in> \<gamma>\<^sub>s S; i \<in> \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) \<in> \<gamma>\<^sub>s(update S x a)"
+by(simp add: \<gamma>_st_def)
+
+end
+
+
+locale Abs_Int = Gamma_semilattice where \<gamma>=\<gamma>
+  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
+begin
+
+definition "step' = Step
+  (\<lambda>x e S. case S of None \<Rightarrow> None | Some S' \<Rightarrow> Some(update S' x (aval' e S')))
+  (\<lambda>b S. case S of None \<Rightarrow> None |
+    Some S' \<Rightarrow> (case bval' b S' of Some False \<Rightarrow> None | _ \<Rightarrow> Some S'))"
+
+definition AI :: "com \<Rightarrow> 'av st option acom option" where
+"AI c = pfp (step' \<top>) (bot c)"
+
+
+lemma strip_step'[simp]: "strip(step' S C) = strip C"
+by(simp add: step'_def)
+
+
+text\<open>Correctness:\<close>
+
+lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
+unfolding step_def step'_def
+proof (rule gamma_Step_subcomm, auto simp: intro!: aval'_correct in_gamma_update split: option.splits bool.splits)
+  fix b s S
+  assume "s \<in> \<gamma>\<^sub>s S"
+  then have "bval' b S = None \<or> bval' b S = Some (bval b s)" by (simp add: bval'_correct)
+  moreover assume "bval' b S = Some False"
+  ultimately have "\<not>bval b s" by auto
+  moreover assume "bval b s"
+  ultimately show False by auto
+qed
+
+lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
+proof(simp add: CS_def AI_def)
+  assume 1: "pfp (step' \<top>) (bot c) = Some C"
+  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
+  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  \<comment> \<open>transfer the pfp'\<close>
+  proof(rule order_trans)
+    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
+    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
+  qed
+  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
+  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
+    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
+  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
+qed
+
+end
+
+
+end
diff --git a/Chapter_13_18/Abs_Int1_const.thy b/Chapter_13_18/Abs_Int1_const.thy
new file mode 100644
index 0000000..6af9ae4
--- /dev/null
+++ b/Chapter_13_18/Abs_Int1_const.thy
@@ -0,0 +1,131 @@
+(* Author: Tobias Nipkow *)
+
+subsection "Constant Propagation"
+
+theory Abs_Int1_const
+imports Abs_Int1
+begin
+
+datatype const = Const val | Any
+
+fun \<gamma>_const where
+"\<gamma>_const (Const i) = {i}" |
+"\<gamma>_const (Any) = UNIV"
+
+fun plus_const where
+"plus_const (Const i) (Const j) = Const(i+j)" |
+"plus_const _ _ = Any"
+
+fun less_const where
+"less_const (Const i) (Const j) = Some (i < j)" |
+"less_const _ _ = None"
+
+lemma plus_const_cases: "plus_const a1 a2 =
+  (case (a1,a2) of (Const i, Const j) \<Rightarrow> Const(i+j) | _ \<Rightarrow> Any)"
+by(auto split: prod.split const.split)
+
+lemma less_const_cases: "less_const a1 a2 =
+  (case (a1,a2) of (Const i, Const j) \<Rightarrow> Some (i < j) | _ \<Rightarrow> None)"
+by(auto split: prod.split const.split)
+
+instantiation const :: semilattice_sup_top
+begin
+
+fun less_eq_const where "x \<le> y = (y = Any | x=y)"
+
+definition "x < (y::const) = (x \<le> y & \<not> y \<le> x)"
+
+fun sup_const where "x \<squnion> y = (if x=y then x else Any)"
+
+definition "\<top> = Any"
+
+instance
+proof (standard, goal_cases)
+  case 1 thus ?case by (rule less_const_def)
+next
+  case (2 x) show ?case by (cases x) simp_all
+next
+  case (3 x y z) thus ?case by(cases z, cases y, cases x, simp_all)
+next
+  case (4 x y) thus ?case by(cases x, cases y, simp_all, cases y, simp_all)
+next
+  case (6 x y) thus ?case by(cases x, cases y, simp_all)
+next
+  case (5 x y) thus ?case by(cases y, cases x, simp_all)
+next
+  case (7 x y z) thus ?case by(cases z, cases y, cases x, simp_all)
+next
+  case 8 thus ?case by(simp add: top_const_def)
+qed
+
+end
+
+
+global_interpretation Val_semilattice
+where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const and less' = less_const
+proof (standard, goal_cases)
+  case (1 a b) thus ?case
+    by(cases a, cases b, simp, simp, cases b, simp, simp)
+next
+  case 2 show ?case by(simp add: top_const_def)
+next
+  case (3 i) show ?case by simp
+next
+  case (4 i1 a1 i2 a2) then show ?case by(auto simp: plus_const_cases split: const.split)
+next
+  case (5 i1 a1 i2 a2)
+  then show ?case by(auto simp: less_const_cases split: const.split)
+qed
+
+global_interpretation Abs_Int
+where \<gamma> = \<gamma>_const and num' = Const and plus' = plus_const and less' = less_const
+defines AI_const = AI and step_const = step' and aval'_const = aval' and bval'_const = bval'
+..
+
+
+subsubsection "Tests"
+
+definition "steps c i = (step_const \<top> ^^ i) (bot c)"
+
+value "show_acom (steps test1_const 0)"
+value "show_acom (steps test1_const 1)"
+value "show_acom (steps test1_const 2)"
+value "show_acom (steps test1_const 3)"
+value "show_acom (the(AI_const test1_const))"
+
+value "show_acom (the(AI_const test2_const))"
+value "show_acom (the(AI_const test3_const))"
+
+value "show_acom (steps test4_const 0)"
+value "show_acom (steps test4_const 1)"
+value "show_acom (steps test4_const 2)"
+value "show_acom (steps test4_const 3)"
+value "show_acom (steps test4_const 4)"
+value "show_acom (the(AI_const test4_const))"
+
+value "show_acom (steps test5_const 0)"
+value "show_acom (steps test5_const 1)"
+value "show_acom (steps test5_const 2)"
+value "show_acom (steps test5_const 3)"
+value "show_acom (steps test5_const 4)"
+value "show_acom (steps test5_const 5)"
+value "show_acom (steps test5_const 6)"
+value "show_acom (the(AI_const test5_const))"
+
+value "show_acom (steps test6_const 0)"
+value "show_acom (steps test6_const 1)"
+value "show_acom (steps test6_const 2)"
+value "show_acom (steps test6_const 3)"
+value "show_acom (steps test6_const 4)"
+value "show_acom (steps test6_const 5)"
+value "show_acom (steps test6_const 6)"
+value "show_acom (steps test6_const 7)"
+value "show_acom (steps test6_const 8)"
+value "show_acom (steps test6_const 9)"
+value "show_acom (steps test6_const 10)"
+value "show_acom (steps test6_const 11)"
+value "show_acom (steps test6_const 12)"
+value "show_acom (steps test6_const 13)"
+value "show_acom (the(AI_const test6_const))"
+
+end
diff --git a/Chapter_13_18/Abs_State.thy b/Chapter_13_18/Abs_State.thy
new file mode 100644
index 0000000..12f82ea
--- /dev/null
+++ b/Chapter_13_18/Abs_State.thy
@@ -0,0 +1,167 @@
+(* Author: Tobias Nipkow *)
+
+subsection "Computable State"
+
+theory Abs_State
+imports Abs_Int0
+begin
+
+type_synonym 'a st_rep = "(vname * 'a) list"
+
+fun fun_rep :: "('a::top) st_rep \<Rightarrow> vname \<Rightarrow> 'a" where
+"fun_rep [] = (\<lambda>x. \<top>)" |
+"fun_rep ((x,a)#ps) = (fun_rep ps) (x := a)"
+
+lemma fun_rep_map_of[code]: \<comment> \<open>original def is too slow\<close>
+  "fun_rep ps = (%x. case map_of ps x of None \<Rightarrow> \<top> | Some a \<Rightarrow> a)"
+by(induction ps rule: fun_rep.induct) auto
+
+definition eq_st :: "('a::top) st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
+"eq_st S1 S2 = (fun_rep S1 = fun_rep S2)"
+
+hide_type st  \<comment> \<open>hide previous def to avoid long names\<close>
+declare [[typedef_overloaded]] \<comment> \<open>allow quotient types to depend on classes\<close>
+
+quotient_type 'a st = "('a::top) st_rep" / eq_st
+morphisms rep_st St
+by (metis eq_st_def equivpI reflpI sympI transpI)
+
+lift_definition update :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a \<Rightarrow> 'a st"
+  is "\<lambda>ps x a. (x,a)#ps"
+by(auto simp: eq_st_def)
+
+lift_definition "fun" :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a" is fun_rep
+by(simp add: eq_st_def)
+
+definition show_st :: "vname set \<Rightarrow> ('a::top) st \<Rightarrow> (vname * 'a)set" where
+"show_st X S = (\<lambda>x. (x, fun S x)) ` X"
+
+definition "show_acom C = map_acom (map_option (show_st (vars(strip C)))) C"
+definition "show_acom_opt = map_option show_acom"
+
+lemma fun_update[simp]: "fun (update S x y) = (fun S)(x:=y)"
+by transfer auto
+
+definition \<gamma>_st :: "(('a::top) \<Rightarrow> 'b set) \<Rightarrow> 'a st \<Rightarrow> (vname \<Rightarrow> 'b) set" where
+"\<gamma>_st \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(fun F x)}"
+
+instantiation st :: (order_top) order
+begin
+
+definition less_eq_st_rep :: "'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
+"less_eq_st_rep ps1 ps2 =
+  ((\<forall>x \<in> set(map fst ps1) \<union> set(map fst ps2). fun_rep ps1 x \<le> fun_rep ps2 x))"
+
+lemma less_eq_st_rep_iff:
+  "less_eq_st_rep r1 r2 = (\<forall>x. fun_rep r1 x \<le> fun_rep r2 x)"
+apply(auto simp: less_eq_st_rep_def fun_rep_map_of split: option.split)
+apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
+apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
+done
+
+corollary less_eq_st_rep_iff_fun:
+  "less_eq_st_rep r1 r2 = (fun_rep r1 \<le> fun_rep r2)"
+by (metis less_eq_st_rep_iff le_fun_def)
+
+lift_definition less_eq_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> bool" is less_eq_st_rep
+by(auto simp add: eq_st_def less_eq_st_rep_iff)
+
+definition less_st where "F < (G::'a st) = (F \<le> G \<and> \<not> G \<le> F)"
+
+instance
+proof (standard, goal_cases)
+  case 1 show ?case by(rule less_st_def)
+next
+  case 2 show ?case by transfer (auto simp: less_eq_st_rep_def)
+next
+  case 3 thus ?case by transfer (metis less_eq_st_rep_iff order_trans)
+next
+  case 4 thus ?case
+    by transfer (metis less_eq_st_rep_iff eq_st_def fun_eq_iff antisym)
+qed
+
+end
+
+lemma le_st_iff: "(F \<le> G) = (\<forall>x. fun F x \<le> fun G x)"
+by transfer (rule less_eq_st_rep_iff)
+
+fun map2_st_rep :: "('a::top \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep" where
+"map2_st_rep f [] ps2 = map (%(x,y). (x, f \<top> y)) ps2" |
+"map2_st_rep f ((x,y)#ps1) ps2 =
+  (let y2 = fun_rep ps2 x
+   in (x,f y y2) # map2_st_rep f ps1 ps2)"
+
+lemma fun_rep_map2_rep[simp]: "f \<top> \<top> = \<top> \<Longrightarrow>
+  fun_rep (map2_st_rep f ps1 ps2) = (\<lambda>x. f (fun_rep ps1 x) (fun_rep ps2 x))"
+apply(induction f ps1 ps2 rule: map2_st_rep.induct)
+apply(simp add: fun_rep_map_of map_of_map fun_eq_iff split: option.split)
+apply(fastforce simp: fun_rep_map_of fun_eq_iff split:option.splits)
+done
+
+instantiation st :: (semilattice_sup_top) semilattice_sup_top
+begin
+
+lift_definition sup_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (\<squnion>)"
+by (simp add: eq_st_def)
+
+lift_definition top_st :: "'a st" is "[]" .
+
+instance
+proof (standard, goal_cases)
+  case 1 show ?case by transfer (simp add:less_eq_st_rep_iff)
+next
+  case 2 show ?case by transfer (simp add:less_eq_st_rep_iff)
+next
+  case 3 thus ?case by transfer (simp add:less_eq_st_rep_iff)
+next
+  case 4 show ?case by transfer (simp add:less_eq_st_rep_iff fun_rep_map_of)
+qed
+
+end
+
+lemma fun_top: "fun \<top> = (\<lambda>x. \<top>)"
+by transfer simp
+
+lemma mono_update[simp]:
+  "a1 \<le> a2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> update S1 x a1 \<le> update S2 x a2"
+by transfer (auto simp add: less_eq_st_rep_def)
+
+lemma mono_fun: "S1 \<le> S2 \<Longrightarrow> fun S1 x \<le> fun S2 x"
+by transfer (simp add: less_eq_st_rep_iff)
+
+locale Gamma_semilattice = Val_semilattice where \<gamma>=\<gamma>
+  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
+begin
+
+abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
+where "\<gamma>\<^sub>s == \<gamma>_st \<gamma>"
+
+abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
+where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"
+
+abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
+where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"
+
+lemma gamma_s_top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
+by(auto simp: \<gamma>_st_def fun_top)
+
+lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
+by (simp add: top_option_def)
+
+lemma mono_gamma_s: "f \<le> g \<Longrightarrow> \<gamma>\<^sub>s f \<subseteq> \<gamma>\<^sub>s g"
+by(simp add:\<gamma>_st_def le_st_iff subset_iff) (metis mono_gamma subsetD)
+
+lemma mono_gamma_o:
+  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
+by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)
+
+lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
+by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])
+
+lemma in_gamma_option_iff:
+  "x \<in> \<gamma>_option r u \<longleftrightarrow> (\<exists>u'. u = Some u' \<and> x \<in> r u')"
+by (cases u) auto
+
+end
+
+end
diff --git a/Compiler.thy b/Compiler.thy
new file mode 100644
index 0000000..7885d7b
--- /dev/null
+++ b/Compiler.thy
@@ -0,0 +1,222 @@
+theory Compiler
+  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
+begin
+
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
+"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"
+
+lemma inth_append [simp]: "0 \<le> i \<Longrightarrow>
+  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
+  by (induction xs arbitrary: i) (auto simp: algebra_simps)
+
+abbreviation (output) "isize xs == int (length xs)"
+
+notation isize ("size")
+
+datatype instr = 
+  LOADI int | LOAD vname |
+  ADD |
+  STORE vname |
+  JMP int | JMPLESS int | JMPGE int
+
+type_synonym stack = "val list"
+type_synonym config = "int \<times> state \<times> stack"
+
+abbreviation "hd2 xs == hd (tl xs)"
+abbreviation "tl2 xs == tl (tl xs)"
+
+fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
+  "iexec instr (i, s, stk) = (case instr of
+    LOADI n \<Rightarrow> (i + 1, s, n # stk) |
+    LOAD x \<Rightarrow> (i + 1, s, s x # stk) |
+    ADD \<Rightarrow> (i + 1, s, (hd2 stk + hd stk) # tl2 stk) |
+    STORE x \<Rightarrow> (i + 1, s(x := hd stk), tl stk) |
+    JMP n \<Rightarrow>  (i + 1 + n, s, stk) |
+    JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk) |
+    JMPGE n \<Rightarrow> (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' = 
+  (\<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)
+
+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)]
+
+code_pred exec1 by (metis exec1_def)
+
+lemma iexec_shift [simp]: 
+  "(n+i',s',stk') = iexec x (n+i,s,stk) \<longleftrightarrow>
+  (i',s',stk') = iexec x (i,s,stk)"
+by(auto split:instr.split)
+
+lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
+by (auto simp: exec1_def)
+
+lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
+by (induction rule: star.induct) (fastforce 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')"
+  unfolding exec1_def
+  by (auto simp del: iexec.simps)
+
+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 (induction rule: exec_induct) (blast intro: star.step exec1_appendL)+
+
+text\<open>Now we specialise the above lemmas to enable automatic proofs of
+\<^prop>\<open>P \<turnstile> c \<rightarrow>* c'\<close> where \<open>P\<close> is a mixture of concrete instructions and
+pieces of code that we already know how they execute (by induction), combined
+by \<open>@\<close> and \<open>#\<close>. Backward jumps are not supported.
+The details should be skipped on a first reading.
+
+If we have just executed the first instruction of the program, drop it:\<close>
+
+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
+
+lemma exec_appendL_if[intro]:
+  fixes i i' j :: int
+  shows
+  "size P' <= 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
+
+text\<open>Split the execution of a compound program up into the execution of its
+parts:\<close>
+
+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 "Compilation"
+
+fun acomp :: "aexp \<Rightarrow> instr list" where
+"acomp (N n) = [LOADI n]" |
+"acomp (V x) = [LOAD x]" |
+"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"
+
+lemma acomp_correct[intro]:
+  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
+by (induction a arbitrary: stk) fastforce+
+
+fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
+"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
+"bcomp (Not b) f n = bcomp b (\<not>f) n" |
+"bcomp (And b1 b2) f n =
+ (let cb2 = bcomp b2 f n;
+        m = if f then size cb2 else (size cb2::int)+n;
+      cb1 = bcomp b1 False m
+  in cb1 @ cb2)" |
+"bcomp (Less a1 a2) f n =
+ acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"
+
+value
+  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
+     False 3"
+
+lemma bcomp_correct[intro]:
+  fixes n :: int
+  shows
+  "0 \<le> n \<Longrightarrow>
+  bcomp b f n \<turnstile>
+ (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
+proof(induction b arbitrary: f n)
+  case Not
+  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
+next
+  case (And b1 b2)
+  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n" 
+                 "False"] 
+       And(2)[of n f] And(3) 
+  show ?case by fastforce
+qed fastforce+
+
+fun ccomp :: "com \<Rightarrow> instr list" where
+"ccomp SKIP = []" |
+"ccomp (x ::= a) = acomp a @ [STORE x]" |
+"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
+"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
+  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
+   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
+"ccomp (WHILE b DO c) =
+ (let cc = ccomp c; cb = bcomp b False (size cc + 1)
+  in cb @ cc @ [JMP (-(size cb + size cc + 1))])"
+
+
+value "ccomp
+ (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
+  ELSE ''v'' ::= V ''u'')"
+
+value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"
+
+
+subsection "Preservation of semantics"
+
+lemma ccomp_bigstep:
+  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
+proof(induction arbitrary: stk rule: big_step_induct)
+  case (Assign x a s)
+  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
+  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
+    using Seq.IH(1) by fastforce
+  moreover
+  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
+    using Seq.IH(2) by fastforce
+  ultimately show ?case by simp (blast intro: star_trans)
+next
+  case (WhileTrue b s1 c s2 s3)
+  let ?cc = "ccomp c"
+  let ?cb = "bcomp b False (size ?cc + 1)"
+  let ?cw = "ccomp(WHILE b DO c)"
+  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
+    using \<open>bval b s1\<close> by fastforce
+  moreover
+  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
+    using WhileTrue.IH(1) by fastforce
+  moreover
+  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
+    by fastforce
+  moreover
+  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
+  ultimately show ?case by(blast intro: star_trans)
+qed fastforce+
+
+end
diff --git a/Compiler_Manual.thy b/Compiler_Manual.thy
new file mode 100644
index 0000000..0cd4803
--- /dev/null
+++ b/Compiler_Manual.thy
@@ -0,0 +1,267 @@
+theory Compiler_Manual
+  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
+begin
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+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))"
+proof (induct xs arbitrary: i)
+  case Nil
+  then show ?case by auto
+next
+  case (Cons a xs)
+  then show ?case
+  proof (cases "i = 0")
+    case True
+    then show ?thesis by auto
+  next
+    case False
+    with Cons(2) have Hle: "0 \<le> i - 1" by simp
+    have "i - 1 - int (length xs) = i - (int (length xs) + 1)" by simp
+    also have "\<dots> = i - int (length xs + 1)" by simp
+    also have "\<dots> = i - int (length (a # xs))" by simp
+    finally have 0: "i - 1 - int (length xs) = i - int (length (a # xs))" .
+    have "((a # xs) @ ys) !! i = (a # xs @ ys) !! i" by simp
+    also from False have "\<dots> = (xs @ ys) !! (i - 1)" by simp
+    also from Cons(1) Hle have "\<dots> = (if i - 1 < int (length xs) then xs !! (i - 1) else ys !! (i - 1 - int (length xs)))" by simp
+    also have "\<dots> = (if i < int (length xs) + 1 then xs !! (i - 1) else ys !! (i - int (length (a # xs))))" by (simp add: 0)
+    also have "\<dots> = (if i < int (length (a # xs)) then xs !! (i - 1) else ys !! (i - int (length (a # xs))))" by simp
+    also from Hle have "\<dots> = (if i < int (length (a # xs)) then (a # xs) !! i else ys !! (i - int (length (a # xs))))" by simp
+    finally show ?thesis .
+  qed
+qed
+
+abbreviation (output)
+  "isize xs == int (length xs)"
+
+notation isize ("size")
+
+datatype instr = 
+  LOADI int | LOAD vname |
+  ADD |
+  STORE vname |
+  JMP int | JMPLESS int | JMPGE int
+
+type_synonym stack = "val list"
+type_synonym config = "int \<times> state \<times> stack"
+
+abbreviation "hd2 xs == hd (tl xs)"
+abbreviation "tl2 xs == tl (tl xs)"
+
+(* note: by using hd / tl functions rather than pattern matching, we limit
+  reliance on the structure of stk in the behavior of iexec, allowing us
+  to simplify preconditions on lemmas that don't rely on the structure of
+  the stack
+*)
+fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
+  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
+  "iexec (LOAD x) (i, s, stk) = (i + 1, s, s x # stk)" |
+  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
+  "iexec (STORE x) (i, s, stk) = (i + 1, s(x := 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)"
+
+(* an introduction rule that expects the LHS config parameters to already be known *)
+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
+proof -
+  assume "x \<turnstile> (xa, xb, xc) \<rightarrow> (xd, xe, xf)"
+  with exec1_def have "\<exists>i s stk. (xa, xb, xc) = (i, s, stk) \<and> (xd, xe, xf) = iexec (x !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size x" by simp
+  then obtain xa' xb' xc' where "(xa, xb, xc) = (xa', xb', xc')" and "(xd, xe, xf) = iexec (x !! xa') (xa', xb', xc')" and "0 \<le> xa'" and "xa' < size x" by blast+
+  then have 0: "(xd, xe, xf) = iexec (x !! xa) (xa, xb, xc)" and 1: "0 \<le> xa" and 2: "xa < size x" by auto
+  assume "\<And>P i s stk c'. \<lbrakk>x = P; (xa, xb, xc) = (i, s, stk); (xd, xe, xf) = c'; c' = iexec (P !! i) (i, s, stk); 0 \<le> i; i < size P\<rbrakk> \<Longrightarrow> thesis"
+  with refl [of "x"] refl [of "(xa, xb, xc)"] refl [of "(xd, xe, xf)"] 0 1 2 show thesis by simp
+qed
+
+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', stk') = iexec x (n + i, s, stk) \<longleftrightarrow>
+  (i', s', stk') = iexec x (i, s, stk)"
+  by (cases x, auto)
+
+(* 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'" unfolding exec1_def
+proof -
+  assume "\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P"
+  then obtain i s stk where "c = (i, s, stk)" and "c' = iexec (P !! i) (i, s, stk)" and "0 \<le> i" and "i < size P" by blast+
+  then have "c = (i, s, stk) \<and> c' = iexec ((P @ P') !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size (P @ P')" by auto+
+  then show "\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec ((P @ P') !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size (P @ P')" by blast
+qed
+
+lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow>* c'"
+proof (induct rule: star.induct)
+  case (refl x)
+  then show ?case by (rule star.refl)
+next
+  case (step x y z)
+  from step(1) exec1_appendR have "P @ P' \<turnstile> x \<rightarrow> y" by simp
+  with step(3) show ?case by (simp add: star.step)
+qed
+
+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')"
+proof (induct rule: exec_induct)
+  case (refl a aa b)
+  then show ?case by (rule star.refl)
+next
+  case (step aa ab ac ba bb bc ca cb cc)
+  from step(1) exec1_appendL have "P' @ P \<turnstile> (size P' + aa, ab, ac) \<rightarrow> (size P' + ba, bb, bc)" by simp
+  with step(3) show ?case by (simp add: star.step)
+qed
+
+(* 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')"
+proof (drule exec_appendL [where P'="[instr]"]) qed 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' <= 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')"
+proof (drule exec_appendL [where P'=P']) qed simp
+
+(* extend exec_appendL_if with an execution on the LHS. Note the premises here that are needed
+  to satisfy the preconditions for exec_appendL
+*)
+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'')"
+proof (rule star_trans [OF exec_appendR exec_appendL_if])
+  assume 0: "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk')"
+    and 1: "size P \<le> i'"
+    and 2: "P' \<turnstile> (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'')"
+    and 3: "j'' = size P + i''"
+  from 0 show "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk')" .
+  from 1 show "size P \<le> i'" .
+  from 2 show "P' \<turnstile> (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'')" .
+  from 3 show "j'' = size P + i''" .
+qed
+                                               
+declare Let_def[simp]
+
+subsection "Compilation"
+
+fun acomp :: "aexp \<Rightarrow> instr list" where
+  "acomp (N n) = [LOADI n]" |
+  "acomp (V x) = [LOAD x]" |
+  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"
+
+lemma acomp_correct[intro]:
+  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size(acomp a), s, aval a s # stk)"
+  by (induction a arbitrary: stk) fastforce+
+
+fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
+  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
+  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
+  "bcomp (And b1 b2) f n = (let
+    cb2 = bcomp b2 f n;
+    m = if f
+      then size cb2
+      else size cb2 + n;
+    cb1 = bcomp b1 False m in
+    cb1 @ cb2)" |
+  "bcomp (Less a1 a2) f n =
+    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"
+
+lemma bcomp_correct[intro]:
+  fixes n :: int
+  shows
+  "0 \<le> n \<Longrightarrow>
+  bcomp b f n \<turnstile>
+ (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
+proof(induction b arbitrary: f n)
+  case Not
+  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
+next
+  case (And b1 b2)
+  from And(1)
+    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
+    And(2) [of n f] And(3)
+  show ?case by fastforce
+qed fastforce+
+
+fun ccomp :: "com \<Rightarrow> instr list" where
+  "ccomp SKIP = []" |
+  "ccomp (x ::= a) = acomp a @ [STORE x]" |
+  "ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
+  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
+    cc\<^sub>1 = ccomp c\<^sub>1;
+    cc\<^sub>2 = ccomp c\<^sub>2;
+    cb = bcomp b False (size cc\<^sub>1 + 1) in
+    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
+  "ccomp (WHILE b DO c) = (let
+    cc = ccomp c;
+    cb = bcomp b False (size cc + 1) in
+    cb @ cc @ [JMP (-(size cb + size cc + 1))])"
+
+lemma ccomp_bigstep:
+  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
+proof(induction arbitrary: stk rule: big_step_induct)
+  case (Assign x a s)
+  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
+  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
+    using Seq.IH(1) by fastforce
+  moreover
+  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
+    using Seq.IH(2) by fastforce
+  ultimately show ?case by simp (blast intro: star_trans)
+next
+  case (WhileTrue b s1 c s2 s3)
+  let ?cc = "ccomp c"
+  let ?cb = "bcomp b False (size ?cc + 1)"
+  and ?cw = "ccomp(WHILE b DO c)"
+  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)"
+    using \<open>bval b s1\<close> by fastforce
+  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
+    using WhileTrue.IH(1) by fastforce
+  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)"
+    by fastforce
+  moreover have "?cw \<turnstile> (0, s2, stk) \<rightarrow>* (size ?cw, s3, stk)" by (rule WhileTrue.IH(2))
+  ultimately show ?case by(blast intro: star_trans)
+qed fastforce+
+
+end
\ No newline at end of file
diff --git a/Compiler_Template.thy b/Compiler_Template.thy
new file mode 100644
index 0000000..57c29fc
--- /dev/null
+++ b/Compiler_Template.thy
@@ -0,0 +1,213 @@
+theory Compiler_Template
+  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
+begin
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+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")
+
+datatype instr = 
+  LOADI int | LOAD vname |
+  ADD |
+  STORE vname |
+  JMP int | JMPLESS int | JMPGE int
+
+type_synonym stack = "val list"
+type_synonym config = "int \<times> state \<times> stack"
+
+abbreviation "hd2 xs == hd (tl xs)"
+abbreviation "tl2 xs == tl (tl xs)"
+
+(* note: by using hd / tl functions rather than pattern matching, we limit
+  reliance on the structure of stk in the behavior of iexec, allowing us
+  to simplify preconditions on lemmas that don't rely on the structure of
+  the stack
+*)
+fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
+  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
+  "iexec (LOAD x) (i, s, stk) = (i + 1, s, s x # stk)" |
+  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
+  "iexec (STORE x) (i, s, stk) = (i + 1, s(x := 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)"
+
+(* an introduction rule that expects the LHS config parameters to already be known *)
+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)
+
+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', stk') = iexec x (n + i, s, stk) \<longleftrightarrow>
+  (i', s', stk') = iexec x (i, s, stk)"
+  by (cases x, auto)
+
+(* 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' <= 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 "Compilation"
+
+fun acomp :: "aexp \<Rightarrow> instr list" where
+  "acomp (N n) = [LOADI n]" |
+  "acomp (V x) = [LOAD x]" |
+  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"
+
+lemma acomp_correct[intro]:
+  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size(acomp a), s, aval a s # stk)"
+  by (induction a arbitrary: stk) fastforce+
+
+(* f = True means that we intend to jump n spaces upon the expression evaluating to True, and
+  step to next instruction upon the expression evaluating to False
+  f = False means vice versa
+
+  Suppose f = True in bcomp (And b1 b2). Then we want b1 to jump to just past b2 on False,
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True. Thus we let cb1 = bcomp b1 False (size cb2)
+
+  suppose f = False in bcomp (And b1 b2). Then we want b1 to jump to (size cb2 + n) on False
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True.
+*)
+fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
+  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
+  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
+  "bcomp (And b1 b2) f n = (let
+    cb2 = bcomp b2 f n;
+    m = if f
+      then size cb2
+      else size cb2 + n;
+    cb1 = bcomp b1 False m in
+    cb1 @ cb2)" |
+  "bcomp (Less a1 a2) f n =
+    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"
+
+lemma bcomp_correct[intro]:
+  fixes n :: int
+  shows
+  "0 \<le> n \<Longrightarrow>
+  bcomp b f n \<turnstile>
+ (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
+proof (induct b arbitrary: f n)
+  case Not
+  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
+next
+  case (And b1 b2)
+  from And(1)
+    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
+    And(2) [of n f] And(3)
+  show ?case by fastforce
+qed fastforce+
+
+fun ccomp :: "com \<Rightarrow> instr list" where
+  "ccomp SKIP = []" |
+  "ccomp (x ::= a) = acomp a @ [STORE x]" |
+  "ccomp (c\<^sub>1;; c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
+  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
+    cc\<^sub>1 = ccomp c\<^sub>1;
+    cc\<^sub>2 = ccomp c\<^sub>2;
+    cb = bcomp b False (size cc\<^sub>1 + 1) in
+    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
+  "ccomp (WHILE b DO c) = (let
+    cc = ccomp c;
+    cb = bcomp b False (size cc + 1) in
+    cb @ cc @ [JMP (-(size cb + size cc + 1))])"
+
+lemma ccomp_bigstep:
+  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
+proof(induct arbitrary: stk rule: big_step_induct)
+  case (Assign x a s)
+  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
+  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
+    using Seq(2) by fastforce
+  moreover
+  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
+    using Seq(4) by fastforce
+  ultimately show ?case by simp (blast intro: star_trans)
+next
+  case (WhileTrue b s1 c s2 s3)
+  let ?cc = "ccomp c"
+  let ?cb = "bcomp b False (size ?cc + 1)"
+  and ?cw = "ccomp (WHILE b DO c)"
+  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)" using \<open>bval b s1\<close> by fastforce
+  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
+    using WhileTrue(3) by fastforce
+  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)" by fastforce
+  ultimately show ?case using WhileTrue(5) by(blast intro: star_trans)
+qed fastforce+
+
+end
\ No newline at end of file
diff --git a/Induction_Demo_My.thy b/Induction_Demo_My.thy
new file mode 100644
index 0000000..4e29117
--- /dev/null
+++ b/Induction_Demo_My.thy
@@ -0,0 +1,13 @@
+theory Induction_Demo_My
+  imports Main
+begin
+
+fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+  "itrev [] ys = ys" |
+  "itrev (x # xs) ys = itrev xs (x # ys)"
+
+(* arbitrary ys tells us to have ys arbitrary in the IH and inductive conclusion *)
+lemma "itrev xs ys = rev xs @ ys"
+  apply (induction xs arbitrary: ys)
+   apply auto
+  done
diff --git a/Short_Theory_10_2.thy b/Short_Theory_10_2.thy
new file mode 100644
index 0000000..6a01f1e
--- /dev/null
+++ b/Short_Theory_10_2.thy
@@ -0,0 +1,210 @@
+theory Short_Theory_10_2
+  imports "HOL-IMP.Sem_Equiv" "HOL-IMP.Vars"
+begin
+
+type_synonym tab = "vname \<Rightarrow> val option"
+
+fun afold :: "aexp \<Rightarrow> tab \<Rightarrow> aexp" where
+"afold (N n) _ = N n" |
+"afold (V x) t = (case t x of
+  None \<Rightarrow> V x |
+  Some k \<Rightarrow> N k)" |
+"afold (Plus e1 e2) t = (case (afold e1 t, afold e2 t) of
+  (N n1, N n2) \<Rightarrow> N (n1 + n2) |
+  (N n1, e2') \<Rightarrow> (if n1 = 0 then e2' else Plus (N n1) e2') |
+  (e1', N n2) \<Rightarrow> (if n2 = 0 then e1' else Plus e1' (N n2)) |
+  (e1', e2') \<Rightarrow> Plus e1' e2')"
+
+definition "approx t s \<longleftrightarrow> (\<forall>x k. t x = Some k \<longrightarrow> s x = k)"
+
+theorem aval_afold[simp]:
+assumes "approx t s"
+shows "aval (afold a t) s = aval a s"
+  using assms
+  by (induct a) (auto simp: approx_def split: aexp.split option.split)
+
+theorem aval_afold_N:
+assumes "approx t s"
+shows "afold a t = N n \<Longrightarrow> aval a s = n"
+  by (metis assms aval.simps(1) aval_afold)
+
+definition
+  "merge t1 t2 = (\<lambda>m. if t1 m = t2 m then t1 m else None)"
+
+primrec "defs" :: "com \<Rightarrow> tab \<Rightarrow> tab" where
+"defs SKIP t = t" |
+"defs (x ::= a) t =
+  (case afold a t of N k \<Rightarrow> t(x \<mapsto> k) | _ \<Rightarrow> t(x:=None))" |
+"defs (c1;;c2) t = (defs c2 o defs c1) t" |
+"defs (IF b THEN c1 ELSE c2) t = merge (defs c1 t) (defs c2 t)" |
+"defs (WHILE b DO c) t = t |` (-lvars c)"
+
+primrec fold where
+"fold SKIP _ = SKIP" |
+"fold (x ::= a) t = (x ::= (afold a t))" |
+"fold (c1;;c2) t = (fold c1 t;; fold c2 (defs c1 t))" |
+"fold (IF b THEN c1 ELSE c2) t = IF b THEN fold c1 t ELSE fold c2 t" |
+"fold (WHILE b DO c) t = WHILE b DO fold c (t |` (-lvars c))"
+
+lemma approx_merge:
+  "approx t1 s \<or> approx t2 s \<Longrightarrow> approx (merge t1 t2) s"
+  by (fastforce simp: merge_def approx_def)
+
+lemma approx_map_le:
+  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
+  by (clarsimp simp: approx_def map_le_def dom_def)
+
+lemma restrict_map_le [intro!, simp]: "t |` S \<subseteq>\<^sub>m t"
+  by (clarsimp simp: restrict_map_def map_le_def)
+
+lemma merge_restrict:
+  assumes "t1 |` S = t |` S"
+  assumes "t2 |` S = t |` S"
+  shows "merge t1 t2 |` S = t |` S"
+proof -
+  from assms
+  have "\<forall>x. (t1 |` S) x = (t |` S) x"
+   and "\<forall>x. (t2 |` S) x = (t |` S) x" by auto
+  thus ?thesis
+    by (auto simp: merge_def restrict_map_def
+             split: if_splits)
+qed
+
+
+lemma defs_restrict:
+  "defs c t |` (- lvars c) = t |` (- lvars c)"
+proof (induction c arbitrary: t)
+  case (Seq c1 c2)
+  hence "defs c1 t |` (- lvars c1) = t |` (- lvars c1)"
+    by simp
+  hence "defs c1 t |` (- lvars c1) |` (-lvars c2) =
+         t |` (- lvars c1) |` (-lvars c2)" by simp
+  moreover
+  from Seq
+  have "defs c2 (defs c1 t) |` (- lvars c2) =
+        defs c1 t |` (- lvars c2)"
+    by simp
+  hence "defs c2 (defs c1 t) |` (- lvars c2) |` (- lvars c1) =
+         defs c1 t |` (- lvars c2) |` (- lvars c1)"
+    by simp
+  ultimately
+  show ?case by (clarsimp simp: Int_commute)
+next
+  case (If b c1 c2)
+  hence "defs c1 t |` (- lvars c1) = t |` (- lvars c1)" by simp
+  hence "defs c1 t |` (- lvars c1) |` (-lvars c2) =
+         t |` (- lvars c1) |` (-lvars c2)" by simp
+  moreover
+  from If
+  have "defs c2 t |` (- lvars c2) = t |` (- lvars c2)" by simp
+  hence "defs c2 t |` (- lvars c2) |` (-lvars c1) =
+         t |` (- lvars c2) |` (-lvars c1)" by simp
+  ultimately
+  show ?case by (auto simp: Int_commute intro: merge_restrict)
+qed (auto split: aexp.split)
+
+
+lemma big_step_pres_approx:
+  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx t s \<Longrightarrow> approx (defs c t) s'"
+proof (induction arbitrary: t rule: big_step_induct)
+  case Skip thus ?case by simp
+next
+  case Assign
+  thus ?case
+    by (clarsimp simp: aval_afold_N approx_def split: aexp.split)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  have "approx (defs c1 t) s2" by (rule Seq.IH(1)[OF Seq.prems])
+  hence "approx (defs c2 (defs c1 t)) s3" by (rule Seq.IH(2))
+  thus ?case by simp
+next
+  case (IfTrue b s c1 s')
+  hence "approx (defs c1 t) s'" by simp
+  thus ?case by (simp add: approx_merge)
+next
+  case (IfFalse b s c2 s')
+  hence "approx (defs c2 t) s'" by simp
+  thus ?case by (simp add: approx_merge)
+next
+  case WhileFalse
+  thus ?case by (simp add: approx_def restrict_map_def)
+next
+  case (WhileTrue b s1 c s2 s3)
+  hence "approx (defs c t) s2" by simp
+  with WhileTrue
+  have "approx (defs c t |` (-lvars c)) s3" by simp
+  thus ?case by (simp add: defs_restrict)
+qed
+
+
+lemma big_step_pres_approx_restrict:
+  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx (t |` (-lvars c)) s \<Longrightarrow> approx (t |` (-lvars c)) s'"
+proof (induction arbitrary: t rule: big_step_induct)
+  case Assign
+  thus ?case by (clarsimp simp: approx_def)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s1"
+    by (simp add: Int_commute)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s2"
+    by (rule Seq)
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s2"
+    by (simp add: Int_commute)
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s3"
+    by (rule Seq)
+  thus ?case by simp
+next
+  case (IfTrue b s c1 s' c2)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s"
+    by (simp add: Int_commute)
+  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s'"
+    by (rule IfTrue)
+  thus ?case by (simp add: Int_commute)
+next
+  case (IfFalse b s c2 s' c1)
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s"
+    by simp
+  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s'"
+    by (rule IfFalse)
+  thus ?case by simp
+qed auto
+
+
+declare assign_simp [simp]
+
+lemma approx_eq:
+  "approx t \<Turnstile> c \<sim> fold c t"
+proof (induction c arbitrary: t)
+  case SKIP show ?case by simp
+next
+  case Assign
+  show ?case by (simp add: equiv_up_to_def)
+next
+  case Seq
+  thus ?case by (auto intro!: equiv_up_to_seq big_step_pres_approx)
+next
+  case If
+  thus ?case by (auto intro!: equiv_up_to_if_weak)
+next
+  case (While b c)
+  hence "approx (t |` (- lvars c)) \<Turnstile>
+         WHILE b DO c \<sim> WHILE b DO fold c (t |` (- lvars c))"
+    by (auto intro: equiv_up_to_while_weak big_step_pres_approx_restrict)
+  thus ?case
+    by (auto intro: equiv_up_to_weaken approx_map_le)
+qed
+
+
+lemma approx_empty [simp]:
+  "approx Map.empty = (\<lambda>_. True)"
+  by (auto simp: approx_def)
+
+
+theorem constant_folding_equiv:
+  "fold c Map.empty \<sim> c"
+  using approx_eq [of Map.empty c]
+  by (simp add: equiv_up_to_True sim_sym)
+
+
+end
+
diff --git a/Short_Theory_11_1.thy b/Short_Theory_11_1.thy
new file mode 100644
index 0000000..d3da941
--- /dev/null
+++ b/Short_Theory_11_1.thy
@@ -0,0 +1,332 @@
+theory Short_Theory_11_1
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype
+  com = SKIP
+  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 60, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+  | Repeat com bexp         ("(REPEAT _/ UNTIL _)" [60, 0] 61)
+
+inductive big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55) where
+    Skip: "(SKIP,s) \<Rightarrow> s" |
+    Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
+    Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    RepeatTrue: "\<lbrakk> bval b t; (c, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
+    RepeatFalse: "\<lbrakk> \<not>bval b s\<^sub>2; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE[elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE[elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_RepeatE[elim]: "\<lbrakk>
+  (REPEAT c UNTIL b, s) \<Rightarrow> t;
+  \<lbrakk>bval b t; (c, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>\<not> bval b s\<^sub>2; (c, s) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+abbreviation
+  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
+  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
+
+theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
+  by (induct arbitrary: u rule: big_step.induct) blast+
+
+inductive small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
+  where
+    Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |
+    Seq1: "(SKIP;; c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    Seq2: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> (c\<^sub>1';; c\<^sub>2, s')" |
+    IfTrue: "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
+    IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |
+    Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"
+
+abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
+  where "x \<rightarrow>* y == star small_step x y"
+
+lemmas small_step_induct = small_step.induct[split_format(complete)]
+declare small_step.intros[simp,intro]
+
+lemma SS_SkipE[elim!]: "(SKIP, s) \<rightarrow> ct \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<rightarrow> ct; ct = (SKIP, s(x := aval a s)) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_SeqE[elim]: "\<lbrakk>
+  (c1;; c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c2, s); c1 = SKIP\<rbrakk> \<Longrightarrow> P;
+  \<And>c\<^sub>1' s'. \<lbrakk>ct = (c\<^sub>1';; c2, s'); (c1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c1 ELSE c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c1, s); bval b s\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>ct = (c2, s); \<not> bval b s\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<rightarrow> ct;
+  ct = (IF b THEN c;; WHILE b DO c ELSE SKIP, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_RepeatE[elim]: "\<lbrakk>
+  (REPEAT c UNTIL b, s) \<rightarrow> ct;
+  ct = (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+
+lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
+  by (induct rule: star_induct) (simp, blast intro: star.step)
+
+lemma seq_comp: "\<lbrakk>(c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3)\<rbrakk>
+  \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
+  by (blast intro: star.step star_seq2 star_trans)
+
+lemma big_to_small: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
+  by (induction rule: big_step.induct) (blast intro: seq_comp star.step)+
+
+lemma small1_big_continue: "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct arbitrary: t rule: small_step.induct) auto
+
+lemma small_to_big: "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct cs "(SKIP,t)" rule: star.induct) (auto intro: small1_big_continue)
+
+theorem big_iff_small: "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
+  by (blast intro: big_to_small small_to_big)
+
+section \<open>Denotational\<close>
+
+type_synonym com_den = "(state \<times> state) set"
+
+definition W :: "(state \<Rightarrow> bool) \<Rightarrow> com_den \<Rightarrow> (com_den \<Rightarrow> com_den)" where
+  "W db dc = (\<lambda>dw. {(s, t). if db s then (s,t) \<in> dc O dw else s=t})"
+
+definition R :: "com_den \<Rightarrow> (state \<Rightarrow> bool) \<Rightarrow> (com_den \<Rightarrow> com_den)" where
+  "R dc db = (\<lambda>dr. dc O {(s, t). if db s then s = t else (s, t) \<in> dr})"
+
+fun D :: "com \<Rightarrow> com_den" where
+  "D SKIP = Id" |
+  "D (x ::= a) = {(s,t). t = s(x := aval a s)}" |
+  "D (c1;; c2)  = D c1 O D c2" |
+  "D (IF b THEN c1 ELSE c2)
+    = {(s,t). if bval b s then (s, t) \<in> D c1 else (s, t) \<in> D c2}" |
+  "D (WHILE b DO c) = lfp (W (bval b) (D c))" |
+  "D (REPEAT c UNTIL b) = lfp (R (D c) (bval b))"
+
+lemma W_mono: "mono (W b c)"
+  by (unfold W_def mono_def) auto
+
+lemma R_mono: "mono (R c b)"
+  by (unfold R_def mono_def) auto
+
+lemma D_While_If:
+  "D (WHILE b DO c) = D (IF b THEN c;; WHILE b DO c ELSE SKIP)"
+proof-
+  let ?w = "WHILE b DO c" let ?f = "W (bval b) (D c)"
+  have "D ?w = lfp ?f" by simp
+  also have "\<dots> = ?f (lfp ?f)" by(rule lfp_unfold [OF W_mono])
+  also have "\<dots> = D(IF b THEN c;;?w ELSE SKIP)" by (simp add: W_def)
+  finally show ?thesis .
+qed
+
+lemma D_Repeat_If:
+  "D (REPEAT c UNTIL b) = D (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b)"
+proof-
+  let ?r = "REPEAT c UNTIL b" let ?f = "R (D c) (bval b)"
+  have "D ?r = lfp ?f" by simp
+  also have "\<dots> = ?f (lfp ?f)" by(rule lfp_unfold [OF R_mono])
+  also have "\<dots> = D (c;; IF b THEN SKIP ELSE ?r)" by (simp add: R_def)
+  finally show ?thesis .
+qed
+
+text\<open>Equivalence of denotational and big-step semantics:\<close>
+
+lemma D_if_big_step:  "(c,s) \<Rightarrow> t \<Longrightarrow> (s,t) \<in> D(c)"
+proof (induction rule: big_step_induct)
+  case (WhileFalse b s c)
+  show ?case unfolding D_While_If using WhileFalse by auto
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  show ?case unfolding D_While_If using WhileTrue(1, 4, 5) by auto
+next
+  case (RepeatTrue b t c s)
+  show ?case unfolding D_Repeat_If using RepeatTrue(1, 3) by auto
+next
+  case (RepeatFalse b s\<^sub>2 c s\<^sub>1 s\<^sub>3)
+  show ?case unfolding D_Repeat_If using RepeatFalse(1, 4, 5) by auto
+qed auto
+
+abbreviation Big_step :: "com \<Rightarrow> com_den" where
+"Big_step c \<equiv> {(s,t). (c,s) \<Rightarrow> t}"
+
+lemma Big_step_if_D:  "(s,t) \<in> D(c) \<Longrightarrow> (s,t) \<in> Big_step c"
+proof (induction c arbitrary: s t)
+  case (Seq c1 c2) thus ?case by fastforce
+next
+  case (While b c)
+  let ?B = "Big_step (WHILE b DO c)" let ?f = "W (bval b) (D c)"
+  have "?f ?B \<subseteq> ?B" using While.IH by (auto simp: W_def)
+  from lfp_lowerbound[where ?f = "?f", OF this] While.prems
+  show ?case by auto
+next
+  case (Repeat c b)
+  let ?B = "Big_step (REPEAT c UNTIL b)" let ?f = "R (D c) (bval b)"
+  have "?f ?B \<subseteq> ?B" using Repeat.IH by (auto simp: R_def)
+  from lfp_lowerbound[where ?f = "?f", OF this] Repeat.prems
+  show ?case by auto
+qed (auto split: if_splits)
+
+theorem denotational_is_big_step:
+  "(s,t) \<in> D(c)  =  ((c,s) \<Rightarrow> t)"
+by (metis D_if_big_step Big_step_if_D[simplified])
+
+corollary equiv_c_iff_equal_D: "(c1 \<sim> c2) \<longleftrightarrow> D c1 = D c2"
+  by(simp add: denotational_is_big_step[symmetric] set_eq_iff)
+
+
+subsection "Continuity"
+
+definition chain :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool" where
+"chain S = (\<forall>i. S i \<subseteq> S(Suc i))"
+
+lemma chain_total: "chain S \<Longrightarrow> S i \<le> S j \<or> S j \<le> S i"
+by (metis chain_def le_cases lift_Suc_mono_le)
+
+definition cont :: "('a set \<Rightarrow> 'b set) \<Rightarrow> bool" where
+"cont f = (\<forall>S. chain S \<longrightarrow> f(UN n. S n) = (UN n. f(S n)))"
+
+lemma mono_if_cont: fixes f :: "'a set \<Rightarrow> 'b set"
+  assumes "cont f" shows "mono f"
+proof
+  fix a b :: "'a set" assume "a \<subseteq> b"
+  let ?S = "\<lambda>n::nat. if n=0 then a else b"
+  have "chain ?S" using \<open>a \<subseteq> b\<close> by(auto simp: chain_def)
+  hence "f(UN n. ?S n) = (UN n. f(?S n))"
+    using assms by (simp add: cont_def del: if_image_distrib)
+  moreover have "(UN n. ?S n) = b" using \<open>a \<subseteq> b\<close> by (auto split: if_splits)
+  moreover have "(UN n. f(?S n)) = f a \<union> f b" by (auto split: if_splits)
+  ultimately show "f a \<subseteq> f b" by (metis Un_upper1)
+qed
+
+lemma chain_iterates: fixes f :: "'a set \<Rightarrow> 'a set"
+  assumes "mono f" shows "chain(\<lambda>n. (f^^n) {})"
+proof-
+  have "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" for n
+  proof (induction n)
+    case 0 show ?case by simp
+  next
+    case (Suc n) thus ?case using assms by (auto simp: mono_def)
+  qed
+  thus ?thesis by(auto simp: chain_def assms)
+qed
+
+theorem lfp_if_cont:
+  assumes "cont f" shows "lfp f = (UN n. (f^^n) {})" (is "_ = ?U")
+proof
+  from assms mono_if_cont
+  have mono: "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" for n
+    using funpow_decreasing [of n "Suc n"] by auto
+  show "lfp f \<subseteq> ?U"
+  proof (rule lfp_lowerbound)
+    have "f ?U = (UN n. (f^^Suc n){})"
+      using chain_iterates[OF mono_if_cont[OF assms]] assms
+      by(simp add: cont_def)
+    also have "\<dots> = (f^^0){} \<union> \<dots>" by simp
+    also have "\<dots> = ?U"
+      using mono by auto (metis funpow_simps_right(2) funpow_swap1 o_apply)
+    finally show "f ?U \<subseteq> ?U" by simp
+  qed
+next
+  have "(f^^n){} \<subseteq> p" if "f p \<subseteq> p" for n p
+  proof -
+    show ?thesis
+    proof(induction n)
+      case 0 show ?case by simp
+    next
+      case Suc
+      from monoD[OF mono_if_cont[OF assms] Suc] \<open>f p \<subseteq> p\<close>
+      show ?case by simp
+    qed
+  qed
+  thus "?U \<subseteq> lfp f" by(auto simp: lfp_def)
+qed
+
+lemma cont_W: "cont(W b r)"
+by(auto simp: cont_def W_def)
+
+lemma cont_R: "cont(R c b)"
+  by(auto simp: cont_def R_def)
+
+
+subsection\<open>The denotational semantics is deterministic\<close>
+
+lemma single_valued_UN_chain:
+  assumes "chain S" "(\<And>n. single_valued (S n))"
+  shows "single_valued(UN n. S n)"
+proof(auto simp: single_valued_def)
+  fix m n x y z assume "(x, y) \<in> S m" "(x, z) \<in> S n"
+  with chain_total[OF assms(1), of m n] assms(2)
+  show "y = z" by (auto simp: single_valued_def)
+qed
+
+lemma single_valued_lfp: fixes f :: "com_den \<Rightarrow> com_den"
+assumes "cont f" "\<And>r. single_valued r \<Longrightarrow> single_valued (f r)"
+shows "single_valued(lfp f)"
+unfolding lfp_if_cont[OF assms(1)]
+proof(rule single_valued_UN_chain[OF chain_iterates[OF mono_if_cont[OF assms(1)]]])
+  fix n show "single_valued ((f ^^ n) {})"
+  by(induction n)(auto simp: assms(2))
+qed
+
+lemma single_valued_D: "single_valued (D c)"
+proof(induction c)
+  case Seq thus ?case by(simp add: single_valued_relcomp)
+next
+  case (While b c)
+  let ?f = "W (bval b) (D c)"
+  have "single_valued (lfp ?f)"
+  proof(rule single_valued_lfp[OF cont_W])
+    show "\<And>r. single_valued r \<Longrightarrow> single_valued (?f r)"
+      using While.IH by(force simp: single_valued_def W_def)
+  qed
+  thus ?case by simp
+next
+  case (Repeat c b)
+  let ?f = "R (D c) (bval b)"
+  have "single_valued (lfp ?f)"
+  proof(rule single_valued_lfp[OF cont_R])
+    show "\<And>r. single_valued r \<Longrightarrow> single_valued (?f r)"
+      using Repeat.IH by(force simp: single_valued_def R_def)
+  qed
+  thus ?case by simp
+qed (auto simp add: single_valued_def)
+
+
+end
\ No newline at end of file
diff --git a/Short_Theory_11_7.thy b/Short_Theory_11_7.thy
new file mode 100644
index 0000000..4f3f7c6
--- /dev/null
+++ b/Short_Theory_11_7.thy
@@ -0,0 +1,231 @@
+theory Short_Theory_11_7
+  imports "HOL-IMP.Denotational" "HOL-IMP.Vars"
+begin
+
+fun Dep :: "com \<Rightarrow> (vname * vname) set" where
+  "Dep SKIP = Id" |
+  "Dep (x::=a) = {(u,v). if v = x then u \<in> vars a else u = v}" |
+  "Dep (c1;;c2) = Dep c1 O Dep c2" |
+  "Dep (IF b THEN c1 ELSE c2) = Dep c1 \<union> Dep c2 \<union> vars b \<times> (lvars c1 \<union> lvars c2)" |
+  "Dep (WHILE b DO c) = lfp (\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R)"
+
+abbreviation Deps :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
+  "Deps c X \<equiv> (\<Union> x\<in>X. {y. (y, x) \<in> Dep c})"
+
+lemma nlvars_Dep: "\<lbrakk>lvars c \<inter> X = {}; x \<in> X; (y, x) \<in> Dep c\<rbrakk> \<Longrightarrow> y = x"
+proof (induct c arbitrary: x y)
+  case (Assign x1 x2)
+  from Assign(1) have "x1 \<notin> X" by simp
+  with Assign(2) have "x \<noteq> x1" by auto
+  with Assign(3) show ?case by simp
+next
+  case (Seq c1 c2)
+  from Seq(3) have Hv: "lvars c1 \<inter> X = {}" "lvars c2 \<inter> X = {}" by auto
+  from Seq(5) obtain x' where Hd: "(y, x') \<in> Dep c1" "(x', x) \<in> Dep c2" by auto
+  from Seq(2) [OF Hv(2) Seq(4) Hd(2)] have "x' = x" .
+  moreover from this Seq(4) have "x' \<in> X" by simp
+  from Seq(1) [OF Hv(1) this Hd(1)] have "y = x'" .
+  ultimately show ?case by simp
+next
+  case (If b c1 c2)
+  from If(3) have Hv: "lvars c1 \<inter> X = {}" "lvars c2 \<inter> X = {}" by auto
+  from If(5) consider (Hc1) "(y, x) \<in> Dep c1" | (Hc2) "(y, x) \<in> Dep c2" | (Hb) "(y, x) \<in> vars b \<times> (lvars c1 \<union> lvars c2)" by auto
+  then show ?case
+  proof cases
+    case Hc1
+    from If(1) [OF Hv(1) If(4) this] show ?thesis .
+  next
+    case Hc2
+    from If(2) [OF Hv(2) If(4) this] show ?thesis .
+  next
+    case Hb
+    with If(4) have "x \<in> lvars (IF b THEN c1 ELSE c2) \<inter> X" by simp
+    with If(3) show ?thesis by simp
+  qed
+next
+  case (While b c)
+  let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
+  let ?GX = "{(y, x)|y x. x \<in> X \<longrightarrow> y = x}"
+  from While(2) have lcXv: "lvars c \<inter> X = {}" by simp
+  have "Id \<subseteq> ?GX" by auto
+  moreover from lcXv have "vars b \<times> lvars c \<subseteq> ?GX" by auto
+  moreover have "Dep c O ?GX \<subseteq> ?GX"
+  proof
+    fix p
+    assume pin: "p \<in> Dep c O ?GX"
+    then obtain x y where xy: "p = (y, x)" by auto
+    show "p \<in> ?GX"
+    proof (cases "x \<in> X")
+      case True
+      from pin xy obtain x' where xx'y: "(y, x') \<in> Dep c" "(x', x) \<in> ?GX" by auto
+      from True xx'y(2) have "x' = x" by simp
+      moreover from True this have "x' \<in> X" by simp
+      from While(1) [OF lcXv this xx'y(1)] have "y = x'" .
+      ultimately have "y = x" by simp
+      with xy show ?thesis by simp
+    next
+      case False
+      with xy show ?thesis by simp
+    qed
+  qed
+  ultimately have "?f ?GX \<subseteq> ?GX" by simp
+  then have "lfp ?f \<subseteq> ?GX" by (auto intro!: lfp_lowerbound)
+  with While(4) have "(y, x) \<in> ?GX" by auto
+  with While(3) show ?case by simp
+qed simp
+
+lemma nlvars_Dep_str: "\<lbrakk>lvars c \<inter> X = {}; x \<in> X\<rbrakk> \<Longrightarrow> (x, x) \<in> Dep c"
+proof (induct c arbitrary: x)
+  case (Assign x1 x2)
+  from Assign(1, 2) have "x \<noteq> x1" by auto
+  then show ?case by simp
+next
+  case (While b c)
+  from While(2) have lcXv: "lvars c \<inter> X = {}" by simp
+  from While(1) [OF this While(3)] have "(x, x) \<in> Dep c" .
+  moreover let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
+  have "mono ?f" unfolding mono_def by auto
+  from lfp_fixpoint [OF this] have "?f (lfp ?f) = lfp ?f" .
+  ultimately show ?case by auto
+qed auto
+
+lemma nlvars_Deps_X: "lvars c \<inter> X = {} \<Longrightarrow> Deps c X \<subseteq> X"
+proof
+  fix y
+  assume assm: "lvars c \<inter> X = {}" "y \<in> Deps c X"
+  from this(2) obtain x where Hx: "(y, x) \<in> Dep c" "x \<in> X" by auto
+  from nlvars_Dep [OF assm(1) Hx(2) Hx(1)] have "y = x" .
+  with Hx(2) show "y \<in> X" by simp
+qed
+
+lemma nlvars_X_Deps: "lvars c \<inter> X = {} \<Longrightarrow> X \<subseteq> Deps c X"
+  by (auto simp add: nlvars_Dep_str)
+
+lemma nlvars_Deps: "lvars c \<inter> X = {} \<Longrightarrow> Deps c X = X"
+  by (intro equalityI) (simp add: nlvars_Deps_X nlvars_X_Deps)+
+
+lemma nlvars_big_step: "\<lbrakk>(c, s) \<Rightarrow> s'; lvars c \<inter> X = {}\<rbrakk> \<Longrightarrow> s = s' on X"
+proof (induct rule: big_step_induct)
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  from Seq(5) have "lvars c\<^sub>1 \<inter> X = {}" "lvars c\<^sub>2 \<inter> X = {}" by auto
+  with Seq show ?case by auto
+qed auto
+
+lemma "\<lbrakk>(c, s) \<Rightarrow> s'; (c, t) \<Rightarrow> t'; s = t on Deps c X\<rbrakk> \<Longrightarrow> s' = t' on X"
+proof (induct arbitrary: t t' X rule: big_step_induct)
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  from Seq(5) obtain ti where Hti: "(c\<^sub>1, t) \<Rightarrow> ti" "(c\<^sub>2, ti) \<Rightarrow> t'" by auto
+  from Seq(6) have "s\<^sub>1 = t on Deps c\<^sub>1 (Deps c\<^sub>2 X)" by auto
+  from Seq(2) [OF Hti(1) this] have "s\<^sub>2 = ti on Deps c\<^sub>2 X" .
+  from Seq(4) [OF Hti(2) this] show ?case .
+next
+  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
+  let ?i = "IF b THEN c\<^sub>1 ELSE c\<^sub>2"
+  show ?case
+  proof (cases "lvars ?i \<inter> X = {}")
+    case True
+    from nlvars_Deps [OF this] IfTrue(5) have "s = t on X" by simp
+    moreover from True have "lvars c\<^sub>1 \<inter> X = {}" by auto
+    from nlvars_big_step [OF IfTrue(2) this] have "s = s' on X" .
+    moreover from nlvars_big_step [OF IfTrue(4) True] have "t = t' on X" .
+    ultimately show ?thesis by simp
+  next
+    case False
+    with IfTrue(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>1 X" by auto
+    from bval_eq_if_eq_on_vars [OF Heq(1)] IfTrue(1) have "bval b t" by simp
+    with IfTrue(4) have "(c\<^sub>1, t) \<Rightarrow> t'" by auto
+    from IfTrue(3) [OF this Heq(2)] show ?thesis .
+  qed
+next
+  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
+  let ?i = "IF b THEN c\<^sub>1 ELSE c\<^sub>2"
+  show ?case
+  proof (cases "lvars ?i \<inter> X = {}")
+    case True
+    from nlvars_Deps [OF this] IfFalse(5) have "s = t on X" by simp
+    moreover from True have "lvars c\<^sub>2 \<inter> X = {}" by auto
+    from nlvars_big_step [OF IfFalse(2) this] have "s = s' on X" .
+    moreover from nlvars_big_step [OF IfFalse(4) True] have "t = t' on X" .
+    ultimately show ?thesis by simp
+  next
+    case False
+    with IfFalse(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>2 X" by auto
+    from bval_eq_if_eq_on_vars [OF Heq(1)] IfFalse(1) have "\<not>bval b t" by simp
+    with IfFalse(4) have "(c\<^sub>2, t) \<Rightarrow> t'" by auto
+    from IfFalse(3) [OF this Heq(2)] show ?thesis .
+  qed
+next
+  case (WhileFalse b s c)
+  let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
+  let ?w = "WHILE b DO c"
+  have monof: "mono ?f" unfolding mono_def by auto
+  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
+  show ?case
+  proof (cases "lvars ?w \<inter> X = {}")
+    case True
+    from nlvars_Deps [OF this] WhileFalse(3) have "s = t on X" by simp
+    moreover from nlvars_big_step [OF WhileFalse(2) True] have "t = t' on X" .
+    ultimately show "s = t' on X" by simp
+  next
+    case False
+    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
+    also from fpf have "\<dots> \<subseteq> Deps ?w X" by simp
+    finally have "vars b \<subseteq> Deps ?w X" .
+    with WhileFalse(3) have Heq1: "s = t on vars b" by auto
+    from bval_eq_if_eq_on_vars [OF Heq1] WhileFalse(1) have "\<not>bval b t" by simp
+    with WhileFalse(2) have Htt': "t' = t" by auto
+    from False have "X \<subseteq> (\<Union>x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
+    also from fpf have "\<dots> \<subseteq> Deps ?w X" by simp
+    finally have Heq2: "X \<subseteq> Deps ?w X" .
+    with WhileFalse(3) Htt' show ?thesis by auto
+  qed
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
+  let ?w = "WHILE b DO c"
+  have monof: "mono ?f" unfolding mono_def by auto
+  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
+  show ?case
+  proof (cases "lvars ?w \<inter> X = {}")
+    case True
+    from nlvars_Deps [OF True] WhileTrue(7) have "s\<^sub>1 = t on X" by simp
+    moreover from True have "lvars c \<inter> X = {}" by simp
+    from nlvars_big_step [OF WhileTrue(2) this] have "s\<^sub>1 = s\<^sub>2 on X" .
+    moreover from nlvars_big_step [OF WhileTrue(4) True] have "s\<^sub>2 = s\<^sub>3 on X" .
+    moreover from nlvars_big_step [OF WhileTrue(6) True] have "t = t' on X" .
+    ultimately show ?thesis by simp
+  next
+    case False
+    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
+    also from fpf have "\<dots> \<subseteq> Deps ?w X" by simp
+    finally have "vars b \<subseteq> Deps ?w X" .
+    with WhileTrue(7) have Heq1: "s\<^sub>1 = t on vars b" by auto
+    from bval_eq_if_eq_on_vars [OF Heq1] WhileTrue(1) have "bval b t" by simp
+    with WhileTrue(6) obtain ti where Htw: "(c, t) \<Rightarrow> ti" "(?w, ti) \<Rightarrow> t'" by auto
+    have "Deps c (Deps ?w X) \<subseteq> Deps ?w X" using lfp_fixpoint [OF monof] by auto
+    with WhileTrue(7) have "s\<^sub>1 = t on Deps c (Deps ?w X)" by blast
+    from WhileTrue(3) [OF Htw(1) this] have "s\<^sub>2 = ti on Deps ?w X" .
+    from WhileTrue(5) [OF Htw(2) this] show ?thesis .
+  qed
+qed auto
+
+lemma "\<exists> c s s' t X. (c, s) \<Rightarrow> s' \<and> s = t on Deps c X \<and> (\<nexists>t'. (c, t) \<Rightarrow> t')"
+proof -
+  let ?b = "Less (N 0) (V ''x'')"
+  let ?c = "SKIP"
+  let ?w = "WHILE ?b DO ?c"
+  let ?s = "<> :: vname \<Rightarrow> val"
+  let ?t = "<''x'' := 1> :: vname \<Rightarrow> val"
+  have H1: "(?w, ?s) \<Rightarrow> ?s" unfolding null_state_def by auto
+  have H2: "?s = ?t on Deps ?w {}" by simp
+  have Hbt: "bval ?b ?t" by simp
+  have H3: "\<nexists>t'. (?w, ?t) \<Rightarrow> t'"
+  proof
+    assume "\<exists>t'. (?w, ?t) \<Rightarrow> t'"
+    then obtain t' where "(?w, ?t) \<Rightarrow> t'" by auto
+    then show "False"
+      using Hbt by (induct "?w" "?t" t' rule: big_step_induct) auto
+  qed
+  from H1 H2 H3 show ?thesis by blast
+qed
+
diff --git a/Short_Theory_12_11.thy b/Short_Theory_12_11.thy
new file mode 100644
index 0000000..485043a
--- /dev/null
+++ b/Short_Theory_12_11.thy
@@ -0,0 +1,199 @@
+theory Short_Theory_12_11
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype
+  com = SKIP
+  | Do "state \<Rightarrow> state"       ("DO _" [61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 60, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+
+inductive big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55) where
+    Skip: "(SKIP, s) \<Rightarrow> s" |
+    Do: "(DO f, s) \<Rightarrow> f s" |
+    Seq: "\<lbrakk> (c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1, s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> s'" |
+    IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2, s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> s'" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c, s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk> bval b s\<^sub>1;  (c, s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE[elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_DoE[elim!]: "\<lbrakk>(DO f, s) \<Rightarrow> t; t = f s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE[elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+abbreviation
+  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
+  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
+lemma unfold_while:
+  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
+proof -
+  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
+  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
+  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
+      case WhileFalse
+      thus ?thesis by blast
+    next
+      case WhileTrue
+      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
+      \<comment> \<open>first, the body of the True-branch:\<close>
+      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
+      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
+    qed
+  qed
+  moreover
+  \<comment> \<open>now the other direction:\<close>
+  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
+      case IfFalse
+      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
+      thus ?thesis using \<open>\<not>bval b s\<close> by blast
+    next
+      case IfTrue
+      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
+      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
+    qed
+  qed
+  ultimately
+  show ?thesis by blast
+qed
+
+
+section "Hoare Logic"
+
+type_synonym assn = "state \<Rightarrow> bool"
+
+definition
+hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
+"\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"
+
+abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
+  ("_[_'/_]" [1000,0,0] 999)
+  where "s[a/x] == s(x := aval a s)"
+
+inductive
+  hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
+where
+Skip: "\<turnstile> {P} SKIP {P}"  |
+Do:  "\<turnstile> {\<lambda>s. P (f s)} DO f {P}"  |
+Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk>
+      \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"  |
+If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
+     \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |
+While: "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P} \<Longrightarrow>
+        \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"  |
+conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
+        \<Longrightarrow> \<turnstile> {P'} c {Q'}"
+lemmas [simp] = hoare.Skip hoare.Do hoare.Seq If
+lemmas [intro!] = hoare.Skip hoare.Do hoare.Seq hoare.If
+lemma strengthen_pre:
+  "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q} \<rbrakk> \<Longrightarrow> \<turnstile> {P'} c {Q}"
+by (blast intro: conseq)
+lemma weaken_post:
+  "\<lbrakk> \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk> \<Longrightarrow>  \<turnstile> {P} c {Q'}"
+by (blast intro: conseq)
+
+lemma Do': "\<forall>s. P s \<longrightarrow> Q(f s) \<Longrightarrow> \<turnstile> {P} DO f {Q}"
+  by (simp add: strengthen_pre [OF _ Do])
+
+lemma While':
+  assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
+  shows "\<turnstile> {P} WHILE b DO c {Q}"
+  by(rule weaken_post [OF While [OF assms(1)] assms(2)])
+
+lemma hoare_sound: "\<turnstile> {P}c{Q}  \<Longrightarrow>  \<Turnstile> {P}c{Q}"
+proof(induction rule: hoare.induct)
+  case (While P b c)
+  have "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow>  P s  \<Longrightarrow>  P t \<and> \<not> bval b t" for s t
+  proof(induction "WHILE b DO c" s t rule: big_step_induct)
+    case WhileFalse thus ?case by blast
+  next
+    case WhileTrue thus ?case
+      using While.IH unfolding hoare_valid_def by blast
+  qed
+  thus ?case unfolding hoare_valid_def by blast
+qed (auto simp: hoare_valid_def)
+
+definition wp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
+"wp c Q = (\<lambda>s. \<forall>t. (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"
+
+lemma wp_SKIP[simp]: "wp SKIP Q = Q"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_Do[simp]: "wp (DO f) Q = (\<lambda>s. Q (f s))"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_Seq[simp]: "wp (c\<^sub>1;;c\<^sub>2) Q = wp c\<^sub>1 (wp c\<^sub>2 Q)"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_If[simp]:
+  "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q =
+  (\<lambda>s. if bval b s then wp c\<^sub>1 Q s else wp c\<^sub>2 Q s)"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_While_If:
+  "wp (WHILE b DO c) Q s =
+  wp (IF b THEN c;;WHILE b DO c ELSE SKIP) Q s"
+unfolding wp_def by (metis unfold_while)
+
+lemma wp_While_True[simp]: "bval b s \<Longrightarrow>
+  wp (WHILE b DO c) Q s = wp (c;; WHILE b DO c) Q s"
+by(simp add: wp_While_If)
+
+lemma wp_While_False[simp]: "\<not> bval b s \<Longrightarrow> wp (WHILE b DO c) Q s = Q s"
+  by(simp add: wp_While_If)
+lemma wp_is_pre: "\<turnstile> {wp c Q} c {Q}"
+proof(induction c arbitrary: Q)
+  case If thus ?case by(auto intro: conseq)
+next
+  case (While b c)
+  let ?w = "WHILE b DO c"
+  show "\<turnstile> {wp ?w Q} ?w {Q}"
+  proof(rule While')
+    show "\<turnstile> {\<lambda>s. wp ?w Q s \<and> bval b s} c {wp ?w Q}"
+    proof(rule strengthen_pre[OF _ While.IH])
+      show "\<forall>s. wp ?w Q s \<and> bval b s \<longrightarrow> wp c (wp ?w Q) s" by auto
+    qed
+    show "\<forall>s. wp ?w Q s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
+  qed
+qed auto
+lemma hoare_complete: assumes "\<Turnstile> {P}c{Q}" shows "\<turnstile> {P}c{Q}"
+proof(rule strengthen_pre)
+  show "\<forall>s. P s \<longrightarrow> wp c Q s" using assms
+    by (auto simp: hoare_valid_def wp_def)
+  show "\<turnstile> {wp c Q} c {Q}" by(rule wp_is_pre)
+qed
+corollary hoare_sound_complete: "\<turnstile> {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q}"
+by (metis hoare_complete hoare_sound)
+
+end
\ No newline at end of file
diff --git a/Short_Theory_12_13.thy b/Short_Theory_12_13.thy
new file mode 100644
index 0000000..89758bd
--- /dev/null
+++ b/Short_Theory_12_13.thy
@@ -0,0 +1,224 @@
+theory Short_Theory_12_13
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype
+  com = SKIP 
+  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+  | Or     com  com         ("(_/ OR _)" [0, 61] 61)
+
+inductive
+  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
+  where
+    Skip: "(SKIP, s) \<Rightarrow> s" |
+    Assign: "(x ::= a, s) \<Rightarrow> s(x := aval a s)" |
+    Seq: "\<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> s'\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> s'" |
+    IfFalse: "\<lbrakk>\<not>bval b s;  (c\<^sub>2, s) \<Rightarrow> s'\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> s'" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk>bval b s\<^sub>1; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    OrLeft: "(c\<^sub>1,s) \<Rightarrow> s' \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> s'" |
+    OrRight: "(c\<^sub>2,s) \<Rightarrow> s' \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> s'"
+
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE [elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE [elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE [elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE [elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE [elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_Or [elim!]: "\<lbrakk>(c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t; (c\<^sub>1, s) \<Rightarrow> t \<Longrightarrow> P; (c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+abbreviation equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
+  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
+
+lemma "(c\<^sub>1 OR c\<^sub>2) \<sim> (c\<^sub>2 OR c\<^sub>1)" by blast
+
+lemma unfold_while:
+  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
+proof -
+  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
+  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
+  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
+      case WhileFalse
+      thus ?thesis by blast
+    next
+      case WhileTrue
+      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
+      \<comment> \<open>first, the body of the True-branch:\<close>
+      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
+      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
+    qed
+  qed
+  moreover
+  \<comment> \<open>now the other direction:\<close>
+  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
+      case IfFalse
+      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
+      thus ?thesis using \<open>\<not>bval b s\<close> by blast
+    next
+      case IfTrue
+      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
+      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
+    qed
+  qed
+  ultimately
+  show ?thesis by blast
+qed
+
+type_synonym assn = "state \<Rightarrow> bool"
+
+section "Hoare Logic"
+
+definition hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
+  ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
+  "\<Turnstile> {P} c {Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"
+
+abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
+  ("_[_'/_]" [1000,0,0] 999) where
+  "s[a/x] == s(x := aval a s)"
+
+inductive hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
+  ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50) where
+  Skip: "\<turnstile> {P} SKIP {P}" |
+  Assign:  "\<turnstile> {\<lambda>s. P(s[a/x])} x::=a {P}" |
+  Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk> \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}" |
+  If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
+    \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}" |
+  While: "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P} \<Longrightarrow>
+    \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}" |
+  Or: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {P} c\<^sub>2 {Q} \<rbrakk>
+    \<Longrightarrow> \<turnstile> {P} c\<^sub>1 OR c\<^sub>2 {Q}" |
+  conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
+    \<Longrightarrow> \<turnstile> {P'} c {Q'}"
+
+lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq hoare.If hoare.Or
+
+lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If hoare.Or
+
+lemma strengthen_pre: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q} \<rbrakk> \<Longrightarrow> \<turnstile> {P'} c {Q}"
+  by (blast intro: conseq)
+
+lemma weaken_post: "\<lbrakk> \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk> \<Longrightarrow>  \<turnstile> {P} c {Q'}"
+  by (blast intro: conseq)
+
+lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile> {P} x ::= a {Q}"
+  by (simp add: strengthen_pre[OF _ Assign])
+
+lemma While':
+  assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}"
+    and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
+  shows "\<turnstile> {P} WHILE b DO c {Q}"
+  by(rule weaken_post[OF While[OF assms(1)] assms(2)])
+
+subsection \<open>Soundness and Completeness\<close>
+
+lemma hoare_sound: "\<turnstile> {P}c{Q}  \<Longrightarrow>  \<Turnstile> {P}c{Q}"
+proof(induction rule: hoare.induct)
+  case (While P b c)
+  have "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow>  P s  \<Longrightarrow>  P t \<and> \<not> bval b t" for s t
+  proof(induction "WHILE b DO c" s t rule: big_step_induct)
+    case WhileFalse thus ?case by blast
+  next
+    case WhileTrue thus ?case
+      using While.IH unfolding hoare_valid_def by blast
+  qed
+  thus ?case unfolding hoare_valid_def by blast
+qed (auto simp: hoare_valid_def)
+
+definition wp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
+"wp c Q = (\<lambda>s. \<forall>t. (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"
+
+lemma wp_SKIP[simp]: "wp SKIP Q = Q"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_Ass[simp]: "wp (x::=a) Q = (\<lambda>s. Q(s[a/x]))"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_Seq[simp]: "wp (c\<^sub>1;;c\<^sub>2) Q = wp c\<^sub>1 (wp c\<^sub>2 Q)"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_If[simp]:
+  "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q =
+  (\<lambda>s. if bval b s then wp c\<^sub>1 Q s else wp c\<^sub>2 Q s)"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_While_If:
+  "wp (WHILE b DO c) Q s =
+  wp (IF b THEN c;;WHILE b DO c ELSE SKIP) Q s"
+  unfolding wp_def by (metis unfold_while)
+
+lemma wp_While_True[simp]: "bval b s \<Longrightarrow>
+  wp (WHILE b DO c) Q s = wp (c;; WHILE b DO c) Q s"
+by(simp add: wp_While_If)
+
+lemma wp_While_False[simp]: "\<not> bval b s \<Longrightarrow> wp (WHILE b DO c) Q s = Q s"
+by(simp add: wp_While_If)
+
+lemma wp_Or[simp]:
+  "wp (c\<^sub>1 OR c\<^sub>2) Q =
+  (\<lambda>s. wp c\<^sub>1 Q s \<and> wp c\<^sub>2 Q s)"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_is_pre: "\<turnstile> {wp c Q} c {Q}"
+proof(induction c arbitrary: Q)
+  case If thus ?case by (auto intro: conseq)
+next
+  case (While b c)
+  let ?w = "WHILE b DO c"
+  show "\<turnstile> {wp ?w Q} ?w {Q}"
+  proof(rule While')
+    show "\<turnstile> {\<lambda>s. wp ?w Q s \<and> bval b s} c {wp ?w Q}"
+    proof(rule strengthen_pre[OF _ While.IH])
+      show "\<forall>s. wp ?w Q s \<and> bval b s \<longrightarrow> wp c (wp ?w Q) s" by auto
+    qed
+    show "\<forall>s. wp ?w Q s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
+  qed
+next
+  case Or thus ?case by (auto intro: conseq)
+qed auto
+
+lemma hoare_complete: assumes "\<Turnstile> {P} c {Q}" shows "\<turnstile> {P} c {Q}"
+proof(rule strengthen_pre)
+  show "\<forall>s. P s \<longrightarrow> wp c Q s" using assms
+    by (auto simp: hoare_valid_def wp_def)
+  show "\<turnstile> {wp c Q} c {Q}" by (rule wp_is_pre)
+qed
+
+corollary hoare_sound_complete: "\<turnstile> {P} c {Q} \<longleftrightarrow> \<Turnstile> {P} c {Q}"
+by (metis hoare_complete hoare_sound)
+
+end
\ No newline at end of file
diff --git a/Short_Theory_12_14.thy b/Short_Theory_12_14.thy
new file mode 100644
index 0000000..064b557
--- /dev/null
+++ b/Short_Theory_12_14.thy
@@ -0,0 +1,313 @@
+theory Short_Theory_12_14
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype
+  com = SKIP
+  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 60, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+  | Repeat com bexp         ("(REPEAT _/ UNTIL _)" [60, 0] 61)
+
+inductive
+  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
+  where
+    Skip: "(SKIP,s) \<Rightarrow> s" |
+    Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
+    Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    RepeatTrue: "\<lbrakk> bval b t; (c, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
+    RepeatFalse: "\<lbrakk> \<not>bval b s\<^sub>2; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE[elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE[elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_RepeatE[elim]: "\<lbrakk>
+  (REPEAT c UNTIL b, s) \<Rightarrow> t;
+  \<lbrakk>bval b t; (c, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>\<not> bval b s\<^sub>2; (c, s) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+abbreviation
+  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
+  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
+
+theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
+  by (induct arbitrary: u rule: big_step.induct) blast+
+
+lemma unfold_while:
+  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
+proof -
+  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
+  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
+  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
+      case WhileFalse
+      thus ?thesis by blast
+    next
+      case WhileTrue
+      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
+      \<comment> \<open>first, the body of the True-branch:\<close>
+      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
+      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
+    qed
+  qed
+  moreover
+  \<comment> \<open>now the other direction:\<close>
+  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
+  proof -
+    from assm show ?thesis
+    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
+      case IfFalse
+      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
+      thus ?thesis using \<open>\<not>bval b s\<close> by blast
+    next
+      case IfTrue
+      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
+      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
+        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
+      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
+      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
+    qed
+  qed
+  ultimately
+  show ?thesis by blast
+qed
+
+lemma unfold_repeat:
+  "(REPEAT c UNTIL b) \<sim> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b)" (is "?r \<sim> ?sr")
+proof -
+  {
+    fix s t
+    assume "(?r, s) \<Rightarrow> t"
+    then have "(?sr, s) \<Rightarrow> t"
+    proof cases
+      case RepeatTrue
+      thus ?thesis by blast
+    next
+      case (RepeatFalse s\<^sub>2)
+      from RepeatFalse(1, 2) have "\<not>(bval b t \<and> (c, s) \<Rightarrow> t)"
+        by (cases "s\<^sub>2 = t") (auto simp add: big_step_determ)
+      with \<open>(?r, s) \<Rightarrow> t\<close> obtain s' where
+        "\<not> bval b s'" "(c, s) \<Rightarrow> s'" and "(?r, s') \<Rightarrow> t" by auto
+      from this(1, 3) have "(IF b THEN SKIP ELSE ?r, s') \<Rightarrow> t" by (rule IfFalse)
+      with \<open>(c, s) \<Rightarrow> s'\<close> show ?thesis by (rule Seq)
+    qed
+  }
+  moreover
+  {
+    fix s t
+    assume "(?sr, s) \<Rightarrow> t"
+    then have "(?r, s) \<Rightarrow> t"
+    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
+      case (Seq s\<^sub>2)
+      from Seq(2) show "(?r, s) \<Rightarrow> t"
+      proof cases
+        case IfTrue
+        from IfTrue(2) have "s\<^sub>2 = t" by auto
+        with Seq(1) IfTrue(1) show ?thesis by auto
+      next
+        case IfFalse
+        with Seq(1) show ?thesis by auto
+      qed
+    qed
+  }
+  ultimately
+  show ?thesis by blast
+qed
+
+type_synonym assn = "state \<Rightarrow> bool"
+
+definition hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
+  "\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"
+
+abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
+  ("_[_'/_]" [1000,0,0] 999) where
+  "s[a/x] == s(x := aval a s)"
+
+inductive hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50) where
+  Skip: "\<turnstile> {P} SKIP {P}" |
+  Assign: "\<turnstile> {\<lambda>s. P(s[a/x])} x::=a {P}" |
+  Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q}; \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk> \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}" |
+  If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
+    \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}" |
+  While: "\<lbrakk>\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}\<rbrakk> \<Longrightarrow> \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}" |
+  Repeat: "\<lbrakk>\<turnstile> {P} c {Q}; \<forall>s. Q s \<and> \<not>bval b s \<longrightarrow> P s\<rbrakk> \<Longrightarrow> \<turnstile> {P} REPEAT c UNTIL b {\<lambda>s. Q s \<and> bval b s}" |
+  conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
+    \<Longrightarrow> \<turnstile> {P'} c {Q'}"
+
+lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq If
+
+lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If
+
+lemma strengthen_pre:
+  "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q} \<rbrakk> \<Longrightarrow> \<turnstile> {P'} c {Q}"
+by (blast intro: conseq)
+
+lemma weaken_post:
+  "\<lbrakk> \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk> \<Longrightarrow>  \<turnstile> {P} c {Q'}"
+by (blast intro: conseq)
+
+text\<open>The assignment and While rule are awkward to use in actual proofs
+because their pre and postcondition are of a very special form and the actual
+goal would have to match this form exactly. Therefore we derive two variants
+with arbitrary pre and postconditions.\<close>
+
+lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile> {P} x ::= a {Q}"
+by (simp add: strengthen_pre[OF _ Assign])
+
+lemma While':
+assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
+shows "\<turnstile> {P} WHILE b DO c {Q}"
+  by(rule weaken_post[OF While[OF assms(1)] assms(2)])
+
+lemma Repeat':
+  assumes "\<turnstile> {P} c {Q}" and "\<forall>s. Q s \<and> \<not>bval b s \<longrightarrow> P s" and "\<forall>s. Q s \<and> bval b s \<longrightarrow> Q' s"
+  shows "\<turnstile> {P} REPEAT c UNTIL b {Q'}"
+  by (rule weaken_post [OF Repeat [OF assms(1) assms(2)] assms(3)])
+
+lemma hoare_sound: "\<turnstile> {P} c {Q} \<Longrightarrow> \<Turnstile> {P} c {Q}"
+proof(induction rule: hoare.induct)
+  case (While P b c)
+  have "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow>  P s  \<Longrightarrow>  P t \<and> \<not> bval b t" for s t
+  proof(induction "WHILE b DO c" s t rule: big_step_induct)
+    case WhileFalse thus ?case by blast
+  next
+    case WhileTrue thus ?case
+      using While.IH unfolding hoare_valid_def by blast
+  qed
+  thus ?case unfolding hoare_valid_def by blast
+next
+  case (Repeat P c Q b)
+  have "(REPEAT c UNTIL b, s) \<Rightarrow> t \<Longrightarrow> P s \<Longrightarrow> Q t \<and> bval b t" for s t
+  proof (induct "REPEAT c UNTIL b" s t rule: big_step_induct) (* note: case analysis sufficed *)
+    case (RepeatTrue t s)
+    from Repeat(3) RepeatTrue(1, 2, 4) show ?case unfolding hoare_valid_def by blast 
+  next
+    case (RepeatFalse s\<^sub>2 s\<^sub>1 s\<^sub>3)
+    from Repeat(2, 3) RepeatFalse(1, 2, 5, 6) show ?case unfolding hoare_valid_def by blast
+  qed
+  thus ?case unfolding hoare_valid_def by blast
+qed (auto simp: hoare_valid_def)
+
+definition wp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
+"wp c Q = (\<lambda>s. \<forall>t. (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"
+
+lemma wp_SKIP[simp]: "wp SKIP Q = Q"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_Ass[simp]: "wp (x::=a) Q = (\<lambda>s. Q(s[a/x]))"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_Seq[simp]: "wp (c\<^sub>1;;c\<^sub>2) Q = wp c\<^sub>1 (wp c\<^sub>2 Q)"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_If[simp]:
+  "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q =
+  (\<lambda>s. if bval b s then wp c\<^sub>1 Q s else wp c\<^sub>2 Q s)"
+  by (rule ext) (auto simp: wp_def)
+
+lemma wp_While_If:
+  "wp (WHILE b DO c) Q s =
+  wp (IF b THEN c;;WHILE b DO c ELSE SKIP) Q s"
+  unfolding wp_def by (metis unfold_while)
+
+lemma wp_While_True[simp]: "bval b s \<Longrightarrow>
+  wp (WHILE b DO c) Q s = wp (c;; WHILE b DO c) Q s"
+  by(simp add: wp_While_If)
+
+lemma wp_While_False[simp]: "\<not> bval b s \<Longrightarrow> wp (WHILE b DO c) Q s = Q s"
+  by(simp add: wp_While_If)
+
+lemma wp_Repeat_If:
+  "wp (REPEAT c UNTIL b) Q s =
+  wp (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b) Q s"
+  unfolding wp_def by (metis unfold_repeat)
+
+lemma wp_Repeat [simp]: "wp c (\<lambda>s. wp (REPEAT c UNTIL b) Q s \<and> \<not>bval b s \<or> Q s \<and> bval b s) s = wp (REPEAT c UNTIL b) Q s"
+  unfolding wp_def by (auto simp add: wp_Repeat_If)
+
+lemma wp_c_bval_or: "wp c (bval b) s \<or> wp c (\<lambda>s. \<not>bval b s) s"
+  unfolding wp_def
+proof (cases "\<forall>t. (c, s) \<Rightarrow> t \<longrightarrow> bval b t")
+  case False
+  then obtain t\<^sub>0 where H: "(c, s) \<Rightarrow> t\<^sub>0" "\<not>bval b t\<^sub>0" by blast
+  then show "(\<forall>t. (c, s) \<Rightarrow> t \<longrightarrow> bval b t) \<or> (\<forall>t. (c, s) \<Rightarrow> t \<longrightarrow> \<not> bval b t)" (is "?L \<or> ?R")
+  proof -
+    have "?R"
+    proof (intro allI impI)
+      fix t
+      assume "(c, s) \<Rightarrow> t"
+      with H(1) have "t = t\<^sub>0" by (simp add: big_step_determ)
+      with H(2) show "\<not>bval b t" by simp
+    qed
+    then show ?thesis by blast
+  qed
+qed simp
+
+lemma wp_is_pre: "\<turnstile> {wp c Q} c {Q}"
+proof(induction c arbitrary: Q)
+  case If thus ?case by(auto intro: conseq)
+next
+  case (While b c)
+  let ?w = "WHILE b DO c"
+  show "\<turnstile> {wp ?w Q} ?w {Q}"
+  proof(rule While')
+    show "\<turnstile> {\<lambda>s. wp ?w Q s \<and> bval b s} c {wp ?w Q}"
+    proof(rule strengthen_pre[OF _ While.IH])
+      show "\<forall>s. wp ?w Q s \<and> bval b s \<longrightarrow> wp c (wp ?w Q) s" by auto
+    qed
+    show "\<forall>s. wp ?w Q s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
+  qed
+next
+  case (Repeat c b)
+  let ?r = "REPEAT c UNTIL b"
+  show "\<turnstile> {wp ?r Q} ?r {Q}"
+  proof (rule Repeat')
+    show "\<turnstile> {wp (REPEAT c UNTIL b) Q} c {\<lambda>s. (wp (REPEAT c UNTIL b) Q s \<and> \<not>bval b s) \<or> (Q s \<and> bval b s)}"
+      by (rule strengthen_pre [OF _ Repeat]) simp
+  qed auto
+qed auto
+
+lemma hoare_complete: assumes "\<Turnstile> {P}c{Q}" shows "\<turnstile> {P}c{Q}"
+proof(rule strengthen_pre)
+  show "\<forall>s. P s \<longrightarrow> wp c Q s" using assms
+    by (auto simp: hoare_valid_def wp_def)
+  show "\<turnstile> {wp c Q} c {Q}" by(rule wp_is_pre)
+qed
+
+corollary hoare_sound_complete: "\<turnstile> {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q}"
+  by (metis hoare_complete hoare_sound)
+
+end
\ No newline at end of file
diff --git a/Short_Theory_13_14.thy b/Short_Theory_13_14.thy
new file mode 100644
index 0000000..b798403
--- /dev/null
+++ b/Short_Theory_13_14.thy
@@ -0,0 +1,178 @@
+theory Short_Theory_13_14
+  imports "HOL-IMP.Abs_Int1"
+begin
+
+datatype sign = Neg | Zero | Pos | Any
+
+text\<open>Instantiation of class \<^class>\<open>order\<close> with type \<^typ>\<open>sign\<close>:\<close>
+
+instantiation sign :: order
+begin
+
+text\<open>First the definition of the interface function \<open>\<le>\<close>. Note that
+the header of the definition must refer to the ascii name \<^const>\<open>less_eq\<close> of the
+constants as \<open>less_eq_parity\<close> and the definition is named \<open>less_eq_parity_def\<close>.  Inside the definition the symbolic names can be used.\<close>
+
+definition less_eq_sign where
+"x \<le> y = (y = Any \<or> x=y)"
+
+text\<open>We also need \<open><\<close>, which is defined canonically:\<close>
+
+definition less_sign where
+"x < y = (x \<le> y \<and> \<not> y \<le> (x::sign))"
+
+text\<open>\noindent(The type annotation is necessary to fix the type of the polymorphic predicates.)
+
+Now the instance proof, i.e.\ the proof that the definition fulfills
+the axioms (assumptions) of the class. The initial proof-step generates the
+necessary proof obligations.\<close>
+
+instance
+proof
+  fix x::sign show "x \<le> x" by(auto simp: less_eq_sign_def)
+next
+  fix x y z :: sign assume "x \<le> y" "y \<le> z" thus "x \<le> z"
+    by(auto simp: less_eq_sign_def)
+next
+  fix x y :: sign assume "x \<le> y" "y \<le> x" thus "x = y"
+    by(auto simp: less_eq_sign_def)
+next
+  fix x y :: sign show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" by(rule less_sign_def)
+qed
+
+end
+
+text\<open>Instantiation of class \<^class>\<open>semilattice_sup_top\<close> with type \<^typ>\<open>sign\<close>:\<close>
+
+instantiation sign :: semilattice_sup_top
+begin
+
+definition sup_sign where
+"x \<squnion> y = (if x = y then x else Any)"
+
+definition top_sign where
+"\<top> = Any"
+
+text\<open>Now the instance proof. This time we take a shortcut with the help of
+proof method \<open>goal_cases\<close>: it creates cases 1 ... n for the subgoals
+1 ... n; in case i, i is also the name of the assumptions of subgoal i and
+\<open>case?\<close> refers to the conclusion of subgoal i.
+The class axioms are presented in the same order as in the class definition.\<close>
+
+instance
+proof (standard, goal_cases)
+  case 1 (*sup1*) show ?case by(auto simp: less_eq_sign_def sup_sign_def)
+next
+  case 2 (*sup2*) show ?case by(auto simp: less_eq_sign_def sup_sign_def)
+next
+  case 3 (*sup least*) thus ?case by(auto simp: less_eq_sign_def sup_sign_def)
+next
+  case 4 (*top*) show ?case by(auto simp: less_eq_sign_def top_sign_def)
+qed
+
+end
+
+
+text\<open>Now we define the functions used for instantiating the abstract
+interpretation locales. Note that the Isabelle terminology is
+\emph{interpretation}, not \emph{instantiation} of locales, but we use
+instantiation to avoid confusion with abstract interpretation.\<close>
+
+fun \<gamma>_sign :: "sign \<Rightarrow> val set" where
+"\<gamma>_sign Neg = {i. i < 0}" |
+"\<gamma>_sign Zero  = {0}" |
+"\<gamma>_sign Pos  = {i. 0 < i}" |
+"\<gamma>_sign Any = UNIV"
+
+fun num_sign :: "val \<Rightarrow> sign" where
+"num_sign i = (if i < 0 then Neg else if 0 < i then Pos else Zero)"
+
+fun plus_sign :: "sign \<Rightarrow> sign \<Rightarrow> sign" where
+"plus_sign Neg Neg = Neg" |
+"plus_sign Neg Zero = Neg" |
+"plus_sign Zero  Neg  = Neg" |
+"plus_sign Zero Zero  = Zero" |
+"plus_sign Zero  Pos = Pos" |
+"plus_sign Pos  Zero = Pos" |
+"plus_sign Pos  Pos = Pos" |
+"plus_sign _  _ = Any"
+
+text\<open>First we instantiate the abstract value interface and prove that the
+functions on type \<^typ>\<open>sign\<close> have all the necessary properties:\<close>
+
+global_interpretation Val_semilattice
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+proof (standard, goal_cases) txt\<open>subgoals are the locale axioms\<close>
+  case 1 thus ?case by(auto simp: less_eq_sign_def)
+next
+  case 2 show ?case by(auto simp: top_sign_def)
+next
+  case 3 show ?case by auto
+next
+  case (4 _ a1 _ a2) thus ?case
+    by (induction a1 a2 rule: plus_sign.induct) auto
+qed
+
+text\<open>In case 4 we needed to refer to particular variables.
+Writing (i x y z) fixes the names of the variables in case i to be x, y and z
+in the left-to-right order in which the variables occur in the subgoal.
+Underscores are anonymous placeholders for variable names we don't care to fix.\<close>
+
+text\<open>Instantiating the abstract interpretation locale requires no more
+proofs (they happened in the instatiation above) but delivers the
+instantiated abstract interpreter which we call \<open>AI_parity\<close>:\<close>
+
+global_interpretation Abs_Int
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+defines aval_sign = aval' and step_sign = step' and AI_sign = AI
+..
+
+
+subsubsection "Tests"
+
+definition "test1_sign =
+  ''x'' ::= N 1;;
+  WHILE Less (V ''x'') (N 100) DO ''x'' ::= Plus (V ''x'') (N 2)"
+value "show_acom (the(AI_sign test1_sign))"
+
+definition "test2_sign =
+  ''x'' ::= N 1;;
+  WHILE Less (V ''x'') (N 100) DO ''x'' ::= Plus (V ''x'') (N 3)"
+
+definition "steps c i = ((step_sign \<top>) ^^ i) (bot c)"
+
+value "show_acom (steps test2_sign 0)"
+value "show_acom (steps test2_sign 1)"
+value "show_acom (steps test2_sign 2)"
+value "show_acom (steps test2_sign 3)"
+value "show_acom (steps test2_sign 4)"
+value "show_acom (steps test2_sign 5)"
+value "show_acom (steps test2_sign 6)"
+value "show_acom (the(AI_parity test2_sign))"
+
+
+subsubsection "Termination"
+
+global_interpretation Abs_Int_mono
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+proof (standard, goal_cases)
+  case (1 _ a1 _ a2) thus ?case
+    by(induction a1 a2 rule: plus_sign.induct)
+      (auto simp add:less_eq_sign_def)
+qed
+
+definition m_sign :: "sign \<Rightarrow> nat" where
+"m_sign x = (if x = Any then 0 else 1)"
+
+global_interpretation Abs_Int_measure
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+and m = m_sign and h = "1"
+proof (standard, goal_cases)
+  case 1 thus ?case by(auto simp add: m_sign_def less_eq_sign_def)
+next
+  case 2 thus ?case by(auto simp add: m_sign_def less_eq_sign_def less_sign_def)
+qed
+
+thm AI_Some_measure
+
+end
diff --git a/Short_Theory_13_15.thy b/Short_Theory_13_15.thy
new file mode 100644
index 0000000..217ccf1
--- /dev/null
+++ b/Short_Theory_13_15.thy
@@ -0,0 +1,263 @@
+theory Short_Theory_13_15
+  imports "HOL-IMP.Abs_Int1"
+begin
+
+datatype sign' = Neg | Zero | Pos
+
+type_synonym sign = "sign' set"
+
+lemma sign_ext: "UNIV = {Neg, Zero, Pos}"
+proof auto
+  fix x
+  show "\<lbrakk>x \<noteq> Neg; x \<noteq> Zero\<rbrakk> \<Longrightarrow> x = Pos"
+  proof (cases x, auto)
+  qed
+qed
+
+lemma card_sign' [simp]: "card (UNIV :: sign) = 3" by (auto simp: sign_ext)
+
+lemma finite_sign' [simp, intro!]: "finite (UNIV :: sign' set)" by (auto simp: sign_ext)
+
+lemma finite_sign [simp, intro!]: "finite (UNIV :: sign set)" by (simp add: Finite_Set.finite_set)
+
+text\<open>Instantiation of class \<^class>\<open>order\<close> with type \<^typ>\<open>sign\<close>:\<close>
+
+text\<open>Instantiation of class \<^class>\<open>semilattice_sup_top\<close> with type \<^typ>\<open>sign\<close>:\<close>
+
+instantiation set :: (type) semilattice_sup_top
+begin
+instance ..
+end
+
+text\<open>Now we define the functions used for instantiating the abstract
+interpretation locales. Note that the Isabelle terminology is
+\emph{interpretation}, not \emph{instantiation} of locales, but we use
+instantiation to avoid confusion with abstract interpretation.\<close>
+
+fun \<gamma>_sign' :: "sign' \<Rightarrow> val set" where
+  "\<gamma>_sign' Neg = {i. i < 0}" |
+  "\<gamma>_sign' Zero  = {0}" |
+  "\<gamma>_sign' Pos  = {i. 0 < i}"
+
+fun \<gamma>_sign :: "sign \<Rightarrow> val set" where
+  "\<gamma>_sign S = {i. \<exists>s\<in>S. i \<in> \<gamma>_sign' s}"
+
+fun num_sign :: "val \<Rightarrow> sign" where
+"num_sign i = (if i < 0 then {Neg} else if 0 < i then {Pos} else {Zero})"
+
+fun plus_sign' :: "sign' \<Rightarrow> sign' \<Rightarrow> sign" where
+  "plus_sign' Neg Pos = UNIV" |
+  "plus_sign' Pos Neg = UNIV" |
+  "plus_sign' Zero s = {s}" |
+  "plus_sign' s _ = {s}"
+  
+fun plus_sign :: "sign \<Rightarrow> sign \<Rightarrow> sign" where
+  "plus_sign S1 S2 = {s. \<exists>s1\<in>S1. \<exists>s2\<in>S2. s \<in> plus_sign' s1 s2}"
+
+text\<open>First we instantiate the abstract value interface and prove that the
+functions on type \<^typ>\<open>sign\<close> have all the necessary properties:\<close>
+
+lemma val_tricho_0:
+  fixes x :: val
+  obtains (BNeg) "x < 0" | (BZero) "x = 0" | (BPos) "x > 0"
+  by (rule linorder_cases)
+
+lemma \<gamma>_sign_top [simp]: "\<gamma>_sign UNIV = UNIV"
+proof auto
+  fix x :: val
+  show "\<exists>s. x \<in> \<gamma>_sign' s"
+  proof (cases rule: val_tricho_0 [of x])
+    case BNeg
+    then have "x \<in> \<gamma>_sign' Neg" by auto
+    then show ?thesis by blast
+  next
+    case BZero
+    then have "x \<in> \<gamma>_sign' Zero" by auto
+    then show ?thesis by blast
+  next
+    case BPos
+    then have "x \<in> \<gamma>_sign' Pos" by auto
+    then show ?thesis by blast
+  qed
+qed
+
+lemma Neg_\<gamma>_sign [dest]: "\<lbrakk>x < 0; x \<in> \<gamma>_sign S\<rbrakk> \<Longrightarrow> Neg \<in> S"
+proof auto
+  fix s
+  assume assm: "s \<in> S" "x < 0" "x \<in> \<gamma>_sign' s"
+  from assm(2, 3) have "s = Neg" by (cases s) auto
+  with assm(1) show "Neg \<in> S" by simp
+qed
+
+lemma Zero_\<gamma>_sign [dest]: "\<lbrakk>x = 0; x \<in> \<gamma>_sign S\<rbrakk> \<Longrightarrow> Zero \<in> S"
+proof auto
+  fix s
+  assume assm: "s \<in> S" "0 \<in> \<gamma>_sign' s"
+  from assm(2) have "s = Zero" by (cases s) auto
+  with assm(1) show "Zero \<in> S" by simp
+qed
+
+lemma Pos_\<gamma>_sign [dest]: "\<lbrakk>0 < x; x \<in> \<gamma>_sign S\<rbrakk> \<Longrightarrow> Pos \<in> S"
+proof auto
+  fix s
+  assume assm: "s \<in> S" "0 < x" "x \<in> \<gamma>_sign' s"
+  from assm(2, 3) have "s = Pos" by (cases s) auto
+  with assm(1) show "Pos \<in> S" by simp
+qed
+
+global_interpretation Val_semilattice
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+proof (standard, goal_cases)
+  case (1 a b)
+  then show ?case by auto
+next
+  case 2
+  then show ?case
+  proof auto
+    fix x :: val
+    show "\<exists>s. x \<in> \<gamma>_sign' s"
+    proof (cases rule: val_tricho_0 [of x])
+      case BNeg
+      then have "x \<in> \<gamma>_sign' Neg" by auto
+      then show ?thesis by blast
+    next
+      case BZero
+      then have "x \<in> \<gamma>_sign' Zero" by auto
+      then show ?thesis by blast
+    next
+      case BPos
+      then have "x \<in> \<gamma>_sign' Pos" by auto
+      then show ?thesis by blast
+    qed
+  qed
+next
+  case (3 i)
+  then show ?case by auto
+next
+  case (4 i1 a1 i2 a2)
+  show ?case
+  proof (cases rule: val_tricho_0 [of i1];
+      cases rule: val_tricho_0 [of i2];
+      cases rule: val_tricho_0 [of "i1 + i2"];
+      linarith?)
+    {
+      assume "i1 < 0"
+      with 4(1) have H1: "Neg \<in> a1" by (simp add: Neg_\<gamma>_sign)
+      {
+        assume "i2 < 0"
+        with 4(2) have H2: "Neg \<in> a2" by (simp add: Neg_\<gamma>_sign)
+        from H1 H2 have "Neg \<in> plus_sign a1 a2" by force
+        moreover assume "i1 + i2 < 0"
+        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
+      }
+      {
+        assume "i2 = 0"
+        with 4(2) have H2: "Zero \<in> a2" by (simp add: Zero_\<gamma>_sign)
+        from H1 H2 have "Neg \<in> plus_sign a1 a2" by force
+        moreover assume "i1 + i2 < 0"
+        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
+      }
+      {
+        assume "i2 > 0"
+        with 4(2) have H2: "Pos \<in> a2" by (simp add: Pos_\<gamma>_sign)
+        from H1 H2 have "plus_sign a1 a2 = UNIV" by force
+        then have "\<gamma>_sign (plus_sign a1 a2) = UNIV" using \<gamma>_sign_top by auto
+        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by auto
+        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
+        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
+      }
+    }
+    {
+      assume "i1 = 0"
+      with 4(1) have H1: "Zero \<in> a1" by (simp add: Zero_\<gamma>_sign)
+      {
+        assume "i2 < 0"
+        with 4(2) have H2: "Neg \<in> a2" by (simp add: Neg_\<gamma>_sign)
+        from H1 H2 have "Neg \<in> plus_sign a1 a2" by force
+        moreover assume "i1 + i2 < 0"
+        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
+      }
+      {
+        assume "i2 = 0"
+        with 4(2) have H2: "Zero \<in> a2" by (simp add: Zero_\<gamma>_sign)
+        from H1 H2 have "Zero \<in> plus_sign a1 a2" by force
+        moreover assume "i1 + i2 = 0"
+        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
+      }
+      {
+        assume "i2 > 0"
+        with 4(2) have H2: "Pos \<in> a2" by (simp add: Pos_\<gamma>_sign)
+        from H1 H2 have "Pos \<in> plus_sign a1 a2" by force
+        moreover assume "0 < i1 + i2"
+        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
+      }
+    }
+    {
+      assume "0 < i1"
+      with 4(1) have H1: "Pos \<in> a1" by (simp add: Pos_\<gamma>_sign)
+      {
+        assume "i2 < 0"
+        with 4(2) have H2: "Neg \<in> a2" by (simp add: Neg_\<gamma>_sign)
+        from H1 H2 have "plus_sign a1 a2 = UNIV" by force
+        then have "\<gamma>_sign (plus_sign a1 a2) = UNIV" using \<gamma>_sign_top by auto
+        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by auto
+        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
+        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
+      }
+      {
+        assume "i2 = 0"
+        with 4(2) have H2: "Zero \<in> a2" by (simp add: Zero_\<gamma>_sign)
+        from H1 H2 have "Pos \<in> plus_sign a1 a2" by force
+        moreover assume "0 < i1 + i2"
+        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
+      }
+      {
+        assume "0 < i2"
+        with 4(2) have H2: "Pos \<in> a2" by (simp add: Pos_\<gamma>_sign)
+        from H1 H2 have "Pos \<in> plus_sign a1 a2" by force
+        moreover assume "0 < i1 + i2"
+        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
+      }
+    }
+  qed
+qed
+
+text\<open>In case 4 we needed to refer to particular variables.
+Writing (i x y z) fixes the names of the variables in case i to be x, y and z
+in the left-to-right order in which the variables occur in the subgoal.
+Underscores are anonymous placeholders for variable names we don't care to fix.\<close>
+
+text\<open>Instantiating the abstract interpretation locale requires no more
+proofs (they happened in the instatiation above) but delivers the
+instantiated abstract interpreter which we call \<open>AI_parity\<close>:\<close>
+
+global_interpretation Abs_Int
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+defines aval_sign = aval' and step_sign = step' and AI_sign = AI
+  ..
+
+global_interpretation Abs_Int_mono
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+proof (standard, goal_cases)
+  case (1 a1 b1 a2 b2) thus ?case
+    by(induct b1 b2 rule: plus_sign.induct) auto
+qed
+
+definition m_sign :: "sign \<Rightarrow> nat" where
+"m_sign x = 3 - card x"
+
+global_interpretation Abs_Int_measure
+where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
+and m = m_sign and h = "3"
+proof (standard, goal_cases)
+  case (1 x) thus ?case by(auto simp add: m_sign_def)
+next
+  case (2 x y)
+  have "y \<subseteq> UNIV" by auto
+  then show ?case unfolding m_sign_def
+    by (metis "2" card_sign' diff_less_mono2 finite_sign' finite_subset less_le_trans psubset_card_mono)
+qed
+
+thm AI_Some_measure
+
+end
diff --git a/Short_Theory_13_2.thy b/Short_Theory_13_2.thy
new file mode 100644
index 0000000..4367758
--- /dev/null
+++ b/Short_Theory_13_2.thy
@@ -0,0 +1,259 @@
+theory Short_Theory_13_2
+  imports "HOL-IMP.BExp"
+begin
+
+datatype
+  com = SKIP 
+      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
+      | Or     com com          ("_/ OR _" [60, 61] 61)
+      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+
+text \<open>acom is the type of annotated commands (wrt. a type of annotation)\<close>
+datatype 'a acom =
+  SKIP 'a                           ("SKIP {_}" 61) |
+  Assign vname aexp 'a              ("(_ ::= _/ {_})" [1000, 61, 0] 61) |
+  Seq "('a acom)" "('a acom)"       ("_;;//_"  [60, 61] 60) |
+  If bexp 'a "'a acom" 'a "'a acom" 'a
+    ("(IF _/ THEN ({_}/ _)/ ELSE ({_}/ _)//{_})"  [0, 0, 0, 61, 0, 0] 61) |
+  Or "'a acom" "'a acom" 'a
+    ("_ OR// _//{_}" [60, 61, 0] 60) |
+  While 'a bexp 'a "'a acom" 'a
+    ("({_}//WHILE _//DO ({_}//_)//{_})"  [0, 0, 0, 61, 0] 61)
+
+notation com.SKIP ("SKIP")
+
+text \<open>strip maps acoms back to the original commands\<close>
+text_raw\<open>\snip{stripdef}{1}{1}{%\<close>
+fun strip :: "'a acom \<Rightarrow> com" where
+"strip (SKIP {P}) = SKIP" |
+"strip (x ::= e {P}) = x ::= e" |
+"strip (C\<^sub>1;;C\<^sub>2) = strip C\<^sub>1;; strip C\<^sub>2" |
+"strip (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {P}) =
+  IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2" |
+"strip (C\<^sub>1 OR C\<^sub>2 {P}) = strip C\<^sub>1 OR strip C\<^sub>2" |
+"strip ({I} WHILE b DO {P} C {Q}) = WHILE b DO strip C"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>asize counts the number of annotations that a com admits\<close>
+text_raw\<open>\snip{asizedef}{1}{1}{%\<close>
+fun asize :: "com \<Rightarrow> nat" where
+"asize SKIP = 1" |
+"asize (x ::= e) = 1" |
+"asize (C\<^sub>1;;C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2" |
+"asize (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 3" |
+"asize (C\<^sub>1 OR C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 1" |
+"asize (WHILE b DO C) = asize C + 3"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>shift eats the first n elements of a sequence\<close>
+text_raw\<open>\snip{annotatedef}{1}{1}{%\<close>
+definition shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
+"shift f n = (\<lambda>p. f(p+n))"
+
+text \<open>Defined in terms of shift, annotate annotates a command c with a sequence of annotations\<close>
+fun annotate :: "(nat \<Rightarrow> 'a) \<Rightarrow> com \<Rightarrow> 'a acom" where
+"annotate f SKIP = SKIP {f 0}" |
+"annotate f (x ::= e) = x ::= e {f 0}" |
+"annotate f (c\<^sub>1;;c\<^sub>2) = annotate f c\<^sub>1;; annotate (shift f (asize c\<^sub>1)) c\<^sub>2" |
+"annotate f (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
+  IF b THEN {f 0} annotate (shift f 1) c\<^sub>1
+  ELSE {f(asize c\<^sub>1 + 1)} annotate (shift f (asize c\<^sub>1 + 2)) c\<^sub>2
+  {f(asize c\<^sub>1 + asize c\<^sub>2 + 2)}" |
+"annotate f (c\<^sub>1 OR c\<^sub>2) =
+  annotate f c\<^sub>1 OR annotate (shift f (asize c\<^sub>1)) c\<^sub>2 {f (asize c\<^sub>1 + asize c\<^sub>2)}" |
+"annotate f (WHILE b DO c) =
+  {f 0} WHILE b DO {f 1} annotate (shift f 2) c {f(asize c + 2)}"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>annos collects a command's annotations into a list\<close>
+text_raw\<open>\snip{annosdef}{1}{1}{%\<close>
+fun annos :: "'a acom \<Rightarrow> 'a list" where
+"annos (SKIP {P}) = [P]" |
+"annos (x ::= e {P}) = [P]" |
+"annos (C\<^sub>1;;C\<^sub>2) = annos C\<^sub>1 @ annos C\<^sub>2" |
+"annos (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
+  P\<^sub>1 # annos C\<^sub>1 @  P\<^sub>2 # annos C\<^sub>2 @ [Q]" |
+"annos (C\<^sub>1 OR C\<^sub>2 {P}) = annos C\<^sub>1 @ annos C\<^sub>2 @ [P]" |
+"annos ({I} WHILE b DO {P} C {Q}) = I # P # annos C @ [Q]"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>anno retrives the pth annotation of a command, by first collecting its annotations then
+indexing into the pth list element\<close>
+definition anno :: "'a acom \<Rightarrow> nat \<Rightarrow> 'a" where
+"anno C p = annos C ! p"
+
+text \<open>post retrieves the last annotation of a command, by first collecting its annotations\<close>
+definition post :: "'a acom \<Rightarrow>'a" where
+"post C = last(annos C)"
+
+text \<open>map_acom maps the annotations of an acom\<close>
+text_raw\<open>\snip{mapacomdef}{1}{2}{%\<close>
+fun map_acom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a acom \<Rightarrow> 'b acom" where
+"map_acom f (SKIP {P}) = SKIP {f P}" |
+"map_acom f (x ::= e {P}) = x ::= e {f P}" |
+"map_acom f (C\<^sub>1;;C\<^sub>2) = map_acom f C\<^sub>1;; map_acom f C\<^sub>2" |
+"map_acom f (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
+  IF b THEN {f P\<^sub>1} map_acom f C\<^sub>1 ELSE {f P\<^sub>2} map_acom f C\<^sub>2
+  {f Q}" |
+"map_acom f (C\<^sub>1 OR C\<^sub>2 {P}) = map_acom f C\<^sub>1 OR map_acom f C\<^sub>2 {f P}" |
+"map_acom f ({I} WHILE b DO {P} C {Q}) =
+  {f I} WHILE b DO {f P} map_acom f C {f Q}"
+text_raw\<open>}%endsnip\<close>
+
+text \<open>the list of annotations for any command is always nonempty\<close>
+lemma annos_ne: "annos C \<noteq> []"
+by(induction C) auto
+
+text \<open>stripping a command that has been annotated recovers it\<close>
+lemma strip_annotate[simp]: "strip(annotate f c) = c"
+by(induction c arbitrary: f) auto
+
+text \<open>the list of annotations of a com, once annotated, is as large as the number of annotations it admits\<close>
+lemma length_annos_annotate[simp]: "length (annos (annotate f c)) = asize c"
+by(induction c arbitrary: f) auto
+
+text \<open>the size of the list of annotations of a command is as large as the number of annotations its underlying com admits\<close>
+lemma size_annos: "size(annos C) = asize(strip C)"
+by(induction C)(auto)
+
+text \<open>if two acom share the same com, then they have the same number of annotations\<close>
+lemma size_annos_same: "strip C1 = strip C2 \<Longrightarrow> size(annos C1) = size(annos C2)"
+apply(induct C2 arbitrary: C1)
+apply(case_tac C1, simp_all)+
+done
+
+lemmas size_annos_same2 = eqTrueI[OF size_annos_same]
+
+text \<open>dually, the pth annotation is the pth element of the annotating sequence\<close>
+lemma anno_annotate[simp]: "p < asize c \<Longrightarrow> anno (annotate f c) p = f p"
+proof (induction c arbitrary: f p)
+  case SKIP
+  then show ?case by (auto simp: anno_def)
+next
+  case (Assign x1 x2)
+  then show ?case by (auto simp: anno_def)
+next
+  case (Seq c1 c2)
+  then show ?case by (auto simp: anno_def nth_append shift_def)
+next
+  case (If x1 c1 c2)
+  then show ?case
+    by (auto simp: anno_def nth_append nth_Cons shift_def split: nat.split,
+        metis add_Suc_right add_diff_inverse add.commute,
+        rule_tac f=f in arg_cong,
+        arith)
+next
+  case (Or c1 c2)
+  then show ?case
+    by (auto simp: anno_def nth_append shift_def,
+        rule_tac f=f in arg_cong,
+        arith)
+next
+case (While x1 c)
+  then show ?case
+    by (auto simp: anno_def nth_append nth_Cons shift_def
+        split: nat.split, rule_tac f=f in arg_cong,
+        arith)
+qed
+
+text \<open>two acoms are equal iff they have the same underlying command and same list of annotations\<close>
+text \<open>Proof is by inductive definiton of acom, and list lemmas / annos lemmas\<close>
+lemma eq_acom_iff_strip_annos:
+  "C1 = C2 \<longleftrightarrow> strip C1 = strip C2 \<and> annos C1 = annos C2"
+apply(induction C1 arbitrary: C2)
+apply(case_tac C2, auto simp: size_annos_same2)+
+done
+
+text \<open>two acoms are equal iff they have the same underlying command and same sublist of annotations\<close>
+lemma eq_acom_iff_strip_anno:
+  "C1=C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p = anno C2 p)"
+by(auto simp add: eq_acom_iff_strip_annos anno_def
+     list_eq_iff_nth_eq size_annos_same2)
+
+text \<open>the last annotation after mapping through f is exactly the last annotation, then mapping it by f\<close>
+lemma post_map_acom[simp]: "post(map_acom f C) = f(post C)"
+by (induction C) (auto simp: post_def last_append annos_ne)
+
+text \<open>the underlying command is unchanged by map_acom\<close>
+lemma strip_map_acom[simp]: "strip (map_acom f C) = strip C"
+by (induction C) auto
+
+text \<open>the pth annotation after mapping through f is exactly the pth annotation, then mapping it by f\<close>
+lemma anno_map_acom: "p < size(annos C) \<Longrightarrow> anno (map_acom f C) p = f(anno C p)"
+apply(induction C arbitrary: p)
+apply(auto simp: anno_def nth_append nth_Cons' size_annos)
+done
+
+text \<open>inversion lemma for strip C\<close>
+
+lemma strip_eq_SKIP:
+  "strip C = SKIP \<longleftrightarrow> (\<exists>P. C = SKIP {P})"
+by (cases C) simp_all
+
+lemma strip_eq_Assign:
+  "strip C = x::=e \<longleftrightarrow> (\<exists>P. C = x::=e {P})"
+by (cases C) simp_all
+
+lemma strip_eq_Seq:
+  "strip C = c1;;c2 \<longleftrightarrow> (\<exists>C1 C2. C = C1;;C2 & strip C1 = c1 & strip C2 = c2)"
+by (cases C) simp_all
+
+lemma strip_eq_If:
+  "strip C = IF b THEN c1 ELSE c2 \<longleftrightarrow>
+  (\<exists>P1 P2 C1 C2 Q. C = IF b THEN {P1} C1 ELSE {P2} C2 {Q} & strip C1 = c1 & strip C2 = c2)"
+by (cases C) simp_all
+
+lemma strip_eq_Or:
+  "strip C = c1 OR c2 \<longleftrightarrow>
+  (\<exists>C1 C2 P. C = C1 OR C2 {P} & strip C1 = c1 & strip C2 = c2)"
+by (cases C) simp_all
+
+lemma strip_eq_While:
+  "strip C = WHILE b DO c1 \<longleftrightarrow>
+  (\<exists>I P C1 Q. C = {I} WHILE b DO {P} C1 {Q} & strip C1 = c1)"
+by (cases C) simp_all
+
+text \<open>shifting a constant sequence does nothing\<close>
+lemma [simp]: "shift (\<lambda>p. a) n = (\<lambda>p. a)"
+by(simp add:shift_def)
+
+text \<open>the set of all members of an acom created by annotate with a constant sequence on that annotation is a singleton\<close>
+lemma set_annos_anno[simp]: "set (annos (annotate (\<lambda>p. a) c)) = {a}"
+  by(induction c) simp_all
+
+text \<open>the last annotation of an acom is in the set of list of annotations of that acom\<close>
+lemma post_in_annos: "post C \<in> set(annos C)"
+by(auto simp: post_def annos_ne)
+
+text \<open>the last annotation of C is the last element of the list of annotations generated from C.\<close>
+lemma post_anno_asize: "post C = anno C (size(annos C) - 1)"
+  by(simp add: post_def last_conv_nth[OF annos_ne] anno_def)
+
+notation
+  sup (infixl "\<squnion>" 65) and
+  inf (infixl "\<sqinter>" 70) and
+  bot ("\<bottom>") and
+  top ("\<top>")
+
+context
+  fixes f :: "vname \<Rightarrow> aexp \<Rightarrow> 'a \<Rightarrow> 'a::sup"
+  fixes g :: "bexp \<Rightarrow> 'a \<Rightarrow> 'a"
+begin
+fun Step :: "'a \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
+"Step S (SKIP {Q}) = (SKIP {S})" |
+"Step S (x ::= e {Q}) =
+  x ::= e {f x e S}" |
+"Step S (C1;; C2) = Step S C1;; Step (post C1) C2" |
+"Step S (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) =
+  IF b THEN {g b S} Step P1 C1 ELSE {g (Not b) S} Step P2 C2
+  {post C1 \<squnion> post C2}" |
+"Step S (C1 OR C2 {P}) =
+  Step S C1 OR Step S C2
+  {post C1 \<squnion> post C2}" |
+"Step S ({I} WHILE b DO {P} C {Q}) =
+  {S \<squnion> post C} WHILE b DO {g b I} Step P C {g (Not b) I}"
+end
+
+end
\ No newline at end of file
diff --git a/Short_Theory_7_10.thy b/Short_Theory_7_10.thy
new file mode 100644
index 0000000..7e91c66
--- /dev/null
+++ b/Short_Theory_7_10.thy
@@ -0,0 +1,227 @@
+theory Short_Theory_7_10
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype com =
+  SKIP
+  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+  | THROW
+  | Try    com  com         ("(TRY _/ CATCH _)" [60, 61] 61)
+
+inductive
+  big_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
+  where
+    Skip: "(SKIP, s) \<Rightarrow> (SKIP, s)" |
+    Assign: "(x ::= a, s) \<Rightarrow> (SKIP, s(x := aval a s))" |
+    SeqSkip: "\<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> (SKIP, s\<^sub>2); (c\<^sub>2, s\<^sub>2) \<Rightarrow> (x, s\<^sub>3)\<rbrakk> \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> (x, s\<^sub>3)" |
+    SeqThrow: "\<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> (THROW, s\<^sub>2)\<rbrakk> \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> (THROW, s\<^sub>2)" |
+    IfTrue: "\<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> (x, t)\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> (x, t)" |
+    IfFalse: "\<lbrakk>\<not>bval b s;  (c\<^sub>2, s) \<Rightarrow> (x, t)\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> (x, t)" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> (SKIP, s)" |
+    WhileTrueSkip: "\<lbrakk>bval b s\<^sub>1; (c, s\<^sub>1) \<Rightarrow> (SKIP, s\<^sub>2); (WHILE b DO c, s\<^sub>2) \<Rightarrow> (x, s\<^sub>3)\<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> (x, s\<^sub>3)" |
+    WhileTrueThrow: "\<lbrakk>bval b s\<^sub>1; (c, s\<^sub>1) \<Rightarrow> (THROW, s\<^sub>2)\<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> (THROW, s\<^sub>2)" |
+    Throw: "(THROW, s) \<Rightarrow> (THROW, s)" |
+    TrySkip: "(c\<^sub>1, s) \<Rightarrow> (SKIP, t) \<Longrightarrow> (TRY c\<^sub>1 CATCH c\<^sub>2, s) \<Rightarrow> (SKIP, t)" |
+    TryThrow: "\<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> (THROW, s\<^sub>2); (c\<^sub>2, s\<^sub>2) \<Rightarrow> (x, s\<^sub>3)\<rbrakk> \<Longrightarrow> (TRY c\<^sub>1 CATCH c\<^sub>2, s\<^sub>1) \<Rightarrow> (x, s\<^sub>3)"
+
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE [elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> (x, t); \<lbrakk>x = SKIP; t = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE [elim!]: "\<lbrakk>
+  (y ::= a, s) \<Rightarrow> (x, t);
+  \<lbrakk>x = SKIP; t = s(y := aval a s)\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE [elim!]: "\<lbrakk>
+  (c\<^sub>1;; c\<^sub>2, s) \<Rightarrow> (x, t);
+  \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s) \<Rightarrow> (SKIP, s\<^sub>2); (c\<^sub>2, s\<^sub>2) \<Rightarrow> (x, t)\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>(c\<^sub>1, s) \<Rightarrow> (THROW, t); x = THROW\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE [elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> (x, t);
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> (x, t)\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> (x, t)\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE [elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> (x, t);
+  \<lbrakk>\<not> bval b t; x = SKIP; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> (SKIP, s\<^sub>2);
+  (WHILE b DO c, s\<^sub>2) \<Rightarrow> (x, t)\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>bval b s; (c, s) \<Rightarrow> (THROW, t); x = THROW\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_Throw [elim!]: "\<lbrakk>(THROW, s) \<Rightarrow> (x, t); \<lbrakk>x = THROW; t = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_Try [elim!]: "\<lbrakk>
+  (TRY c\<^sub>1 CATCH c\<^sub>2, s) \<Rightarrow> (x, t);
+  \<lbrakk>(c\<^sub>1, s) \<Rightarrow> (SKIP, t); x = SKIP\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s) \<Rightarrow> (THROW, s\<^sub>2); (c\<^sub>2, s\<^sub>2) \<Rightarrow> (x, t)\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+inductive small_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
+  where
+    Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |
+    SeqSkip: "(SKIP;; c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    SeqThrow: "(THROW;; c\<^sub>2, s) \<rightarrow> (THROW, s)" |
+    SeqNext: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> (c\<^sub>1';; c\<^sub>2, s')" |
+    IfTrue: "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
+    IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |
+    TrySkip: "(TRY SKIP CATCH c\<^sub>2, s) \<rightarrow> (SKIP, s)" |
+    TryThrow: "(TRY THROW CATCH c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    TryNext: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (TRY c\<^sub>1 CATCH c\<^sub>2, s) \<rightarrow> (TRY c\<^sub>1' CATCH c\<^sub>2, s')"
+
+abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
+  where "x \<rightarrow>* y == star small_step x y"
+
+lemmas small_step_induct = small_step.induct[split_format(complete)]
+declare small_step.intros[simp,intro]
+
+lemma SS_SkipE [elim!]: "(SKIP, s) \<rightarrow> ct \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_AssignE [elim!]: "\<lbrakk>(x ::= a, s) \<rightarrow> ct; ct = (SKIP, s(x := aval a s)) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_SeqE [elim]: "\<lbrakk>
+  (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c\<^sub>2, s); c\<^sub>1 = SKIP\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>ct = (THROW, s); c\<^sub>1 = THROW\<rbrakk> \<Longrightarrow> P;
+  \<And>c\<^sub>1' s'. \<lbrakk>ct = (c\<^sub>1';; c\<^sub>2, s'); (c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_IfE [elim!]: "\<lbrakk>
+  (IF b THEN c1 ELSE c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c1, s); bval b s\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>ct = (c2, s); \<not> bval b s\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_WhileE [elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<rightarrow> ct;
+  ct = (IF b THEN c;; WHILE b DO c ELSE SKIP, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_ThrowE [elim!]: "(THROW, s) \<rightarrow> ct \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_TryE [elim]: "\<lbrakk>
+  (TRY c\<^sub>1 CATCH c\<^sub>2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (SKIP, s); c\<^sub>1 = SKIP\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>ct = (c\<^sub>2, s); c\<^sub>1 = THROW\<rbrakk> \<Longrightarrow> P;
+  \<And>c\<^sub>1' s'. \<lbrakk>ct = (TRY c\<^sub>1' CATCH c\<^sub>2, s'); (c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+
+lemma star_seq2: "(c1, s) \<rightarrow>* (c1', s') \<Longrightarrow> (c1;; c2, s) \<rightarrow>* (c1';;c2, s')"
+  by (induct rule: star_induct) (simp, blast intro: star.step)
+
+lemma seq_comp_skip: "\<lbrakk>(c1, s1) \<rightarrow>* (SKIP, s2); (c2, s2) \<rightarrow>* (x, s3)\<rbrakk>
+  \<Longrightarrow> (c1;; c2, s1) \<rightarrow>* (x, s3)"
+  by (blast intro: star.step star_seq2 star_trans)
+
+lemma seq_comp_throw: "\<lbrakk>(c1, s1) \<rightarrow>* (THROW, s2)\<rbrakk>
+  \<Longrightarrow> (c1;; c2, s1) \<rightarrow>* (THROW, s2)"
+  by (blast intro: star.step star_seq2 star_trans)
+
+lemma star_try2: "(c1, s) \<rightarrow>* (c1', s') \<Longrightarrow> (TRY c1 CATCH c2, s) \<rightarrow>* (TRY c1' CATCH c2, s')"
+  by (induct rule: star_induct) (simp, blast intro: star.step)
+
+lemma try_comp_skip: "\<lbrakk>(c1, s1) \<rightarrow>* (SKIP, s2)\<rbrakk>
+  \<Longrightarrow> (TRY c1 CATCH c2, s1) \<rightarrow>* (SKIP, s2)"
+  by (blast intro: star.step star_try2 star_trans)
+
+lemma try_comp_throw: "\<lbrakk>(c1, s1) \<rightarrow>* (THROW, s2); (c2, s2) \<rightarrow>* (x, s3)\<rbrakk>
+  \<Longrightarrow> (TRY c1 CATCH c2, s1) \<rightarrow>* (x, s3)"
+  by (blast intro: star.step star_try2 star_trans)
+
+lemma big_to_small: "cs \<Rightarrow> (x, t) \<Longrightarrow> cs \<rightarrow>* (x, t)"
+  by (induct cs "(x, t)" arbitrary: x t rule: big_step.induct)
+    (blast intro: seq_comp_skip seq_comp_throw try_comp_skip try_comp_throw star.step)+
+
+lemma big_final: "cs \<Rightarrow> (x, t) \<Longrightarrow> x = SKIP \<or> x = THROW"
+  by (induct cs "(x, t)" arbitrary: x t rule: big_step.induct) blast+
+
+lemma small1_big_continue: "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> (x, t) \<Longrightarrow> cs \<Rightarrow> (x, t)"
+  by (induct arbitrary: x t rule: small_step.induct) auto
+
+lemma small_to_big_skip: "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> (SKIP, t)"
+  by (induct cs "(SKIP,t)" rule: star.induct) (auto intro: small1_big_continue)
+
+lemma small_to_big_throw: "cs \<rightarrow>* (THROW, t) \<Longrightarrow> cs \<Rightarrow> (THROW, t)"
+  by (induct cs "(THROW, t)" rule: star.induct) (auto intro: small1_big_continue)
+
+theorem big_iff_small_skip: "cs \<Rightarrow> (SKIP, t) = cs \<rightarrow>* (SKIP,t)"
+  by (blast intro: big_to_small small_to_big_skip)
+
+theorem big_iff_small_throw: "cs \<Rightarrow> (THROW, t) = cs \<rightarrow>* (THROW,t)"
+  by (blast intro: big_to_small small_to_big_throw)
+
+definition "final cs \<longleftrightarrow> \<not>(\<exists>cs'. cs \<rightarrow> cs')"
+
+lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP \<or> c = THROW"
+proof -
+  assume "final (c, s)"
+  then have "\<not>(\<exists>c' s'. (c, s) \<rightarrow> (c', s'))" using final_def by simp
+  then show "c = SKIP \<or> c = THROW"
+  proof (induct c)
+    case (Seq c1 c2)
+    show ?case
+    proof (cases "\<exists>c' s'. (c1, s) \<rightarrow> (c', s')")
+      case True
+      with Seq(3) show ?thesis by blast
+    next
+      case False
+      with Seq(1) consider "c1 = SKIP" | "c1 = THROW" by blast
+      then show ?thesis using Seq(3) by cases blast+
+    qed
+  next
+    case (Try c1 c2)
+    then show ?case
+    proof (cases "\<exists>c' s'. (c1, s) \<rightarrow> (c', s')")
+      case True
+      with Try(3) show ?thesis by blast
+    next
+      case False
+      with Try(1) consider "c1 = SKIP" | "c1 = THROW" by blast
+      then show ?thesis using Try(3) by cases blast+
+    qed
+  qed blast+
+qed
+
+lemma final_iff_SKIP_or_THROW: "final (c,s) = (c = SKIP \<or> c = THROW)"
+  by (metis SS_SkipE SS_ThrowE finalD final_def)
+
+lemma big_iff_small_termination: "(\<exists> cs'. cs \<Rightarrow> cs') \<longleftrightarrow> (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
+proof
+  assume "\<exists>cs'. cs \<Rightarrow> cs'"
+  then obtain cs' where "cs \<Rightarrow> cs'" by blast
+  moreover from surj_pair [of cs'] obtain x t where "cs' = (x, t)" by blast
+  ultimately have "cs \<Rightarrow> (x, t)" by blast
+  then have "cs \<rightarrow>* (x, t)" and "x = SKIP \<or> x = THROW" using big_to_small big_final by simp+
+  with final_iff_SKIP_or_THROW show "\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs'" by auto
+next
+  assume "\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs'"
+  then obtain cs' where "cs \<rightarrow>* cs' \<and> final cs'" by blast
+  moreover from surj_pair [of cs'] obtain x t where "cs' = (x, t)" by blast
+  ultimately have H1: "cs \<rightarrow>* (x, t)" and H2: "final (x, t)" by blast+
+  from H2 consider "x = SKIP" | "x = THROW" using final_iff_SKIP_or_THROW by blast 
+  then have "cs \<Rightarrow> (x, t)"
+  proof cases
+    case 1
+    then show ?thesis using H1 small_to_big_skip by blast
+  next
+    case 2
+    then show ?thesis using H1 small_to_big_throw by blast
+  qed
+  then show "\<exists>cs'. cs \<Rightarrow> cs'" by blast
+qed
+
+
+end
\ No newline at end of file
diff --git a/Short_Theory_7_8.thy b/Short_Theory_7_8.thy
new file mode 100644
index 0000000..a945461
--- /dev/null
+++ b/Short_Theory_7_8.thy
@@ -0,0 +1,122 @@
+theory Short_Theory_7_8
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype
+  com = SKIP
+  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 60, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+  | Repeat com bexp         ("(REPEAT _/ UNTIL _)" [60, 0] 61)
+
+inductive
+  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
+  where
+    Skip: "(SKIP,s) \<Rightarrow> s" |
+    Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
+    Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    RepeatTrue: "\<lbrakk> bval b t; (c, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
+    RepeatFalse: "\<lbrakk> \<not>bval b s\<^sub>2; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE[elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE[elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_RepeatE[elim]: "\<lbrakk>
+  (REPEAT c UNTIL b, s) \<Rightarrow> t;
+  \<lbrakk>bval b t; (c, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>\<not> bval b s\<^sub>2; (c, s) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
+  by (induct arbitrary: u rule: big_step.induct) blast+
+
+inductive small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
+  where
+    Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |
+    Seq1: "(SKIP;; c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    Seq2: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> (c\<^sub>1';; c\<^sub>2, s')" |
+    IfTrue: "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
+    IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |
+    Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"
+
+abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
+  where "x \<rightarrow>* y == star small_step x y"
+
+lemmas small_step_induct = small_step.induct[split_format(complete)]
+declare small_step.intros[simp,intro]
+
+lemma SS_SkipE[elim!]: "(SKIP, s) \<rightarrow> ct \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<rightarrow> ct; ct = (SKIP, s(x := aval a s)) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_SeqE[elim]: "\<lbrakk>
+  (c1;; c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c2, s); c1 = SKIP\<rbrakk> \<Longrightarrow> P;
+  \<And>c\<^sub>1' s'. \<lbrakk>ct = (c\<^sub>1';; c2, s'); (c1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c1 ELSE c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c1, s); bval b s\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>ct = (c2, s); \<not> bval b s\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<rightarrow> ct;
+  ct = (IF b THEN c;; WHILE b DO c ELSE SKIP, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_RepeatE[elim]: "\<lbrakk>
+  (REPEAT c UNTIL b, s) \<rightarrow> ct;
+  ct = (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+
+lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
+  by (induct rule: star_induct) (simp, blast intro: star.step)
+
+lemma seq_comp: "\<lbrakk>(c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3)\<rbrakk>
+  \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
+  by (blast intro: star.step star_seq2 star_trans)
+
+lemma big_to_small: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
+  by (induction rule: big_step.induct) (blast intro: seq_comp star.step)+
+
+lemma small1_big_continue: "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct arbitrary: t rule: small_step.induct) auto
+
+lemma small_to_big: "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct cs "(SKIP,t)" rule: star.induct) (auto intro: small1_big_continue)
+
+theorem big_iff_small: "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
+  by (blast intro: big_to_small small_to_big)
+
+end
\ No newline at end of file
diff --git a/Short_Theory_7_9.thy b/Short_Theory_7_9.thy
new file mode 100644
index 0000000..525b169
--- /dev/null
+++ b/Short_Theory_7_9.thy
@@ -0,0 +1,118 @@
+theory Short_Theory_7_9
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype
+  com = SKIP 
+  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+  | Or     com  com         ("(_/ OR _)" [0, 61] 61)
+
+inductive
+  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
+  where
+    Skip: "(SKIP, s) \<Rightarrow> s" |
+    Assign: "(x ::= a, s) \<Rightarrow> s(x := aval a s)" |
+    Seq: "\<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    IfFalse: "\<lbrakk>\<not>bval b s;  (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk>bval b s\<^sub>1; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    OrLeft: "(c\<^sub>1,s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t" |
+    OrRight: "(c\<^sub>2,s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t"
+
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE [elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE [elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE [elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE [elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE [elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_Or [elim!]: "\<lbrakk>(c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t; (c\<^sub>1, s) \<Rightarrow> t \<Longrightarrow> P; (c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+abbreviation equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
+  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
+
+lemma "(c\<^sub>1 OR c\<^sub>2) \<sim> (c\<^sub>2 OR c\<^sub>1)" by blast
+
+inductive small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
+  where
+    Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |
+    Seq1: "(SKIP;; c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    Seq2: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> (c\<^sub>1';; c\<^sub>2, s')" |
+    IfTrue: "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
+    IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |
+    OrLeft: "(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
+    OrRight: "(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)"
+
+abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
+  where "x \<rightarrow>* y == star small_step x y"
+
+lemmas small_step_induct = small_step.induct[split_format(complete)]
+declare small_step.intros[simp,intro]
+
+lemma SS_SkipE [elim!]: "(SKIP, s) \<rightarrow> ct \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_AssignE [elim!]: "\<lbrakk>(x ::= a, s) \<rightarrow> ct; ct = (SKIP, s(x := aval a s)) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_SeqE [elim]: "\<lbrakk>
+  (c1;; c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c2, s); c1 = SKIP\<rbrakk> \<Longrightarrow> P;
+  \<And>c\<^sub>1' s'. \<lbrakk>ct = (c\<^sub>1';; c2, s'); (c1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_IfE [elim!]: "\<lbrakk>
+  (IF b THEN c1 ELSE c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c1, s); bval b s\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>ct = (c2, s); \<not> bval b s\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_WhileE [elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<rightarrow> ct;
+  ct = (IF b THEN c;; WHILE b DO c ELSE SKIP, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_OrE [elim!]: "\<lbrakk>(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> ct; ct = (c\<^sub>1, s) \<Longrightarrow> P; ct = (c\<^sub>2, s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+
+lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
+  by (induct rule: star_induct) (simp, blast intro: star.step)
+
+lemma seq_comp: "\<lbrakk>(c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3)\<rbrakk>
+  \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
+  by (blast intro: star.step star_seq2 star_trans)
+
+lemma big_to_small: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
+  by (induction rule: big_step.induct) (blast intro: seq_comp star.step)+
+
+lemma small1_big_continue: "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct arbitrary: t rule: small_step.induct) auto
+
+lemma small_to_big: "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct cs "(SKIP,t)" rule: star.induct) (auto intro: small1_big_continue)
+
+theorem big_iff_small: "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
+  by (blast intro: big_to_small small_to_big)
+
+end
diff --git a/Short_Theory_8_1.thy b/Short_Theory_8_1.thy
new file mode 100644
index 0000000..048f827
--- /dev/null
+++ b/Short_Theory_8_1.thy
@@ -0,0 +1,872 @@
+theory Short_Theory_8_1
+  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
+begin
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+primrec (nonexhaustive) inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
+  "(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"
+
+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)
+
+lemma nth_inth: "i < length (x # xs) \<Longrightarrow> (x # xs) !! i = (x # xs) ! i"
+proof (induct xs arbitrary: i x)
+  case (Cons a xs)
+  then show ?case
+  proof (cases "i = 0")
+    case False
+    from Cons False have Hl: "i - 1 < length (a # xs)" by auto
+    from Cons(2) False have "(x # a # xs) !! int i = (a # xs) !! (int (i - 1))" using int_ops(6) by auto
+    also from Cons(1) Hl have "\<dots> = (a # xs) ! (i - 1)" by blast
+    also from Cons(2) False have "\<dots> = (x # a # xs) ! i" by simp
+    finally show ?thesis .
+  qed simp
+qed simp
+
+abbreviation (output)
+  "isize xs == int (length xs)"
+
+notation isize ("size")
+
+datatype instr = 
+  LOADI int | LOAD vname |
+  ADD |
+  STORE vname |
+  JMP int | JMPLESS int | JMPGE int
+
+type_synonym stack = "val list"
+type_synonym config = "int \<times> state \<times> stack"
+
+abbreviation "hd2 xs == hd (tl xs)"
+abbreviation "tl2 xs == tl (tl xs)"
+
+(* note: by using hd / tl functions rather than pattern matching, we limit
+  reliance on the structure of stk in the behavior of iexec, allowing us
+  to simplify preconditions on lemmas that don't rely on the structure of
+  the stack
+*)
+fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
+  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
+  "iexec (LOAD x) (i, s, stk) = (i + 1, s, s x # stk)" |
+  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
+  "iexec (STORE x) (i, s, stk) = (i + 1, s(x := 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)"
+
+(* an introduction rule that expects the LHS config parameters to already be known *)
+lemma exec1I [intro, code_pred_intro]:
+  "\<lbrakk>c' = iexec (P !! i) (i, s, stk);
+    0 \<le> i;
+    i < size P
+  \<rbrakk> \<Longrightarrow> P \<turnstile> (i, s, stk) \<rightarrow> c'"
+  by (simp add: exec1_def)
+code_pred exec1 by (simp add: exec1_def)
+
+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:"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: "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]:
+  "\<lbrakk>size P' \<le> i;
+    P \<turnstile> (i - size P', s, stk) \<rightarrow>* (j, s', stk');
+    i' = size P' + j
+  \<rbrakk> \<Longrightarrow> P' @ P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')"
+  by (drule exec_appendL [where P'=P']) simp
+
+lemma exec_append_trans[intro]:
+  "\<lbrakk>P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk');
+    size P \<le> i';
+    P' \<turnstile>  (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'');
+    j'' = size P + i''
+   \<rbrakk> \<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 "Compilation"
+
+fun acomp :: "aexp \<Rightarrow> instr list" where
+  "acomp (N n) = [LOADI n]" |
+  "acomp (V x) = [LOAD x]" |
+  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"
+
+lemma acomp_correct[intro]:
+  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size(acomp a), s, aval a s # stk)"
+  by (induction a arbitrary: stk) fastforce+
+
+(* f = True means that we intend to jump n spaces upon the expression evaluating to True, and
+  step to next instruction upon the expression evaluating to False
+  f = False means vice versa
+
+  Suppose f = True in bcomp (And b1 b2). Then we want b1 to jump to just past b2 on False,
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True. Thus we let cb1 = bcomp b1 False (size cb2)
+
+  suppose f = False in bcomp (And b1 b2). Then we want b1 to jump to (size cb2 + n) on False
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True.
+*)
+fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
+  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
+  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
+  "bcomp (And b1 b2) f n = (let
+    cb2 = bcomp b2 f n;
+    m = if f
+      then size cb2
+      else size cb2 + n;
+    cb1 = bcomp b1 False m in
+    cb1 @ cb2)" |
+  "bcomp (Less a1 a2) f n =
+    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"
+
+lemma bcomp_correct[intro]: "0 \<le> n \<Longrightarrow>
+  bcomp b f n \<turnstile>
+  (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
+proof (induct b arbitrary: f n)
+  case Not
+  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
+next
+  case (And b1 b2)
+  from And(1)
+    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
+    And(2) [of n f] And(3)
+  show ?case by fastforce
+qed fastforce+
+
+fun ccomp :: "com \<Rightarrow> instr list" where
+  "ccomp SKIP = []" |
+  "ccomp (x ::= a) = acomp a @ [STORE x]" |
+  "ccomp (c\<^sub>1;; c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
+  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
+      cc\<^sub>1 = ccomp c\<^sub>1;
+      cc\<^sub>2 = ccomp c\<^sub>2;
+      cb = bcomp b False (size cc\<^sub>1 + 1) in
+      cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
+  "ccomp (WHILE b DO c) = (let
+    cc = ccomp c;
+    cb = bcomp b False (size cc + 1) in
+    cb @ cc @ [JMP (-(size cb + size cc + 1))])"
+
+lemma ccomp_bigstep:
+  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
+proof (induct arbitrary: stk rule: big_step_induct)
+  case (Assign x a s)
+  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
+  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
+    using Seq(2) by fastforce
+  moreover
+  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
+    using Seq(4) by fastforce
+  ultimately show ?case by simp (blast intro: star_trans)
+next
+  case (WhileTrue b s1 c s2 s3)
+  let ?cc = "ccomp c"
+  let ?cb = "bcomp b False (size ?cc + 1)"
+  and ?cw = "ccomp (WHILE b DO c)"
+  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)"
+    using \<open>bval b s1\<close> by fastforce
+  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
+    using WhileTrue(3) by fastforce
+  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)"
+    by fastforce
+  moreover have "?cw \<turnstile> (0, s2, stk) \<rightarrow>* (size ?cw, s3, stk)" by (rule WhileTrue(5))
+  ultimately show ?case by(blast intro: star_trans)
+qed fastforce+
+
+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})"
+
+lemma isuccs_LOADI_correct: "{fst c' | c' i s stk. c' = iexec (LOADI i) (n, s, stk)} = isuccs (LOADI i) n"
+  by (auto simp add: isuccs_def)
+
+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. \<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,stk,s) \<rightarrow>^k (n',stk',s') = 
+  (\<exists>c. P \<turnstile> (n,stk,s) \<rightarrow> c \<and> P \<turnstile> c \<rightarrow>^(k - 1) (n',stk',s') \<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::int) \<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>
+
+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
+  let ?isuccs = "\<lambda>p P n i::int. 0 \<le> i \<and> i < size P \<and> p \<in> isuccs (P!!i) (n+i)"
+  have "p \<in> ?x \<union> ?xs" if assm: "p \<in> succs (x#xs) n" for p
+  proof -
+    from assm obtain i::int where isuccs: "?isuccs p (x#xs) n i"
+      unfolding succs_def by auto
+    show ?thesis
+    proof cases
+      assume "i = 0" with isuccs show ?thesis by simp
+    next
+      assume "i \<noteq> 0" 
+      with isuccs 
+      have "?isuccs p xs (1+n) (i - 1)" by auto
+      hence "p \<in> ?xs" unfolding succs_def by blast
+      thus ?thesis .. 
+    qed
+  qed
+  thus "succs (x#xs) n \<subseteq> ?x \<union> ?xs" ..
+
+  have "p \<in> succs (x#xs) n" if assm: "p \<in> ?x \<or> p \<in> ?xs" for p
+  proof -
+    from assm show ?thesis
+    proof
+      assume "p \<in> ?x" thus ?thesis by (fastforce simp: succs_def)
+    next
+      assume "p \<in> ?xs"
+      then obtain i where "?isuccs p xs (1+n) i"
+        unfolding succs_def by auto
+      hence "?isuccs p (x#xs) n (1+i)"
+        by (simp add: algebra_simps)
+      thus ?thesis unfolding succs_def by blast
+    qed
+  qed
+  thus "?x \<union> ?xs \<subseteq> succs (x#xs) n" by blast
+qed
+
+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)
+
+lemma succs_shift:
+  "(p - n \<in> succs P 0) = (p \<in> succs P n)" 
+  by (fastforce simp: succs_def isuccs_def split: instr.split)
+  
+lemma inj_op_plus [simp]:
+  "inj ((+) (i::int))"
+  by (metis add_minus_cancel inj_on_inverseI)
+
+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 a) n = {n + 1 .. n + size (acomp a)}"
+  by (induct a arbitrary: n) auto
+
+lemma acomp_size:
+  "(1::int) \<le> size (acomp a)"
+  by (induct a) auto
+
+lemma acomp_exits [simp]:
+  "exits (acomp a) = {size (acomp a)}"
+  by (auto simp: exits_def acomp_size)
+
+lemma bcomp_succs:
+  "0 \<le> i \<Longrightarrow>
+  succs (bcomp b f i) n \<subseteq> {n .. n + size (bcomp b f i)}
+                           \<union> {n + i + size (bcomp b f i)}" 
+proof (induction b arbitrary: f i n)
+  case (And b1 b2)
+  from And.prems
+  show ?case 
+    by (cases f)
+       (auto dest: And.IH(1) [THEN subsetD, rotated] 
+                   And.IH(2) [THEN subsetD, rotated])
+qed auto
+
+lemmas bcomp_succsD [dest!] = bcomp_succs [THEN subsetD, rotated]
+
+lemma bcomp_exits:
+  fixes i :: int
+  shows
+  "0 \<le> i \<Longrightarrow>
+  exits (bcomp b f i) \<subseteq> {size (bcomp b f i), i + size (bcomp b f i)}" 
+  by (auto simp: exits_def)
+  
+lemma bcomp_exitsD [dest!]:
+  "p \<in> exits (bcomp b f i) \<Longrightarrow> 0 \<le> i \<Longrightarrow> 
+  p = size (bcomp b f i) \<or> p = i + size (bcomp b f i)"
+  using bcomp_exits by auto
+
+lemma ccomp_succs:
+  "succs (ccomp c) n \<subseteq> {n..n + size (ccomp c)}"
+proof (induction c arbitrary: n)
+  case SKIP thus ?case by simp
+next
+  case Assign thus ?case by simp
+next
+  case (Seq c1 c2)
+  from Seq.prems
+  show ?case 
+    by (fastforce dest: Seq.IH [THEN subsetD])
+next
+  case (If b c1 c2)
+  from If.prems
+  show ?case
+    by (auto dest!: If.IH [THEN subsetD] simp: isuccs_def succs_Cons)
+next
+  case (While b c)
+  from While.prems
+  show ?case by (auto dest!: While.IH [THEN subsetD])
+qed
+
+lemma ccomp_exits:
+  "exits (ccomp c) \<subseteq> {size (ccomp c)}"
+  using ccomp_succs [of c 0] by (auto simp: exits_def)
+
+lemma ccomp_exitsD [dest!]:
+  "p \<in> exits (ccomp c) \<Longrightarrow> p = size (ccomp c)"
+  using ccomp_exits by auto
+
+
+subsection \<open>Splitting up machine executions\<close>
+
+lemma exec1_split:
+  fixes i j :: int
+  shows
+  "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 intro: iexec_shift)
+  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:
+  fixes j :: int
+  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:
+  fixes i n :: int
+  assumes "P1 @ P2 \<turnstile> (i, s, stk) \<rightarrow> (n, s', stk')" and "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:
+  fixes i n :: int
+  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 c)"
+  using ccomp_exits by (auto simp: closed_def)
+
+lemma acomp_closed [simp, intro!]: "closed (acomp c)"
+  by (simp add: closed_def)
+
+lemma exec_n_split_full:
+  fixes j :: int
+  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 a \<noteq> []"
+  by (induct a) auto
+
+lemma acomp_exec_n [dest!]:
+  "acomp a \<turnstile> (0,s,stk) \<rightarrow>^n (size (acomp a),s',stk') \<Longrightarrow> 
+  s' = s \<and> stk' = aval a s#stk"
+proof (induction a arbitrary: n s' stk stk')
+  case (Plus a1 a2)
+  let ?sz = "size (acomp a1) + (size (acomp a2) + 1)"
+  from Plus.prems
+  have "acomp a1 @ acomp 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 a1 \<turnstile> (0,s,stk) \<rightarrow>^n1 (size (acomp a1), s1, stk1)"
+    "acomp a2 \<turnstile> (0,s1,stk1) \<rightarrow>^n2 (size (acomp 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)
+
+lemma bcomp_split:
+  fixes i j :: int
+  assumes "bcomp b f i @ P' \<turnstile> (0, s, stk) \<rightarrow>^n (j, s', stk')" 
+          "j \<notin> {0..<size (bcomp b f i)}" "0 \<le> i"
+  shows "\<exists>s'' stk'' (i'::int) k m. 
+           bcomp b f i \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'') \<and>
+           (i' = size (bcomp b f i) \<or> i' = i + size (bcomp b f i)) \<and>
+           bcomp b f i @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^m (j, s', stk') \<and>
+           n = k + m"
+  using assms by (cases "bcomp b f i = []") (fastforce dest!: exec_n_drop_right)+
+
+lemma bcomp_exec_n [dest]:
+  fixes i j :: int
+  assumes "bcomp b f j \<turnstile> (0, s, stk) \<rightarrow>^n (i, s', stk')"
+          "size (bcomp b f j) \<le> i" "0 \<le> j"
+  shows "i = size(bcomp b f j) + (if f = bval b s then j else 0) \<and>
+         s' = s \<and> stk' = stk"
+using assms proof (induction 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.prems show ?case
+    by (fastforce dest!: Not.IH) 
+next
+  case (And b1 b2)
+  
+  let ?b2 = "bcomp b2 f j" 
+  let ?m  = "if f then size ?b2 else size ?b2 + j"
+  let ?b1 = "bcomp b1 False ?m" 
+
+  have j: "size (bcomp (And b1 b2) f j) \<le> i" "0 \<le> j" by fact+
+  
+  from And(3-5)
+  obtain s'' stk'' and i'::int and k m where 
+    b1: "?b1 \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'')"
+        "i' = size ?b1 \<or> i' = ?m + size ?b1" and
+    b2: "?b2 \<turnstile> (i' - size ?b1, s'', stk'') \<rightarrow>^m (i - size ?b1, s', stk')"
+    by (auto dest!: bcomp_split dest: exec_n_drop_left)
+  from b1 j(2)
+  have "i' = size ?b1 + (if \<not>bval b1 s then ?m else 0) \<and> s'' = s \<and> stk'' = stk"
+    by (auto dest!: And.IH)
+  with b2 j
+  show ?case
+    by (fastforce dest!: And.IH simp: exec_n_end split: if_split_asm)
+next
+  case Less
+  thus ?case by (auto dest!: exec_n_split_full simp: exec_n_simps exec1_def) (* takes time *)
+qed
+
+lemma ccomp_empty [elim!]:
+  "ccomp c = [] \<Longrightarrow> (c,s) \<Rightarrow> s"
+  by (induct c) auto
+
+declare assign_simp [simp]
+
+lemma ccomp_exec_n:
+  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>^n (size(ccomp c),t,stk')
+  \<Longrightarrow> (c,s) \<Rightarrow> t \<and> stk'=stk"
+proof (induction c arbitrary: s t stk stk' n)
+  case SKIP
+  thus ?case by auto
+next
+  case (Assign 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
diff --git a/Short_Theory_8_2.thy b/Short_Theory_8_2.thy
new file mode 100644
index 0000000..981750a
--- /dev/null
+++ b/Short_Theory_8_2.thy
@@ -0,0 +1,1044 @@
+theory Short_Theory_8_2
+  imports "HOL-IMP.BExp" "HOL-IMP.Star"
+begin
+
+datatype
+  com = SKIP 
+  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
+  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 60, 61] 61)
+  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
+  | Repeat com bexp         ("(REPEAT _/ UNTIL _)" [60, 0] 61)
+
+inductive
+  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
+  where
+    Skip: "(SKIP,s) \<Rightarrow> s" |
+    Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
+    Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
+    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
+    WhileTrue: "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
+    RepeatTrue: "\<lbrakk> bval b t; (c, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
+    RepeatFalse: "\<lbrakk> \<not>bval b s\<^sub>2; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
+      \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
+lemmas big_step_induct = big_step.induct[split_format(complete)]
+declare big_step.intros [intro]
+
+lemma BS_SkipE[elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_SeqE[elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
+ \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
+\<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
+  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<Rightarrow> t;
+  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+lemma BS_RepeatE[elim]: "\<lbrakk>
+  (REPEAT c UNTIL b, s) \<Rightarrow> t;
+  \<lbrakk>bval b t; (c, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
+  \<And>s\<^sub>2. \<lbrakk>\<not> bval b s\<^sub>2; (c, s) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: big_step.cases) auto
+
+lemma assign_simp:
+  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
+  by auto
+
+theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
+  by (induct arbitrary: u rule: big_step.induct) blast+
+
+inductive small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
+  where
+    Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |
+    Seq1: "(SKIP;; c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    Seq2: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> (c\<^sub>1';; c\<^sub>2, s')" |
+    IfTrue: "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
+    IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
+    While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |
+    Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"
+
+abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
+  where "x \<rightarrow>* y == star small_step x y"
+
+lemmas small_step_induct = small_step.induct[split_format(complete)]
+declare small_step.intros[simp,intro]
+
+lemma SS_SkipE[elim!]: "(SKIP, s) \<rightarrow> ct \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<rightarrow> ct; ct = (SKIP, s(x := aval a s)) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_SeqE[elim]: "\<lbrakk>
+  (c1;; c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c2, s); c1 = SKIP\<rbrakk> \<Longrightarrow> P;
+  \<And>c\<^sub>1' s'. \<lbrakk>ct = (c\<^sub>1';; c2, s'); (c1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_IfE[elim!]: "\<lbrakk>
+  (IF b THEN c1 ELSE c2, s) \<rightarrow> ct;
+  \<lbrakk>ct = (c1, s); bval b s\<rbrakk> \<Longrightarrow> P;
+  \<lbrakk>ct = (c2, s); \<not> bval b s\<rbrakk> \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_WhileE[elim]: "\<lbrakk>
+  (WHILE b DO c, s) \<rightarrow> ct;
+  ct = (IF b THEN c;; WHILE b DO c ELSE SKIP, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+lemma SS_RepeatE[elim]: "\<lbrakk>
+  (REPEAT c UNTIL b, s) \<rightarrow> ct;
+  ct = (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s) \<Longrightarrow> P
+\<rbrakk> \<Longrightarrow> P"
+  by (cases rule: small_step.cases) auto
+
+lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
+  by (induct rule: star_induct) (simp, blast intro: star.step)
+
+lemma seq_comp: "\<lbrakk>(c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3)\<rbrakk>
+  \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
+  by (blast intro: star.step star_seq2 star_trans)
+
+lemma big_to_small: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
+  by (induction rule: big_step.induct) (blast intro: seq_comp star.step)+
+
+lemma small1_big_continue: "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct arbitrary: t rule: small_step.induct) auto
+
+lemma small_to_big: "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
+  by (induct cs "(SKIP,t)" rule: star.induct) (auto intro: small1_big_continue)
+
+theorem big_iff_small: "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
+  by (blast intro: big_to_small small_to_big)
+
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+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)
+
+lemma nth_inth: "i < length (x # xs) \<Longrightarrow> (x # xs) !! i = (x # xs) ! i"
+proof (induct xs arbitrary: i x)
+  case (Cons a xs)
+  then show ?case
+  proof (cases "i = 0")
+    case False
+    from Cons False have Hl: "i - 1 < length (a # xs)" by auto
+    from Cons(2) False have "(x # a # xs) !! int i = (a # xs) !! (int (i - 1))" using int_ops(6) by auto
+    also from Cons(1) Hl have "\<dots> = (a # xs) ! (i - 1)" by blast
+    also from Cons(2) False have "\<dots> = (x # a # xs) ! i" by simp
+    finally show ?thesis .
+  qed simp
+qed simp
+
+abbreviation (output)
+  "isize xs == int (length xs)"
+
+notation isize ("size")
+
+datatype instr = 
+  LOADI int | LOAD vname |
+  ADD |
+  STORE vname |
+  JMP int | JMPLESS int | JMPGE int
+
+type_synonym stack = "val list"
+type_synonym config = "int \<times> state \<times> stack"
+
+abbreviation "hd2 xs == hd (tl xs)"
+abbreviation "tl2 xs == tl (tl xs)"
+
+(* note: by using hd / tl functions rather than pattern matching, we limit
+  reliance on the structure of stk in the behavior of iexec, allowing us
+  to simplify preconditions on lemmas that don't rely on the structure of
+  the stack
+*)
+fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
+  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
+  "iexec (LOAD x) (i, s, stk) = (i + 1, s, s x # stk)" |
+  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
+  "iexec (STORE x) (i, s, stk) = (i + 1, s(x := 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)"
+
+(* an introduction rule that expects the LHS config parameters to already be known *)
+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)
+
+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: "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: "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]:
+  "size P' <= 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 "Compilation"
+
+fun acomp :: "aexp \<Rightarrow> instr list" where
+  "acomp (N n) = [LOADI n]" |
+  "acomp (V x) = [LOAD x]" |
+  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"
+
+lemma acomp_correct[intro]:
+  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size (acomp a), s, aval a s # stk)"
+  by (induction a arbitrary: stk) fastforce+
+
+(* f = True means that we intend to jump n spaces upon the expression evaluating to True, and
+  step to next instruction upon the expression evaluating to False
+  f = False means vice versa
+
+  Suppose f = True in bcomp (And b1 b2). Then we want b1 to jump to just past b2 on False,
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True. Thus we let cb1 = bcomp b1 False (size cb2)
+
+  suppose f = False in bcomp (And b1 b2). Then we want b1 to jump to (size cb2 + n) on False
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True.
+
+  we have to have a JMP instruction to avoid jumping back from within the compiled bexp,
+  since our analysis so far has assumed that we always jump forward
+*)
+fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
+  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
+  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
+  "bcomp (And b1 b2) f n = (let
+    cb2 = bcomp b2 f n;
+    m = if f
+      then size cb2
+      else size cb2 + n;
+    cb1 = bcomp b1 False m in
+    cb1 @ cb2)" |
+  "bcomp (Less a1 a2) f n =
+    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"
+
+lemma bcomp_correct[intro]:
+  fixes n :: int
+  shows
+  "0 \<le> n \<Longrightarrow>
+  bcomp b f n \<turnstile>
+ (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
+proof (induct b arbitrary: f n)
+  case Not
+  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
+next
+  case (And b1 b2)
+  from And(1)
+    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
+    And(2) [of n f] And(3)
+  show ?case by fastforce
+qed fastforce+
+
+fun ccomp :: "com \<Rightarrow> instr list" where
+  "ccomp SKIP = []" |
+  "ccomp (x ::= a) = acomp a @ [STORE x]" |
+  "ccomp (c\<^sub>1;; c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
+  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
+    cc\<^sub>1 = ccomp c\<^sub>1;
+    cc\<^sub>2 = ccomp c\<^sub>2;
+    cb = bcomp b False (size cc\<^sub>1 + 1) in
+    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
+  "ccomp (WHILE b DO c) = (let
+    cc = ccomp c;
+    cb = bcomp b False (size cc + 1) in
+    cb @ cc @ [JMP (-(size cb + size cc + 1))])" |
+  "ccomp (REPEAT c UNTIL b) = (let
+    cc = ccomp c;
+    cb = bcomp b True 1 in
+    cc @ cb @ [JMP (-(size cc + size cb + 1))])"
+
+lemma shift_bcomp: "\<And>m n. size (bcomp b f m) = size (bcomp b f n)"
+proof (induct b arbitrary: f)
+  case (And b1 b2)
+  then show ?case
+  proof auto
+    assume H1: "\<And>f m n. length (bcomp b1 f m) = length (bcomp b1 f n)"
+    assume H2: "\<And>f m n. length (bcomp b2 f m) = length (bcomp b2 f n)"
+    from H2 have "size (bcomp b1 False (size (bcomp b2 True m))) + size (bcomp b2 True m) =
+      size (bcomp b1 False (size (bcomp b2 True m))) + size (bcomp b2 True n)" by simp
+    also from H1 have "\<dots> =
+      size (bcomp b1 False (size (bcomp b2 True n))) + size (bcomp b2 True n)" by simp
+    finally show "size (bcomp b1 False (size (bcomp b2 True m))) + size (bcomp b2 True m) =
+      size (bcomp b1 False (size (bcomp b2 True n))) + size (bcomp b2 True n)" .
+    from H2 have "size (bcomp b1 False (size (bcomp b2 False m) + m)) + size (bcomp b2 False m) =
+      size (bcomp b1 False (size (bcomp b2 False m) + m)) + size (bcomp b2 False n)" by simp
+    also from H1 have "\<dots> =
+      size (bcomp b1 False (size (bcomp b2 False n) + n)) + size (bcomp b2 False n)" by simp
+    finally show "size (bcomp b1 False (size (bcomp b2 False m) + m)) + size (bcomp b2 False m) =
+      size (bcomp b1 False (size (bcomp b2 False n) + n)) + size (bcomp b2 False n)" .
+  qed
+qed simp+
+
+lemma ccomp_bigstep:
+  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
+proof(induct arbitrary: stk rule: big_step_induct)
+  case (Assign x a s)
+  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
+  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
+    using Seq(2) by fastforce
+  moreover
+  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
+    using Seq(4) by fastforce
+  ultimately show ?case by simp (blast intro: star_trans)
+next
+  case (WhileTrue b s1 c s2 s3)
+  let ?cc = "ccomp c"
+  let ?cb = "bcomp b False (size ?cc + 1)"
+  and ?cw = "ccomp (WHILE b DO c)"
+  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)"
+    using \<open>bval b s1\<close> by fastforce
+  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
+    using WhileTrue(3) by fastforce
+  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)" by fastforce
+  ultimately show ?case using WhileTrue(5) by (blast intro: star_trans)
+next
+  case (RepeatFalse b s\<^sub>2 c s\<^sub>1 s\<^sub>3)
+  let ?cc = "ccomp c"
+  let ?cb = "bcomp b True 1"
+    and ?cr = "ccomp (REPEAT c UNTIL b)"
+  have "?cr \<turnstile> (0, s\<^sub>1, stk) \<rightarrow>* (size ?cc, s\<^sub>2, stk)" using RepeatFalse(3) by fastforce
+  moreover have "?cr \<turnstile> (size ?cc, s\<^sub>2, stk) \<rightarrow>* (size ?cc + size ?cb, s\<^sub>2, stk)"
+    using \<open>\<not> bval b s\<^sub>2\<close> by fastforce
+  moreover have "?cr \<turnstile> (size ?cc + size ?cb, s\<^sub>2, stk) \<rightarrow>* (0, s\<^sub>2, stk)" by fastforce
+  ultimately show ?case using RepeatFalse(5) by (blast intro: star_trans)
+qed fastforce+
+
+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. \<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,stk,s) \<rightarrow>^k (n',stk',s') = 
+  (\<exists>c. P \<turnstile> (n,stk,s) \<rightarrow> c \<and> P \<turnstile> c \<rightarrow>^(k - 1) (n',stk',s') \<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::int) \<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>
+
+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
+  let ?isuccs = "\<lambda>p P n i::int. 0 \<le> i \<and> i < size P \<and> p \<in> isuccs (P!!i) (n+i)"
+  have "p \<in> ?x \<union> ?xs" if assm: "p \<in> succs (x#xs) n" for p
+  proof -
+    from assm obtain i::int where isuccs: "?isuccs p (x#xs) n i"
+      unfolding succs_def by auto
+    show ?thesis
+    proof cases
+      assume "i = 0" with isuccs show ?thesis by simp
+    next
+      assume "i \<noteq> 0" 
+      with isuccs 
+      have "?isuccs p xs (1+n) (i - 1)" by auto
+      hence "p \<in> ?xs" unfolding succs_def by blast
+      thus ?thesis .. 
+    qed
+  qed
+  thus "succs (x#xs) n \<subseteq> ?x \<union> ?xs" ..
+
+  have "p \<in> succs (x#xs) n" if assm: "p \<in> ?x \<or> p \<in> ?xs" for p
+  proof -
+    from assm show ?thesis
+    proof
+      assume "p \<in> ?x" thus ?thesis by (fastforce simp: succs_def)
+    next
+      assume "p \<in> ?xs"
+      then obtain i where "?isuccs p xs (1+n) i"
+        unfolding succs_def by auto
+      hence "?isuccs p (x#xs) n (1+i)"
+        by (simp add: algebra_simps)
+      thus ?thesis unfolding succs_def by blast
+    qed
+  qed
+  thus "?x \<union> ?xs \<subseteq> succs (x#xs) n" by blast
+qed
+
+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)
+
+lemma succs_shift:
+  "(p - n \<in> succs P 0) = (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 a) n = {n + 1 .. n + size (acomp a)}"
+  by (induct a arbitrary: n) auto
+
+lemma acomp_size:
+  "(1::int) \<le> size (acomp a)"
+  by (induct a) auto
+
+(* consequence of acomp_succs *)
+lemma acomp_exits [simp]:
+  "exits (acomp a) = {size (acomp 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 b f i) n \<subseteq> {n..n + size (bcomp b f i)} \<union> {n + i + size (bcomp b f i)}" 
+proof (induction b arbitrary: f i n)
+  case (And b1 b2)
+  from And.prems
+  show ?case 
+    by (cases f)
+       (auto dest: And.IH(1) [THEN subsetD, rotated] 
+                   And.IH(2) [THEN subsetD, rotated])
+qed auto
+
+lemmas bcomp_succsD [dest!] = bcomp_succs [THEN subsetD, rotated]
+
+lemma bcomp_exits:
+  "0 \<le> i \<Longrightarrow>
+  exits (bcomp b f i) \<subseteq> {size (bcomp b f i), i + size (bcomp b f i)}" 
+  by (auto simp: exits_def)
+  
+lemma bcomp_exitsD [dest!]:
+  "p \<in> exits (bcomp b f i) \<Longrightarrow> 0 \<le> i \<Longrightarrow> 
+  p = size (bcomp b f i) \<or> p = i + size (bcomp b f i)"
+  using bcomp_exits by auto
+
+lemma ccomp_succs:
+  "succs (ccomp c) n \<subseteq> {n..n + size (ccomp c)}"
+proof (induction c arbitrary: n)
+  case SKIP thus ?case by simp
+next
+  case Assign thus ?case by simp
+next
+  case (Seq c1 c2)
+  from Seq.prems
+  show ?case 
+    by (fastforce dest: Seq.IH [THEN subsetD])
+next
+  case (If b c1 c2)
+  from If.prems
+  show ?case
+    by (auto dest!: If.IH [THEN subsetD] simp: isuccs_def succs_Cons)
+next
+  case (While b c)
+  from While.prems
+  show ?case by (auto dest!: While.IH [THEN subsetD])
+next
+  case (Repeat c x2)
+  from Repeat.prems
+  show ?case by (auto dest!: Repeat.IH [THEN subsetD])
+qed
+
+lemma ccomp_exits:
+  "exits (ccomp c) \<subseteq> {size (ccomp c)}"
+  using ccomp_succs [of c 0] by (auto simp: exits_def)
+
+lemma ccomp_exitsD [dest!]:
+  "p \<in> exits (ccomp c) \<Longrightarrow> p = size (ccomp c)"
+  using ccomp_exits by auto
+
+
+subsection \<open>Splitting up machine executions\<close>
+
+lemma exec1_split:
+  fixes i j :: int
+  shows
+  "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 intro: iexec_shift)
+  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:
+  fixes j :: int
+  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:
+  fixes i n :: int
+  assumes "P1 @ P2 \<turnstile> (i, s, stk) \<rightarrow> (n, s', stk')" and "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:
+  fixes i n :: int
+  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 c)"
+  using ccomp_exits by (auto simp: closed_def)
+
+lemma acomp_closed [simp, intro!]: "closed (acomp c)"
+  by (simp add: closed_def)
+
+lemma exec_n_split_full:
+  fixes j :: int
+  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 a \<noteq> []"
+  by (induct a) auto
+
+lemma acomp_exec_n [dest!]:
+  "acomp a \<turnstile> (0,s,stk) \<rightarrow>^n (size (acomp a),s',stk') \<Longrightarrow> 
+  s' = s \<and> stk' = aval a s#stk"
+proof (induction a arbitrary: n s' stk stk')
+  case (Plus a1 a2)
+  let ?sz = "size (acomp a1) + (size (acomp a2) + 1)"
+  from Plus.prems
+  have "acomp a1 @ acomp 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 a1 \<turnstile> (0,s,stk) \<rightarrow>^n1 (size (acomp a1), s1, stk1)"
+    "acomp a2 \<turnstile> (0,s1,stk1) \<rightarrow>^n2 (size (acomp 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)
+
+lemma bcomp_split:
+  fixes i j :: int
+  assumes "bcomp b f i @ P' \<turnstile> (0, s, stk) \<rightarrow>^n (j, s', stk')" 
+          "j \<notin> {0..<size (bcomp b f i)}" "0 \<le> i"
+  shows "\<exists>s'' stk'' (i'::int) k m. 
+           bcomp b f i \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'') \<and>
+           (i' = size (bcomp b f i) \<or> i' = i + size (bcomp b f i)) \<and>
+           bcomp b f i @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^m (j, s', stk') \<and>
+           n = k + m"
+  using assms by (cases "bcomp b f i = []") (fastforce dest!: exec_n_drop_right)+
+
+lemma bcomp_exec_n [dest]:
+  fixes i j :: int
+  assumes "bcomp b f j \<turnstile> (0, s, stk) \<rightarrow>^n (i, s', stk')"
+          "size (bcomp b f j) \<le> i" "0 \<le> j"
+  shows "i = size(bcomp b f j) + (if f = bval b s then j else 0) \<and>
+         s' = s \<and> stk' = stk"
+using assms proof (induction 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.prems show ?case
+    by (fastforce dest!: Not.IH) 
+next
+  case (And b1 b2)
+  
+  let ?b2 = "bcomp b2 f j" 
+  let ?m  = "if f then size ?b2 else size ?b2 + j"
+  let ?b1 = "bcomp b1 False ?m" 
+
+  have j: "size (bcomp (And b1 b2) f j) \<le> i" "0 \<le> j" by fact+
+  
+  from And.prems
+  obtain s'' stk'' and i'::int and k m where 
+    b1: "?b1 \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'')"
+        "i' = size ?b1 \<or> i' = ?m + size ?b1" and
+    b2: "?b2 \<turnstile> (i' - size ?b1, s'', stk'') \<rightarrow>^m (i - size ?b1, s', stk')"
+    by (auto dest!: bcomp_split dest: exec_n_drop_left)
+  from b1 j
+  have "i' = size ?b1 + (if \<not>bval b1 s then ?m else 0) \<and> s'' = s \<and> stk'' = stk"
+    by (auto dest!: And.IH)
+  with b2 j
+  show ?case 
+    by (fastforce dest!: And.IH simp: exec_n_end split: if_split_asm)
+next
+  case Less
+  thus ?case by (auto dest!: exec_n_split_full simp: exec_n_simps exec1_def) (* takes time *) 
+qed
+
+lemma ccomp_empty [elim!]:
+  "ccomp c = [] \<Longrightarrow> (c,s) \<Rightarrow> s"
+  by (induct c) auto
+
+declare assign_simp [simp]
+
+lemma ccomp_exec_n:
+  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>^n (size(ccomp c),t,stk')
+  \<Longrightarrow> (c,s) \<Rightarrow> t \<and> stk'=stk"
+proof (induction c arbitrary: s t stk stk' n)
+  case SKIP
+  thus ?case by auto
+next
+  case (Assign 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
+next
+  case (Repeat c x2)
+  from Repeat.prems
+  show ?case
+  proof (induction n arbitrary: s rule: nat_less_induct)
+    case (1 n)
+    then show ?case sorry
+  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
\ No newline at end of file
diff --git a/Short_Theory_8_3.thy b/Short_Theory_8_3.thy
new file mode 100644
index 0000000..bd1d96e
--- /dev/null
+++ b/Short_Theory_8_3.thy
@@ -0,0 +1,256 @@
+theory Short_Theory_8_3_2
+  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
+begin
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+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")
+
+datatype instr = 
+  LOADI int | LOAD vname |
+  ADD |
+  STORE vname |
+  JMP int | JMPLESS int | JMPGE int
+
+fun vars_in :: "instr list \<Rightarrow> vname list" where
+  "vars_in [] = []" |
+  "vars_in (LOAD x # P) = List.insert x (vars_in P)" |
+  "vars_in (STORE x # P) = List.insert x (vars_in P)" |
+  "vars_in (i # P) = vars_in P"
+
+type_synonym addr = int
+lemma vars_in_distinct: "distinct (vars_in P)"
+proof (induct P)
+  case (Cons a P)
+  {
+    fix x
+    from Cons have "distinct (List.insert x (vars_in P))"
+      by (cases "x \<in> set (vars_in P)") (auto simp add: Cons)
+  }
+  then show ?case  by (cases a) (auto simp add: Cons)
+qed simp
+
+fun nth_inv_P :: "instr list \<Rightarrow> vname \<Rightarrow> nat" where
+  "nth_inv_P P = the_inv_into {..<length (vars_in P)} ((!) (vars_in P))"
+
+fun addr_of :: "instr list \<Rightarrow> vname \<Rightarrow> int" where
+  "addr_of P v = (if v \<in> set (vars_in P)
+    then (int \<circ> nth_inv_P P) v
+    else -1)"
+
+lemma bij_addr_of: "bij_betw (addr_of P) (set (vars_in P)) (int ` {..<length (vars_in P)})"
+proof -
+  have "bij_betw ((!) (vars_in P)) {..<length (vars_in P)} (set (vars_in P))"
+    by (rule bij_betw_nth, auto simp add: vars_in_distinct)
+  then have 0: "bij_betw (nth_inv_P P) (set (vars_in P)) {..<length (vars_in P)}" (is ?P0)
+    by (simp add: bij_betw_the_inv_into)
+  have 1: "bij_betw int {..<length (vars_in P)} (int ` {..<length (vars_in P)})" (is ?P1) by simp
+  thm bij_betw_comp_iff [OF 0, of int "(int ` {..<length (vars_in P)})"]
+  have "?P1 \<longleftrightarrow>
+    bij_betw (int \<circ> nth_inv_P P) (set (vars_in P)) (int ` {..<length (vars_in P)})" (is "?P1 \<longleftrightarrow> ?P2")
+    by (rule bij_betw_comp_iff [OF 0])
+  with 1 have 2: ?P2 by blast
+  have "bij_betw (addr_of P) (set (vars_in P)) (int ` {..<length (vars_in P)}) \<longleftrightarrow> ?P2"
+    by (rule bij_betw_cong, simp)
+  with 2 show ?thesis by blast
+qed
+
+type_synonym stack = "val list"
+type_synonym mem_state = "addr \<Rightarrow> val"
+type_synonym addrs = "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 :: "addrs \<Rightarrow> instr \<Rightarrow> config \<Rightarrow> config" where
+  "iexec a (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
+  "iexec a (LOAD x) (i, s, stk) = (i + 1, s, s (a x) # stk)" |
+  "iexec a ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
+  "iexec a (STORE x) (i, s, stk) = (i + 1, s(a x := hd stk), tl stk)" |
+  "iexec a (JMP n) (i, s, stk) = (i + 1 + n, s, stk)" |
+  "iexec a (JMPLESS n) (i, s, stk) = (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk)" |
+  "iexec a (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 (addr_of P) (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P)"
+
+(* an introduction rule that expects the LHS config parameters to already be known *)
+lemma exec1I [intro, code_pred_intro]:
+  "c' = iexec (addr_of P) (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)
+
+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)]
+
+lemma iexec_shift [simp]: 
+  "(n + i', s', stk') = iexec a x (n + i, s, stk) \<longleftrightarrow>
+  (i', s', stk') = iexec a x (i, s, stk)"
+  by (cases x, auto)
+
+(* 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'" unfolding exec1_def
+proof -
+  assume "\<exists> i s stk. c = (i, s, stk) \<and> c' = iexec (addr_of P) (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P"
+  then obtain i s stk where 0: "c = (i, s, stk)"
+    and 1: "c' = iexec (addr_of P) (P !! i) (i, s, stk)"
+    and 2: "0 \<le> i" and 3: "i < size P" by blast+
+  from 3 have 4: "i < size (P @ P')" by auto
+qed
+
+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' <= 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 "Compilation"
+
+fun acomp :: "aexp \<Rightarrow> instr list" where
+  "acomp (N n) = [LOADI n]" |
+  "acomp (V x) = [LOAD x]" |
+  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"
+
+lemma acomp_correct[intro]:
+  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size(acomp a), s, aval a s # stk)"
+  by (induction a arbitrary: stk) fastforce+
+
+(* f = True means that we intend to jump n spaces upon the expression evaluating to True, and
+  step to next instruction upon the expression evaluating to False
+  f = False means vice versa
+
+  Suppose f = True in bcomp (And b1 b2). Then we want b1 to jump to just past b2 on False,
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True. Thus we let cb1 = bcomp b1 False (size cb2)
+
+  suppose f = False in bcomp (And b1 b2). Then we want b1 to jump to (size cb2 + n) on False
+  (we know early that the And expression evaluates to False),
+  and to continue with b2 on True.
+*)
+fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
+  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
+  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
+  "bcomp (And b1 b2) f n = (let
+    cb2 = bcomp b2 f n;
+    m = if f
+      then size cb2
+      else size cb2 + n;
+    cb1 = bcomp b1 False m in
+    cb1 @ cb2)" |
+  "bcomp (Less a1 a2) f n =
+    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"
+
+lemma bcomp_correct[intro]:
+  fixes n :: int
+  shows
+  "0 \<le> n \<Longrightarrow>
+  bcomp b f n \<turnstile>
+ (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
+proof (induct b arbitrary: f n)
+  case Not
+  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
+next
+  case (And b1 b2)
+  from And(1)
+    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
+    And(2) [of n f] And(3)
+  show ?case by fastforce
+qed fastforce+
+
+fun ccomp :: "com \<Rightarrow> instr list" where
+  "ccomp SKIP = []" |
+  "ccomp (x ::= a) = acomp a @ [STORE x]" |
+  "ccomp (c\<^sub>1;; c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
+  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
+    cc\<^sub>1 = ccomp c\<^sub>1;
+    cc\<^sub>2 = ccomp c\<^sub>2;
+    cb = bcomp b False (size cc\<^sub>1 + 1) in
+    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
+  "ccomp (WHILE b DO c) = (let
+    cc = ccomp c;
+    cb = bcomp b False (size cc + 1) in
+    cb @ cc @ [JMP (-(size cb + size cc + 1))])"
+
+lemma ccomp_bigstep:
+  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
+proof(induct arbitrary: stk rule: big_step_induct)
+  case (Assign x a s)
+  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
+next
+  case (Seq c1 s1 s2 c2 s3)
+  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
+  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
+    using Seq(2) by fastforce
+  moreover
+  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
+    using Seq(4) by fastforce
+  ultimately show ?case by simp (blast intro: star_trans)
+next
+  case (WhileTrue b s1 c s2 s3)
+  let ?cc = "ccomp c"
+  let ?cb = "bcomp b False (size ?cc + 1)"
+  and ?cw = "ccomp (WHILE b DO c)"
+  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)" using \<open>bval b s1\<close> by fastforce
+  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
+    using WhileTrue(3) by fastforce
+  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)" by fastforce
+  ultimately show ?case using WhileTrue(5) by(blast intro: star_trans)
+qed fastforce+
+
+end
\ No newline at end of file
diff --git a/Short_Theory_8_3_1.thy b/Short_Theory_8_3_1.thy
new file mode 100644
index 0000000..5b3c661
--- /dev/null
+++ b/Short_Theory_8_3_1.thy
@@ -0,0 +1,259 @@
+theory Short_Theory_8_3_1
+  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
+begin
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+subsection "mmap setup"
+
+lemma bij_cancel_r [simp]: "\<lbrakk>bij b; f \<circ> b = g \<circ> b\<rbrakk> \<Longrightarrow> f = g"
+  by (metis bij_betw_def surj_fun_eq)
+
+lemma bij_comp_update [simp]: "bij b \<Longrightarrow> (f \<circ> b) (x := y) = (f ((b x) := y)) \<circ> b"
+proof
+  fix xa
+  assume "bij b"
+  show "((f \<circ> b)(x := y)) xa = (f(b x := y) \<circ> b) xa"
+  proof (cases "xa = x")
+    case False
+    then have "((f \<circ> b)(x := y)) xa = f (b xa)" by simp
+    also from \<open>bij b\<close> False have "b xa \<noteq> b x" by (meson bij_def inj_def)
+    then have "f (b xa) = (f(b x := y) \<circ> b) xa" by simp
+    finally show ?thesis .
+  qed simp
+qed
+
+lemma bij_cancel_r2: "bij b \<Longrightarrow> \<exists> g. f = g \<circ> b" by (metis bij_is_inj o_inv_o_cancel)
+
+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)"
+
+(* an introduction rule that expects the LHS config parameters to already be known *)
+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)
+
+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)]
+
+subsection\<open>Verification infrastructure\<close>
+
+lemma iexec_shift [simp]: 
+  "(n + i', s', stk') = iexec x (n + i, s, stk) \<longleftrightarrow>
+  (i', s', stk') = iexec x (i, s, stk)"
+  by (cases x, auto)
+
+(* 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' <= 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 "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]:
+  "acomp m a \<turnstile> (0, s, stk) \<rightarrow>* (size (acomp m a), s, aval a (s \<circ> m) # stk)"
+  by (induction a arbitrary: stk) 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>
+  bcomp m b f n \<turnstile>
+ (0, s, stk) \<rightarrow>* (size (bcomp m b f n) + (if f = bval b (s \<circ> m) then n else 0), s, stk)"
+proof (induct b arbitrary: f n)
+  case (Not b)
+  from Not(1) Not(2) 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 \<circ> m) then n else 0), s, stk)" .
+  moreover have "?this \<longleftrightarrow> (bcomp m (bexp.Not b) f n \<turnstile> (0, s, stk) \<rightarrow>* (size (bcomp m (bexp.Not b) f n) + (if f = bval (bexp.Not b) (s \<circ> m) then n else 0), s, stk))" by simp
+  ultimately show ?case by blast
+next
+  case (And b1 b2)
+  let ?sm = "s \<circ> m"
+  let ?bc2 = "bcomp m b2 f n" and ?bv2 = "bval b2 ?sm"
+  let ?sizeb2 = "size ?bc2"
+
+  let ?n' = "if f then ?sizeb2 else ?sizeb2 + n"
+  let ?bc1 = "bcomp m b1 False ?n'" and ?bv1 = "bval b1 ?sm"
+  let ?sizeb1 = "size ?bc1"
+
+  let ?bcAnd = "bcomp m (And b1 b2) f n"
+    and ?bvAnd = "bval (And b1 b2) ?sm"
+  let ?sizeAnd = "size ?bcAnd"
+
+  from And(2) And(3) have H2: "?bc2 \<turnstile> (0, s, stk) \<rightarrow>* (?sizeb2 + (if f = ?bv2 then n else 0), s, stk)" .
+  from And(3) And(1) [of ?n' "False"] 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
+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))])"
+
+lemma ccomp_bigstep:
+  "\<lbrakk>(c, s \<circ> m) \<Rightarrow> (t \<circ> m); bij m\<rbrakk> \<Longrightarrow> ccomp m c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp m c), t, stk)"
+proof (induct c "s \<circ> m" "t \<circ> m" arbitrary: s t m stk rule: big_step_induct)
+  case (Skip s)
+  then have "s = t" by simp
+  then show ?case by simp
+next
+  case (Assign x a s)
+  then have "s((m x) := aval a (s \<circ> m)) = t" by simp
+  then show ?case by fastforce
+next
+  case (Seq c\<^sub>1 s\<^sub>2m c\<^sub>2)
+  from Seq(5) obtain s\<^sub>2 where Hs\<^sub>2: "s\<^sub>2m = s\<^sub>2 \<circ> m" using bij_cancel_r2 by auto
+  with Seq(2, 5) have H1: "ccomp m c\<^sub>1 \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp m c\<^sub>1), s\<^sub>2, stk)" by auto
+  from Hs\<^sub>2 Seq(4, 5) have H2: "ccomp m c\<^sub>2 \<turnstile> (0, s\<^sub>2, stk) \<rightarrow>* (size (ccomp m c\<^sub>2), t, stk)" by auto
+  from H1 H2 show ?case by auto
+next
+  case (WhileFalse b c)
+  from WhileFalse(2, 3) have "s = t" by simp
+  with WhileFalse(1) show ?case by fastforce
+next
+  case (WhileTrue b c s\<^sub>2m)
+  let ?cc = "ccomp m c" and ?cw = "ccomp m (WHILE b DO c)"
+  let ?cb = "bcomp m b False (size ?cc + 1)"
+  from WhileTrue(1) have "?cw \<turnstile> (0, s, stk) \<rightarrow>* (size ?cb, s, stk)" by fastforce
+  moreover from WhileTrue(6) obtain s\<^sub>2 where Hs\<^sub>2: "s\<^sub>2m = s\<^sub>2 \<circ> m" using bij_cancel_r2 by auto
+  with WhileTrue(3, 6) have "?cw \<turnstile> (size ?cb, s, stk) \<rightarrow>* (size ?cb + size ?cc, s\<^sub>2, stk)" by fastforce
+  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s\<^sub>2, stk) \<rightarrow>* (0, s\<^sub>2, stk)" by fastforce
+  moreover from Hs\<^sub>2 WhileTrue(5, 6) have "?cw \<turnstile> (0, s\<^sub>2, stk) \<rightarrow>* (size (ccomp m (WHILE b DO c)), t, stk)" by simp
+  ultimately show ?case by (blast intro: star_trans)
+qed fastforce+
+
+end
\ No newline at end of file
diff --git a/Short_Theory_8_3_2.thy b/Short_Theory_8_3_2.thy
new file mode 100644
index 0000000..09b236f
--- /dev/null
+++ b/Short_Theory_8_3_2.thy
@@ -0,0 +1,1251 @@
+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
+*)
\ No newline at end of file
diff --git a/Short_Theory_8_4.thy b/Short_Theory_8_4.thy
new file mode 100644
index 0000000..6709930
--- /dev/null
+++ b/Short_Theory_8_4.thy
@@ -0,0 +1,634 @@
+theory Short_Theory_8_4
+  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
+begin
+declare [[coercion_enabled]] 
+declare [[coercion "int :: nat \<Rightarrow> int"]]
+
+subsection "List setup"
+
+primrec (nonexhaustive) inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
+  "(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"
+
+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)
+
+lemma nth_inth: "i < length (x # xs) \<Longrightarrow> (x # xs) !! i = (x # xs) ! i"
+proof (induct xs arbitrary: i x)
+  case (Cons a xs)
+  then show ?case
+  proof (cases "i = 0")
+    case False
+    from Cons False have Hl: "i - 1 < length (a # xs)" by auto
+    from Cons(2) False have "(x # a # xs) !! int i = (a # xs) !! (int (i - 1))" using int_ops(6) by auto
+    also from Cons(1) Hl have "\<dots> = (a # xs) ! (i - 1)" by blast
+    also from Cons(2) False have "\<dots> = (x # a # xs) ! i" by simp
+    finally show ?thesis .
+  qed simp
+qed simp
+
+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> int"
+
+abbreviation "hd2 xs == hd (tl xs)"
+abbreviation "tl2 xs == tl (tl xs)"
+
+fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
+  "iexec (LOADI n) (pc, s, sp) = (pc + 1, s(sp - 1 := n), sp - 1)" |
+  "iexec (LOAD a) (pc, s, sp) = (pc + 1, s(sp - 1 := s a), sp - 1)" |
+  "iexec ADD (pc, s, sp) = (pc + 1, s(sp + 1 := s (sp + 1) + s sp), sp + 1)" |
+  "iexec (STORE a) (pc, s, sp) = (pc + 1, s(a := s sp), sp + 1)" |
+  "iexec (JMP n) (pc, s, sp) = (pc + 1 + n, s, sp)" |
+  "iexec (JMPLESS n) (pc, s, sp) = (if s (sp + 1) < s sp then pc + 1 + n else pc + 1, s, sp + 2)" |
+  "iexec (JMPGE n) (pc, s, sp) = (if s (sp + 1) >= s sp then pc + 1 + n else pc + 1, s, sp + 2)"
+
+abbreviation stack_eq :: "int \<Rightarrow> mem_state \<Rightarrow> mem_state \<Rightarrow> bool"
+  where "stack_eq sp s t \<equiv> (\<forall> a. (sp \<le> a \<and> a < 0) \<longrightarrow> s a = t a)"
+
+definition exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
+  ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)  where
+  "P \<turnstile> c \<rightarrow> c' \<longleftrightarrow>
+  (\<exists>pc s sp. c = (pc, s, sp) \<and>
+    (\<forall> a. (P !! pc) = STORE a \<longrightarrow> 0 \<le> a) \<and>
+    0 \<le> pc \<and> pc < size P \<and>
+    sp \<le> 0 \<and>
+    c' = iexec (P !! pc) (pc, s, sp))"
+  (* While we can check  *)
+
+lemma exec1I [intro, code_pred_intro]:
+  "\<lbrakk>c' = iexec (P !! pc) (pc, s, sp);
+    \<forall> a. (P !! pc) = STORE a \<longrightarrow> 0 \<le> a;
+    0 \<le> pc; pc < size P;
+    sp \<le> 0
+  \<rbrakk> \<Longrightarrow> P \<turnstile> (pc, s, sp) \<rightarrow> c'"
+  using exec1_def by blast
+
+code_pred exec1 by (simp add: exec1_def)
+
+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)]
+
+lemma iexec_shift [simp]: 
+  "(n + pc', s', sp') = iexec x (n + pc, s, sp) \<longleftrightarrow>
+  (pc', s', sp') = iexec x (pc, s, sp)"
+  by (cases x, auto)
+
+(* 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: "P \<turnstile> (pc, s, sp) \<rightarrow> (pc', s', sp') \<Longrightarrow>
+  P' @ P \<turnstile> (size P' + pc, s, sp) \<rightarrow> (size P' + pc', s', sp')"
+  by (auto simp add: exec1_def)
+
+lemma exec_appendL: "P \<turnstile> (pc, s, sp) \<rightarrow>* (pc', s', sp') \<Longrightarrow>
+  P' @ P \<turnstile> (size P' + pc, s, sp) \<rightarrow>* (size P' + pc', s', sp')"
+  by (induct rule: exec_induct) (blast intro: star.step exec1_appendL)+
+
+(* specialize append lemmas to have tools automatically reason about execution
+  in certain safe and uninteresting cases.
+*)
+lemma exec_Cons_1 [intro]:
+  "P \<turnstile> (0, s, sp) \<rightarrow>* (pc', t, sp') \<Longrightarrow>
+  instr # P \<turnstile> (1, s, sp) \<rightarrow>* (1 + pc', t, sp')"
+  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]:
+  "\<lbrakk>size P' \<le> pc;
+    P \<turnstile> (pc - size P', s, sp) \<rightarrow>* (pci, s', sp');
+    pc' = size P' + pci
+  \<rbrakk> \<Longrightarrow> P' @ P \<turnstile> (pc, s, sp) \<rightarrow>* (pc', s', sp')"
+  by (drule exec_appendL [where P'=P']) simp
+
+lemma exec_append_trans [intro]:
+  "\<lbrakk>P \<turnstile> (0, s, sp) \<rightarrow>* (pci, si, spi);
+    size P \<le> pci;
+    P' \<turnstile>  (pci - size P, si, spi) \<rightarrow>* (pci', s', sp');
+    pc' = size P + pci'
+  \<rbrakk> \<Longrightarrow> P @ P' \<turnstile> (0, s, sp) \<rightarrow>* (pc', s', sp')"
+  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 ` (Suc ` {..<length (vars_in c)})"
+
+abbreviation on_eq :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
+  "on_eq A f g \<equiv> (\<forall> a \<in> A. f a = g a)"
+
+abbreviation nneg_int :: "int set" where
+  "nneg_int \<equiv> {n\<in>\<int>. n \<ge> 0}"
+
+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> Suc \<circ> nth_inv_c c) v
+    else 0)"
+
+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 Suc {..<length (vars_in c)} (Suc ` {..<length (vars_in c)})" by simp
+  with bij_betw_comp_iff [OF 0] have 2: "bij_betw (Suc \<circ> nth_inv_c c) (svars_in c) (Suc ` {..<length (vars_in c)})" by blast
+  have 3: "bij_betw int (Suc ` {..<length (vars_in c)}) (addrs_in c)" (is ?P1) by simp
+  with 1 bij_betw_comp_iff [OF 2, of int "addrs_in c"] have "bij_betw (int \<circ> (Suc \<circ> nth_inv_c c)) (svars_in c) (addrs_in c)" by auto
+  then have 4: "bij_betw (int \<circ> Suc \<circ> nth_inv_c c) (svars_in c) (addrs_in c)" by (simp add: comp_assoc)
+  have 5: "\<And>a. a \<in> svars_in c \<Longrightarrow> (int \<circ> Suc \<circ> nth_inv_c c) a = addr_of c a" by simp
+  from bij_betw_cong [of "svars_in c" "int \<circ> Suc \<circ> nth_inv_c c" "addr_of c" "addrs_in c", OF 5] 4
+  show 6: "bij_betw (addr_of c) (svars_in c) (addrs_in c)" by blast
+qed
+
+corollary inj_on_addr_of: "inj_on (addr_of c) (svars_in c)" using bij_addr_of bij_betw_def by blast
+
+subsection "mmap setup"
+
+lemma inj_on_cancel_r: "\<lbrakk>inj_on b A; f \<circ> b = g \<circ> b\<rbrakk> \<Longrightarrow> on_eq (b ` A) f g" using comp_eq_dest by fastforce
+
+lemma inj_on_comp_update: "inj_on b A \<Longrightarrow> \<forall> x \<in> A. on_eq A ((f \<circ> b)(x := y)) (f(b x := y) \<circ> b)"
+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 "on_eq A ((f \<circ> b)(x := y)) (f(b x := y) \<circ> b)" by blast
+qed
+
+lemma inj_on_cancel_r2: "inj_on b A \<Longrightarrow> \<exists> g. on_eq A f (g \<circ> b)"
+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]:
+  "\<lbrakk>sp \<le> 0;
+    \<forall>a\<in>range m. a \<ge> 0;
+    on_eq (set (vars_in_aexp a)) s (s' \<circ> m)
+  \<rbrakk> \<Longrightarrow> \<exists>t'. (acomp m a \<turnstile> (0, s', sp) \<rightarrow>* (size (acomp m a), t', sp - 1)) \<and>
+    stack_eq sp s' t' \<and>
+    (\<forall>a\<ge>0. s' a = t' a) \<and>
+    t' (sp - 1) = aval a s"
+proof (induct a arbitrary: s' sp)
+  case (Plus a1 a2)
+  let ?ac1 = "acomp m a1" and ?av1 = "aval a1 s"
+    and ?ac2 = "acomp m a2" and ?av2 = "aval a2 s"
+    and ?cap = "acomp m (Plus a1 a2)"
+  from Plus(1, 3-5) have "\<exists>t'. (?ac1 \<turnstile> (0, s', sp) \<rightarrow>* (size ?ac1, t', sp - 1)) \<and>
+    stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a) \<and> t' (sp - 1) = ?av1" by simp
+  then obtain si where He1: "?ac1 \<turnstile> (0, s', sp) \<rightarrow>* (size ?ac1, si, sp - 1)"
+    and Hs1: "stack_eq sp s' si"
+    and Ha1: "\<And>a. a \<ge> 0 \<Longrightarrow> s' a = si a"
+    and Hv1: "si (sp - 1) = ?av1" by auto
+  from Plus(3) have H1: "sp - 1 \<le> 0" by simp
+  from Plus(4, 5) Ha1 have H2: "on_eq (set (vars_in_aexp a2)) s (si \<circ> m)" by simp
+  from Plus(2) [OF H1 Plus(4) H2] have "\<exists>t'. (?ac2 \<turnstile> (0, si, sp - 1) \<rightarrow>* (size ?ac2, t', sp - 2)) \<and>
+    stack_eq (sp - 1) si t' \<and> (\<forall>a\<ge>0. si a = t' a) \<and> t' (sp - 2) = aval a2 s" by simp
+  then obtain t' where He2: "?ac2 \<turnstile> (0, si, sp - 1) \<rightarrow>* (size ?ac2, t', sp - 2)"
+    and Hs2: "stack_eq (sp - 1) si t'"
+    and Ha2: "\<And>a. 0 \<le> a \<Longrightarrow> si a = t' a"
+    and Hv2: "t' (sp - 2) = ?av2" by auto
+  show ?case
+  proof (intro exI conjI)
+    from Plus(3) have "[ADD] \<turnstile> (0, t', sp - 2) \<rightarrow>* (1, t'(sp - 1 := t' (sp - 2) + t' (sp - 1)), sp - 1)" by fastforce
+    with He1 He2 show "?cap \<turnstile> (0, s', sp) \<rightarrow>* (size ?cap, t'(sp - 1 := t' (sp - 2) + t' (sp - 1)), sp - 1)" by fastforce
+    from Hs1 Hs2 show "stack_eq sp s' (t'(sp - 1 := t' (sp - 2) + t' (sp - 1)))" by simp
+    from Plus(3) Ha1 Ha2 show "\<forall>a\<ge>0. s' a = (t'(sp - 1 := t' (sp - 2) + t' (sp - 1))) a" by simp
+    from Plus(3) Hv1 Hs2 Hv2 show "(t'(sp - 1 := t' (sp - 2) + t' (sp - 1))) (sp - 1) = aval (Plus a1 a2) s" by auto
+  qed
+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]:
+  "\<lbrakk>sp \<le> 0;
+    \<forall>a\<in>range m. a \<ge> 0;
+    on_eq (set (vars_in_bexp b)) s (s' \<circ> m);
+    0 \<le> n
+  \<rbrakk> \<Longrightarrow> \<exists>t'. (bcomp m b f n \<turnstile> (0, s', sp) \<rightarrow>* (size (bcomp m b f n) + (if f = bval b s then n else 0), t', sp)) \<and>
+    stack_eq sp s' t' \<and>
+    (\<forall>a\<ge>0. s' a = t' a)"
+proof (induct b arbitrary: f n s')
+  case (Not b)
+  then have "\<exists>t'. (bcomp m b (\<not> f) n \<turnstile> (0, s', sp) \<rightarrow>* (size (bcomp m b (\<not> f) n) + (if (\<not> f) = bval b s then n else 0), t', sp)) \<and>
+    stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" 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(1) [of s' ?n' False] And(3-6) have "\<exists> t'. (?bc1 \<turnstile> (0, s', sp) \<rightarrow>* (?sizeb1 + (if False = ?bv1 then ?n' else 0), t', sp)) \<and>
+    stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by simp
+  then obtain si where He1: "?bc1 \<turnstile> (0, s', sp) \<rightarrow>* (?sizeb1 + (if False = ?bv1 then ?n' else 0), si, sp)"
+    and Hs1: "stack_eq sp s' si"
+    and Hv1: "\<forall>a\<ge>0. s' a = si a" by auto
+  from And(2-6) Hv1 have "\<exists>t'. (?bc2 \<turnstile> (0, si, sp) \<rightarrow>* (?sizeb2 + (if f = ?bv2 then n else 0), t', sp)) \<and>
+    stack_eq sp si t' \<and> (\<forall>a\<ge>0. si a = t' a)" by simp
+  then obtain t' where He2: "?bc2 \<turnstile> (0, si, sp) \<rightarrow>* (?sizeb2 + (if f = ?bv2 then n else 0), t', sp)"
+    and Hs2: "stack_eq sp si t'"
+    and Hv2: "\<forall>a\<ge>0. si a = t' a" by auto
+  from Hs1 Hs2 have Hs3: "stack_eq sp s' t'" by simp
+  from Hv1 Hv2 have Hv3: "\<forall>a\<ge>0. s' a = t' a" by simp
+  show ?case
+  proof (cases ?bv1)
+    case Hbv1: True
+    from Hbv1 He1 He2 Hs3 Hv3 show ?thesis by fastforce
+  next
+    case Hbv1: False
+    then show ?thesis
+    proof (cases f)
+      case Hf: True
+      from Hbv1 Hf He1 Hs1 Hv1 show ?thesis by fastforce
+    next
+      case Hf: False
+      from Hbv1 Hf He1 And(6) Hs1 Hv1 show ?thesis by (fastforce simp add: add.assoc)
+    qed
+  qed
+next
+  case (Less x1a x2a)
+  let ?ac1 = "acomp m x1a" and ?av1 = "aval x1a s"
+    and ?ac2 = "acomp m x2a" and ?av2 = "aval x2a s"
+    and ?jmp = "if f then [JMPLESS n] else [JMPGE n]"
+    and ?bcLess = "bcomp m (Less x1a x2a) f n"
+    and ?bvLess = "bval (Less x1a x2a) s"
+  from Less(1-3) have "\<exists>t'. (?ac1 \<turnstile> (0, s', sp) \<rightarrow>* (size ?ac1, t', sp - 1)) \<and> stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a) \<and> t' (sp - 1) = ?av1" by auto
+  then obtain si where He1: "?ac1 \<turnstile> (0, s', sp) \<rightarrow>* (size ?ac1, si, sp - 1)"
+    and Hs1: "stack_eq sp s' si"
+    and Ha1: "\<forall>a\<ge>0. s' a = si a"
+    and Hv1: "si (sp - 1) = ?av1" by auto
+  from Less(2, 3) Ha1 have Heq1: "on_eq (set (vars_in_bexp (Less x1a x2a))) s (si \<circ> m)" by simp
+  from Less(1,2) Heq1 have "\<exists>t'. (?ac2 \<turnstile> (0, si, sp - 1) \<rightarrow>* (size ?ac2, t', sp - 2)) \<and> stack_eq (sp - 1) si t' \<and> (\<forall>a\<ge>0. si a = t' a) \<and> t' (sp - 2) = ?av2"
+    using acomp_correct [of "sp - 1"] by simp
+  then obtain t' where He2: "?ac2 \<turnstile> (0, si, sp - 1) \<rightarrow>* (size ?ac2, t', sp - 2)"
+    and Hs2: "stack_eq (sp - 1) si t'"
+    and Ha2: "\<forall>a\<ge>0. si a = t' a"
+    and Hv2: "t' (sp - 2) = ?av2" by auto
+  value "iexec (JMPLESS n) (0, t', sp - 2)"
+  show ?case
+  proof (intro exI conjI)
+    from Hv1 Hv2 Hs2 Less(1) have He3: "?jmp \<turnstile> (0, t', sp - 2) \<rightarrow>* (1 + (if f = ?bvLess then n else 0), t', sp)" by fastforce
+    from He1 He2 He3 show "?bcLess \<turnstile> (0, s', sp) \<rightarrow>* (size ?bcLess + (if f = ?bvLess then n else 0), t', sp)" by (fastforce simp add: add.assoc)
+    from Hs1 Hs2 show "stack_eq sp s' t'" by simp
+    from Ha1 Ha2 show "\<forall>a\<ge>0. s' a = t' a" by simp
+  qed
+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> on_eq (-(svars_in c)) s t"
+  by (induct rule: big_step_induct) simp+
+
+lemma map_invariance: "\<lbrakk>
+  inj_on m (svars_in c);
+  \<forall>a\<in>range m. a \<ge> 0;
+  (c\<^sub>1, s) \<Rightarrow> t;
+  svars_in c\<^sub>1 \<subseteq> svars_in c;
+  on_eq (svars_in c) s (s' \<circ> m);
+  on_eq (svars_in c\<^sub>1) t (t' \<circ> m);
+  \<forall>a\<ge>0. a \<notin> m ` (svars_in c\<^sub>1) \<longrightarrow> s' a = t' a
+\<rbrakk> \<Longrightarrow> \<forall> v \<in> svars_in c. t v = t' (m v)"
+proof
+  assume H: "inj_on m (svars_in c)"
+    "\<forall>a\<in>range m. a \<ge> 0"
+    "(c\<^sub>1, s) \<Rightarrow> t"
+    "svars_in c\<^sub>1 \<subseteq> svars_in c"
+    "on_eq (svars_in c) s (s' \<circ> m)"
+    "on_eq (svars_in c\<^sub>1) t (t' \<circ> m)"
+    "\<forall>a\<ge>0. a \<notin> m ` (svars_in c\<^sub>1) \<longrightarrow> s' a = t' a"
+  fix v
+  assume H1: "v \<in> svars_in c"
+  show "t v = t' (m v)"
+  proof (cases "v \<in> svars_in c\<^sub>1")
+    case False
+    from H(1, 2, 4) H1 False have H2: "m v \<ge> 0 \<and> m v \<notin> m ` svars_in c\<^sub>1"
+      by (meson inj_on_image_mem_iff_alt range_eqI)
+    from H(3, 4) False have "t v = s v" using bigstep_state_invariance by fastforce
+    also from H(5) H1 have "\<dots> = s' (m v)" by simp
+    also from H(7) H2 have "\<dots> = t' (m v)" by simp
+    finally show ?thesis .
+  qed (simp add: H(6))
+qed
+
+lemma ccomp_bigstep: "\<lbrakk>
+  (c, s) \<Rightarrow> t;
+  inj_on m (svars_in c);
+  sp \<le> 0;
+  \<forall>a\<in>range m. a \<ge> 0;
+  on_eq (svars_in c) s (s' \<circ> m)
+\<rbrakk> \<Longrightarrow> \<exists> t'. (ccomp m c \<turnstile> (0, s', sp) \<rightarrow>* (size (ccomp m c), t', sp)) \<and>
+  on_eq (svars_in c) t (t' \<circ> m) \<and>
+  (\<forall> a \<ge> 0. a \<notin> m ` (svars_in c) \<longrightarrow> s' a = t' a)"
+proof (induct c s t arbitrary: sp s' rule: big_step_induct)
+  case (Skip s)
+  show ?case
+  proof (intro exI conjI)
+    show "ccomp m SKIP \<turnstile> (0, s', sp) \<rightarrow>* (size (ccomp m SKIP), s', sp)" by simp
+    show "on_eq (svars_in SKIP) s (s' \<circ> m)" by simp
+    show "\<forall>a\<ge>0. a \<notin> m ` svars_in SKIP \<longrightarrow> s' a = s' a" by simp
+  qed
+next
+  case (Assign x a s)
+  thm acomp_correct
+  let ?ac = "acomp m a" and ?av = "aval a s" and ?cc = "ccomp m (x ::= a)"
+  from Assign(2, 3, 4) have "\<exists>t'. (?ac \<turnstile> (0, s', sp) \<rightarrow>* (size ?ac, t', sp - 1)) \<and>
+    stack_eq sp s' t' \<and>
+    (\<forall>a\<ge>0. s' a = t' a) \<and>
+    t' (sp - 1) = ?av" by auto
+  then obtain si where He1: "?ac \<turnstile> (0, s', sp) \<rightarrow>* (size ?ac, si, sp - 1)"
+    and Hs1: "stack_eq sp s' si"
+    and Ha1: "\<forall>a\<ge>0. s' a = si a"
+    and Hv1: "si (sp - 1) = ?av" by auto
+  show ?case
+  proof (intro exI conjI)
+    let ?t' = "si(m x := si (sp - 1))"
+    from Assign(2, 3) have "[STORE (m x)] \<turnstile> (0, si, sp - 1) \<rightarrow>* (1, ?t', sp)" by fastforce
+    with He1 show "?cc \<turnstile> (0, s', sp) \<rightarrow>* (size ?cc, ?t', sp)" by auto
+    have H1: "x \<in> svars_in (x ::= a)" by simp
+    show "on_eq (svars_in (x ::= a)) (s(x := aval a s)) (si(m x := si (sp - 1)) \<circ> m)"
+    proof
+      fix v
+      assume H2: "v \<in> svars_in (x ::= a)"
+      show "(s(x := aval a s)) v = (si(m x := si (sp - 1)) \<circ> m) v"
+      proof (cases "v = x")
+        case False
+        then have "(s(x := aval a s)) v = s v" by simp
+        also from Assign(4) H2 have "\<dots> = s' (m v)" by simp
+        also from Assign(3,4) Ha1 H2 have "\<dots> = si (m v)" by simp
+        also from Assign(1) H1 H2 False have "\<dots> = (si(m x := si (sp - 1)) \<circ> m) v" using inj_onD by fastforce
+        finally show ?thesis .
+      qed (simp add: Hv1)
+    qed
+    from Ha1 H1 show "\<forall>a'\<ge>0. a' \<notin> m ` svars_in (x ::= a) \<longrightarrow> s' a' = (si(m x := si (sp - 1))) a'" by auto
+  qed
+next
+  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
+  let ?c1 = "ccomp m c\<^sub>1" and ?c2 = "ccomp m c\<^sub>2" and ?cs = "ccomp m (c\<^sub>1;; c\<^sub>2)"
+    and ?s1 = "svars_in c\<^sub>1" and ?s2 = "svars_in c\<^sub>2" and ?ss = "svars_in (c\<^sub>1;; c\<^sub>2)"
+  from Seq(2, 5-8) have "\<exists>t'. (?c1 \<turnstile> (0, s', sp) \<rightarrow>* (size ?c1, t', sp)) \<and>
+    on_eq ?s1 s\<^sub>2 (t' \<circ> m) \<and> (\<forall>a\<ge>0. a \<notin> m ` ?s1 \<longrightarrow> s' a = t' a)" using inj_on_subset by fastforce
+  then obtain s\<^sub>2' where He1: "?c1 \<turnstile> (0, s', sp) \<rightarrow>* (size ?c1, s\<^sub>2', sp)"
+    and Hv1: "on_eq ?s1 s\<^sub>2 (s\<^sub>2' \<circ> m)"
+    and Ha1: "\<forall>a\<ge>0. a \<notin> m ` ?s1 \<longrightarrow> s' a = s\<^sub>2' a" by auto
+  have Hv1': "on_eq ?ss s\<^sub>2 (s\<^sub>2' \<circ> m)"
+    using map_invariance [OF Seq(5) Seq(7) Seq(1) _ Seq(8) Hv1 Ha1] by simp
+  from Seq(4, 5-7) Hv1' have "\<exists>t'. (?c2 \<turnstile> (0, s\<^sub>2', sp) \<rightarrow>* (size ?c2, t', sp)) \<and>
+    on_eq ?s2 s\<^sub>3 (t' \<circ> m) \<and> (\<forall>a\<ge>0. a \<notin> m ` ?s2 \<longrightarrow> s\<^sub>2' a = t' a)" using inj_on_subset by fastforce
+  then obtain s\<^sub>3' where He2: "?c2 \<turnstile> (0, s\<^sub>2', sp) \<rightarrow>* (size ?c2, s\<^sub>3', sp)"
+    and Hv2: "on_eq ?s2 s\<^sub>3 (s\<^sub>3' \<circ> m)"
+    and Ha2: "\<forall>a\<ge>0. a \<notin> m ` ?s2 \<longrightarrow> s\<^sub>2' a = s\<^sub>3' a" by auto
+  show ?case
+  proof (intro exI conjI)
+    from He1 He2 show "?cs \<turnstile> (0, s', sp) \<rightarrow>* (size ?cs, s\<^sub>3', sp)" by auto
+    show "on_eq ?ss s\<^sub>3 (s\<^sub>3' \<circ> m)"
+      using map_invariance [OF Seq(5) Seq(7) Seq(3) _ Hv1' Hv2 Ha2] by simp
+    from Ha1 Ha2 show "\<forall>a\<ge>0. a \<notin> m ` ?ss \<longrightarrow> s' a = s\<^sub>3' a" by fastforce
+  qed
+next
+  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
+  let ?cc1 = "ccomp m c\<^sub>1" and ?cc2 = "ccomp m c\<^sub>2" and ?ci = "ccomp m (IF b THEN c\<^sub>1 ELSE c\<^sub>2)"
+    and ?sb = "set (vars_in_bexp b)" and ?sc1 = "svars_in c\<^sub>1" and ?sc2 = "svars_in c\<^sub>2"
+    and ?si = "svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2)"
+  let ?cb = "bcomp m b False (size ?cc1 + 1)"
+  from bcomp_correct [OF IfTrue(5) IfTrue(6) _ _, of b s s' "size ?cc1 + 1" False] IfTrue(1, 7)
+  have "\<exists>t'. (?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb, t', sp)) \<and>
+         stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by simp
+  then obtain si where Heb: "?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb, si, sp)"
+    and Hsb: "stack_eq sp s' si"
+    and Hab: "\<forall>a\<ge>0. s' a = si a" by auto
+  from IfTrue(6, 7) Hab have Heqb': "on_eq ?si s (si \<circ> m)" by simp
+  then have Heqc: "on_eq ?sc1 s (si \<circ> m)" by simp
+  from IfTrue(3) [OF _ IfTrue(5) IfTrue(6) Heqc] IfTrue(4)
+  have "\<exists>t'. (?cc1 \<turnstile> (0, si, sp) \<rightarrow>* (size ?cc1, t', sp)) \<and>
+       on_eq ?sc1 t (t' \<circ> m) \<and> (\<forall>a\<ge>0. a \<notin> m ` ?sc1 \<longrightarrow> si a = t' a)"
+    using inj_on_subset by auto
+  then obtain t' where Hec: "?cc1 \<turnstile> (0, si, sp) \<rightarrow>* (size ?cc1, t', sp)"
+    and Hsc: "on_eq ?sc1 t (t' \<circ> m)"
+    and Hac: "\<forall>a\<ge>0. a \<notin> m ` ?sc1 \<longrightarrow> si a = t' a" by auto
+  show ?case
+  proof (intro exI conjI)
+    from IfTrue(5) have "JMP (size ?cc2) # ?cc2 \<turnstile> (0, t', sp) \<rightarrow> (size ?cc2 + 1, t', sp)" by fastforce
+    with Heb Hec show "?ci \<turnstile> (0, s', sp) \<rightarrow>* (size ?ci, t', sp)" by (fastforce simp add: add.assoc)
+    from map_invariance [OF IfTrue(4) IfTrue(6) IfTrue(2) _ Heqb' Hsc Hac]
+    show "on_eq ?si t (t' \<circ> m)" by auto
+    from Hab Hac show "\<forall>a\<ge>0. a \<notin> m ` ?si \<longrightarrow> s' a = t' a" by auto
+  qed
+next
+  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
+  let ?cc1 = "ccomp m c\<^sub>1" and ?cc2 = "ccomp m c\<^sub>2" and ?ci = "ccomp m (IF b THEN c\<^sub>1 ELSE c\<^sub>2)"
+    and ?sb = "set (vars_in_bexp b)" and ?sc1 = "svars_in c\<^sub>1" and ?sc2 = "svars_in c\<^sub>2"
+    and ?si = "svars_in (IF b THEN c\<^sub>1 ELSE c\<^sub>2)"
+  let ?cb = "bcomp m b False (size ?cc1 + 1)"
+  from bcomp_correct [OF IfFalse(5) IfFalse(6), of b s s' "size ?cc1 + 1" False] IfFalse(7)
+  have "\<exists>t'. (?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb + (if False = bval b s then size ?cc1 + 1 else 0), t', sp)) \<and>
+         stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by fastforce
+  then have "\<exists>t'. (?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb + size ?cc1 + 1, t', sp)) \<and>
+         stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by (smt IfFalse(1))
+  then obtain si where Heb: "?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb + size ?cc1 + 1, si, sp)"
+    and Hsb: "stack_eq sp s' si"
+    and Hab: "\<forall>a\<ge>0. s' a = si a" by auto
+  from IfFalse(6, 7) Hab have Heqb': "on_eq ?si s (si \<circ> m)" by simp
+  from IfFalse(3) [OF _ IfFalse(5) IfFalse(6), of si] IfFalse(4) Heqb'
+  have "\<exists>t'. (?cc2 \<turnstile> (0, si, sp) \<rightarrow>* (size ?cc2, t', sp)) \<and>
+             on_eq ?sc2 t (t' \<circ> m) \<and> (\<forall>a\<ge>0. a \<notin> m ` ?sc2 \<longrightarrow> si a = t' a)"
+    using inj_on_subset by fastforce
+  then have "\<exists>t'. (?cc1 @ JMP (size ?cc2) # ?cc2 \<turnstile> (size ?cc1 + 1, si, sp) \<rightarrow>* (size ?cc1 + 1 + size ?cc2, t', sp)) \<and>
+             on_eq ?sc2 t (t' \<circ> m) \<and> (\<forall>a\<ge>0. a \<notin> m ` ?sc2 \<longrightarrow> si a = t' a)"
+    by fastforce
+  then obtain t' where Hec: "?cc1 @ JMP (size ?cc2) # ?cc2 \<turnstile> (size ?cc1 + 1, si, sp) \<rightarrow>* (size ?cc1 + 1 + size ?cc2, t', sp)"
+    and Hsc: "on_eq ?sc2 t (t' \<circ> m)"
+    and Hac: "\<forall>a\<ge>0. a \<notin> m ` ?sc2 \<longrightarrow> si a = t' a" by auto
+  show ?case
+  proof (intro exI conjI)
+    from Heb Hec show "?ci \<turnstile> (0, s', sp) \<rightarrow>* (size ?ci, t', sp)" by fastforce
+    from map_invariance [OF IfFalse(4) IfFalse(6) IfFalse(2) _ Heqb' Hsc Hac]
+    show "on_eq ?si t (t' \<circ> m)" by auto
+    from Hab Hac show "\<forall>a\<ge>0. a \<notin> m ` ?si \<longrightarrow> s' a = t' a" by auto
+  qed
+next
+  case (WhileFalse b s c)
+  let ?cc = "ccomp m c" and ?cw = "ccomp m (WHILE b DO c)" and ?sw = "svars_in (WHILE b DO c)"
+  let ?cb = "bcomp m b False (size ?cc + 1)"
+  from bcomp_correct [OF WhileFalse(3) WhileFalse(4), of b s s' "size ?cc + 1" False] WhileFalse(5)
+  have "\<exists>t'. (?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb + (if False = bval b s then size ?cc + 1 else 0), t', sp)) \<and>
+             stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by auto
+  then have "\<exists>t'. (?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb + size ?cc + 1, t', sp)) \<and>
+             stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by (smt WhileFalse(1))
+  then have "\<exists>t'. (?cw \<turnstile> (0, s', sp) \<rightarrow>* (size ?cw, t', sp)) \<and>
+             stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by fastforce
+  then obtain si where Heb: "?cw \<turnstile> (0, s', sp) \<rightarrow>* (size ?cw, si, sp)"
+    and Hsb: "stack_eq sp s' si"
+    and Hab: "\<forall>a\<ge>0. s' a = si a" by auto
+  show ?case
+  proof (intro exI conjI)
+    from Heb show "?cw \<turnstile> (0, s', sp) \<rightarrow>* (size ?cw, si, sp)" .
+    from WhileFalse(4, 5) Hab show "on_eq ?sw s (si \<circ> m)" by simp
+    from Hab show "\<forall>a\<ge>0. a \<notin> m ` svars_in (WHILE b DO c) \<longrightarrow> s' a = si a" by simp
+  qed
+next
+  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
+  let ?cc = "ccomp m c" and ?cw = "ccomp m (WHILE b DO c)" and ?sc = "svars_in c" and ?sw = "svars_in (WHILE b DO c)"
+  let ?cb = "bcomp m b False (size ?cc + 1)"
+  from bcomp_correct [OF WhileTrue(7) WhileTrue(8), of b s\<^sub>1 s' "size ?cc + 1" False] WhileTrue(9)
+  have "\<exists>t'. (?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb + (if False = bval b s\<^sub>1 then size ?cc + 1 else 0), t', sp)) \<and>
+             stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by auto
+  then have "\<exists>t'. (?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb, t', sp)) \<and>
+             stack_eq sp s' t' \<and> (\<forall>a\<ge>0. s' a = t' a)" by (smt WhileTrue(1))
+  then obtain si where He1: "?cb \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb, si, sp)"
+    and Hs1: "stack_eq sp s' si"
+    and Ha1: "\<forall>a\<ge>0. s' a = si a" by auto
+
+  from Ha1 WhileTrue(8, 9) have Heq1: "on_eq ?sw s\<^sub>1 (si \<circ> m)" by simp
+  from WhileTrue(3) [OF _ WhileTrue(7) WhileTrue(8), of si] WhileTrue(6) Heq1
+  have "\<exists>t'. (?cc \<turnstile> (0, si, sp) \<rightarrow>* (size ?cc, t', sp)) \<and>
+           on_eq ?sc s\<^sub>2 (t' \<circ> m) \<and> (\<forall>a\<ge>0. a \<notin> m ` ?sc \<longrightarrow> si a = t' a)"
+    using inj_on_subset by auto
+  then obtain s\<^sub>2' where He2: "?cc \<turnstile> (0, si, sp) \<rightarrow>* (size ?cc, s\<^sub>2', sp)"
+    and Hs2: "on_eq ?sc s\<^sub>2 (s\<^sub>2' \<circ> m)"
+    and Ha2: "\<forall>a\<ge>0. a \<notin> m ` ?sc \<longrightarrow> si a = s\<^sub>2' a" by auto
+
+  from He1 He2 have "?cw \<turnstile> (0, s', sp) \<rightarrow>* (size ?cb + size ?cc, s\<^sub>2', sp)" by fastforce
+  moreover from WhileTrue(7) have "?cw \<turnstile> (size ?cb + size ?cc, s\<^sub>2', sp) \<rightarrow>* (0, s\<^sub>2', sp)" by fastforce
+  ultimately have He12: "?cw \<turnstile> (0, s', sp) \<rightarrow>* (0, s\<^sub>2', sp)" using star_trans by auto
+
+  have Heq2: "on_eq (svars_in (WHILE b DO c)) s\<^sub>2 (s\<^sub>2' \<circ> m)"
+    using map_invariance [OF WhileTrue(6) WhileTrue(8) WhileTrue(2) _ Heq1 Hs2 Ha2] by simp
+  from WhileTrue(5) [OF WhileTrue(6) WhileTrue(7) WhileTrue(8) Heq2]
+  have "\<exists>t'. (?cw \<turnstile> (0, s\<^sub>2', sp) \<rightarrow>* (size ?cw, t', sp)) \<and>
+     on_eq ?sw s\<^sub>3 (t' \<circ> m) \<and> (\<forall>a\<ge>0. a \<notin> m ` ?sw \<longrightarrow> s\<^sub>2' a = t' a)" .
+  then obtain s\<^sub>3' where He3: "?cw \<turnstile> (0, s\<^sub>2', sp) \<rightarrow>* (size ?cw, s\<^sub>3', sp)"
+    and Hs3: "on_eq ?sw s\<^sub>3 (s\<^sub>3' \<circ> m)"
+    and Ha3: "\<forall>a\<ge>0. a \<notin> m ` ?sw \<longrightarrow> s\<^sub>2' a = s\<^sub>3' a" by auto
+  show ?case
+  proof (intro exI conjI)
+    from He12 He3 show "?cw \<turnstile> (0, s', sp) \<rightarrow>* (size ?cw, s\<^sub>3', sp)" using star_trans by auto
+    from Hs3 show "on_eq ?sw s\<^sub>3 (s\<^sub>3' \<circ> m)" .
+    from Ha1 Ha2 Ha3 show "\<forall>a\<ge>0. a \<notin> m ` ?sw \<longrightarrow> s' a = s\<^sub>3' a" by auto
+  qed
+qed
+
+lemma ccomp_bigstep_addr_of: "\<lbrakk>
+  (c, s) \<Rightarrow> t;
+  sp \<le> 0;
+  on_eq (svars_in c) s (s' \<circ> (addr_of c))
+\<rbrakk> \<Longrightarrow> \<exists> t'. (ccomp (addr_of c) c \<turnstile> (0, s', sp) \<rightarrow>* (size (ccomp (addr_of c) c), t', sp)) \<and>
+  on_eq (svars_in c) t (t' \<circ> (addr_of c)) \<and>
+  (\<forall> a \<ge> 0. a \<notin> (addr_of c) ` (svars_in c) \<longrightarrow> s' a = t' a)" using ccomp_bigstep inj_on_addr_of by fastforce
+
+end
\ No newline at end of file
diff --git a/Short_Theory_9_3.thy b/Short_Theory_9_3.thy
new file mode 100644
index 0000000..6fb5c3e
--- /dev/null
+++ b/Short_Theory_9_3.thy
@@ -0,0 +1,184 @@
+theory Short_Theory_9_3 imports "HOL-IMP.Star" Complex_Main begin
+
+datatype val = Iv int | Rv real
+
+type_synonym vname = string
+type_synonym state = "vname \<Rightarrow> val"
+
+datatype aexp =  Ic int | Rc real | V vname | Plus aexp aexp
+
+inductive taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
+"taval (Ic i) s (Iv i)" |
+"taval (Rc r) s (Rv r)" |
+"taval (V x) s (s x)" |
+"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2)
+ \<Longrightarrow> taval (Plus a1 a2) s (Iv (i1 + i2))" |
+"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2)
+ \<Longrightarrow> taval (Plus a1 a2) s (Rv (r1 + r2))"
+
+inductive_cases [elim!]:
+  "taval (Ic i) s v"  "taval (Rc i) s v"
+  "taval (V x) s v"
+  "taval (Plus a1 a2) s v"
+
+datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp
+
+inductive tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool" where
+"tbval (Bc v) s v" |
+"tbval b s bv \<Longrightarrow> tbval (Not b) s (\<not> bv)" |
+"tbval b1 s bv1 \<Longrightarrow> tbval b2 s bv2 \<Longrightarrow> tbval (And b1 b2) s (bv1 & bv2)" |
+"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2) \<Longrightarrow> tbval (Less a1 a2) s (i1 < i2)" |
+"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2) \<Longrightarrow> tbval (Less a1 a2) s (r1 < r2)"
+
+datatype
+  com = SKIP 
+      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
+      | Seq    com  com         ("_;; _"  [60, 61] 60)
+      | If     bexp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
+      | While  bexp com         ("WHILE _ DO _"  [0, 61] 61)
+      | Repeat com bexp         ("REPEAT _/ UNTIL _" [60, 0] 61)
+
+inductive small_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>" 55) where
+  Assign: "taval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |
+  Seq1: "(SKIP;;c,s) \<rightarrow> (c,s)" |
+  Seq2: "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |
+  IfTrue: "tbval b s True \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
+  IfFalse: "tbval b s False \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |
+  While: "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
+  Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"
+
+lemmas small_step_induct = small_step.induct[split_format(complete)]
+
+datatype ty = Ity | Rty
+
+type_synonym tyenv = "vname \<Rightarrow> ty"
+
+inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
+  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
+where
+Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
+Rc_ty: "\<Gamma> \<turnstile> Rc r : Rty" |
+V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
+Plus_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : \<tau>"
+
+declare atyping.intros [intro!]
+inductive_cases [elim!]:
+  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Rc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"
+
+inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>" 50)
+where
+B_ty: "\<Gamma> \<turnstile> Bc v" |
+Not_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> Not b" |
+And_ty: "\<Gamma> \<turnstile> b1 \<Longrightarrow> \<Gamma> \<turnstile> b2 \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2" |
+Less_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2"
+
+declare btyping.intros [intro!]
+inductive_cases [elim!]: "\<Gamma> \<turnstile> Not b" "\<Gamma> \<turnstile> And b1 b2" "\<Gamma> \<turnstile> Less a1 a2"
+
+inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
+Skip_ty: "\<Gamma> \<turnstile> SKIP" |
+Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
+Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
+If_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
+While_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c" |
+Repeat_ty: "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> REPEAT c UNTIL b"
+
+declare ctyping.intros [intro!]
+inductive_cases [elim!]:
+  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
+  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
+  "\<Gamma> \<turnstile> WHILE b DO c"
+  "\<Gamma> \<turnstile> REPEAT c UNTIL b"
+
+fun type :: "val \<Rightarrow> ty" where
+"type (Iv i) = Ity" |
+"type (Rv r) = Rty"
+
+lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
+by (cases v) simp_all
+
+lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
+by (cases v) simp_all
+
+definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
+where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"
+
+lemma apreservation: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> taval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
+  by(induct arbitrary: v rule: atyping.induct) (fastforce simp: styping_def)+
+
+lemma aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. taval a s v"
+proof(induct rule: atyping.induct)
+  case (Plus_ty \<Gamma> a1 t a2)
+  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2" by blast
+  show ?case
+  proof (cases v1)
+    case Iv
+    with Plus_ty v show ?thesis
+      by(fastforce intro: taval.intros(4) dest!: apreservation)
+  next
+    case Rv
+    with Plus_ty v show ?thesis
+      by(fastforce intro: taval.intros(5) dest!: apreservation)
+  qed
+qed (auto intro: taval.intros)
+
+lemma bprogress: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. tbval b s v"
+proof(induct rule: btyping.induct)
+  case (Less_ty \<Gamma> a1 t a2)
+  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2"
+    by (metis aprogress)
+  show ?case
+  proof (cases v1)
+    case Iv
+    with Less_ty v show ?thesis
+      by (fastforce intro!: tbval.intros(4) dest!:apreservation)
+  next
+    case Rv
+    with Less_ty v show ?thesis
+      by (fastforce intro!: tbval.intros(5) dest!:apreservation)
+  qed
+qed (auto intro: tbval.intros)
+
+theorem progress: "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
+proof(induct rule: ctyping.induct)
+  case Skip_ty thus ?case by simp
+next
+  case Assign_ty 
+  thus ?case by (metis Assign aprogress)
+next
+  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
+next
+  case (If_ty \<Gamma> b c1 c2)
+  then obtain bv where "tbval b s bv" by (metis bprogress)
+  show ?case
+  proof(cases bv)
+    assume "bv"
+    with \<open>tbval b s bv\<close> show ?case by simp (metis IfTrue)
+  next
+    assume "\<not>bv"
+    with \<open>tbval b s bv\<close> show ?case by simp (metis IfFalse)
+  qed
+next
+  case While_ty show ?case by (metis While)
+next
+  case Repeat_ty show ?case by (metis Repeat)
+qed
+
+theorem styping_preservation: "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
+proof(induct rule: small_step_induct)
+  case Assign thus ?case
+    by (auto simp: styping_def) (metis Assign(1,3) apreservation)
+qed auto
+
+theorem ctyping_preservation: "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
+by (induct rule: small_step_induct) (auto simp: ctyping.intros)
+
+abbreviation small_steps :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
+where "x \<rightarrow>* y == star small_step x y"
+
+theorem type_sound: "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
+   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
+  by (induction rule:star_induct)
+    ((metis progress)?, metis styping_preservation ctyping_preservation)
+
+end
diff --git a/Short_Theory_9_4.thy b/Short_Theory_9_4.thy
new file mode 100644
index 0000000..7213e22
--- /dev/null
+++ b/Short_Theory_9_4.thy
@@ -0,0 +1,152 @@
+theory Short_Theory_9_4 imports "HOL-IMP.Star" Complex_Main begin
+
+datatype val = Iv int | Bv bool
+
+type_synonym vname = string
+type_synonym state = "vname \<Rightarrow> val"
+
+datatype exp =  Ic int | Bc bool | V vname | Not exp | Plus exp exp | And exp exp | Less exp exp
+
+inductive eval :: "exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
+"eval (Ic i) _ (Iv i)" |
+"eval (Bc v) _ (Bv v)" |
+"eval (V x) s (s x)" |
+"eval e s (Bv v) \<Longrightarrow> eval (Not e) s (Bv (\<not> v))" |
+"\<lbrakk>eval a1 s (Iv i1); eval a2 s (Iv i2)\<rbrakk>
+ \<Longrightarrow> eval (Plus a1 a2) s (Iv (i1 + i2))" |
+"\<lbrakk>eval b1 s (Bv v1); eval b2 s (Bv v2)\<rbrakk>
+ \<Longrightarrow> eval (And b1 b2) s (Bv (v1 \<and> v2))" |
+"\<lbrakk>eval a1 s (Iv i1); eval a2 s (Iv i2)\<rbrakk>
+ \<Longrightarrow> eval (Less a1 a2) s (Bv (i1 < i2))"
+
+inductive_cases [elim!]:
+  "eval (Ic i) s v"
+  "eval (Bc bv) s v"
+  "eval (V x) s v"
+  "eval (Plus a1 a2) s v"
+  "eval (And b1 b2) s v"
+  "eval (Less a1 a2) s v"
+
+datatype
+  com = SKIP 
+      | Assign vname exp       ("_ ::= _" [1000, 61] 61)
+      | Seq    com  com         ("_;; _"  [60, 61] 60)
+      | If     exp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
+      | While  exp com         ("WHILE _ DO _"  [0, 61] 61)
+
+inductive small_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>" 55) where
+  Assign: "eval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |
+  Seq1: "(SKIP;; c, s) \<rightarrow> (c, s)" |
+  Seq2: "(c1, s) \<rightarrow> (c1', s') \<Longrightarrow> (c1;; c2,s) \<rightarrow> (c1';; c2,s')" |
+  IfTrue: "eval b s (Bv True) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1, s)" |
+  IfFalse: "eval b s (Bv False) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2, s)" |
+  While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)"
+
+lemmas small_step_induct = small_step.induct[split_format(complete)]
+
+datatype ty = Ity | Bty
+
+type_synonym tyenv = "vname \<Rightarrow> ty"
+
+inductive etyping :: "tyenv \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool"
+  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
+where
+Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
+Bc_ty: "\<Gamma> \<turnstile> Bc r : Bty" |
+V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
+Plus_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : Ity" |
+And_ty: "\<Gamma> \<turnstile> b1 : Bty \<Longrightarrow> \<Gamma> \<turnstile> b2 : Bty \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2 : Bty" |
+Less_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2 : Bty"
+
+declare etyping.intros [intro!]
+inductive_cases [elim!]:
+  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Bc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"
+  "\<Gamma> \<turnstile> And b1 b2 : \<tau>" "\<Gamma> \<turnstile> Less a1 a2 : \<tau>"
+
+inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
+Skip_ty: "\<Gamma> \<turnstile> SKIP" |
+Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma> x \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
+Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;; c2" |
+If_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
+While_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"
+
+declare ctyping.intros [intro!]
+inductive_cases [elim!]:
+  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
+  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
+  "\<Gamma> \<turnstile> WHILE b DO c"
+
+fun type :: "val \<Rightarrow> ty" where
+  "type (Iv i) = Ity" |
+  "type (Bv r) = Bty"
+
+lemma type_eq_Ity [simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
+  by (cases v) auto
+
+lemma type_eq_Bty [simp]: "type v = Bty \<longleftrightarrow> (\<exists>b. v = Bv b)"
+  by (cases v) simp_all
+
+definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50) where
+  "\<Gamma> \<turnstile> s \<longleftrightarrow> (\<forall>x. type (s x) = \<Gamma> x)"
+
+lemma epreservation: "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> eval e s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
+  by(induct arbitrary: v rule: etyping.induct) (fastforce simp: styping_def)+
+
+lemma eprogress: "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. eval e s v"
+proof(induct rule: etyping.induct)
+  case (Plus_ty \<Gamma> a1 a2)
+  then obtain v1 v2 where v: "eval a1 s v1" "eval a2 s v2" by blast
+  with Plus_ty show ?case by (fastforce intro: eval.intros(5) dest!: epreservation)
+next
+  case (And_ty \<Gamma> b1 b2)
+  thm eval.intros
+  then obtain v1 v2 where v: "eval b1 s v1" "eval b2 s v2" by blast
+  with And_ty show ?case by (fastforce intro: eval.intros(6) dest!: epreservation)
+next
+  case (Less_ty \<Gamma> a1 a2)
+  then obtain v1 v2 where v: "eval a1 s v1" "eval a2 s v2" by blast
+  with Less_ty show ?case by (fastforce intro: eval.intros(7) dest!: epreservation)
+qed (auto intro: eval.intros)
+
+theorem progress: "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c, s) \<rightarrow> cs'"
+proof(induct rule: ctyping.induct)
+  case Skip_ty thus ?case by simp
+next
+  case Assign_ty 
+  thus ?case by (metis Assign eprogress)
+next
+  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
+next
+  case (If_ty \<Gamma> b c1 c2)
+  then obtain bv where Heval: "eval b s bv" by (metis eprogress)
+  with If_ty(1, 6) obtain b where Hb: "bv = Bv b" by (auto dest!: epreservation)
+  show ?case
+  proof (cases b)
+    case True
+    with Heval Hb show ?thesis by simp (metis IfTrue)
+  next
+    case False
+    with Heval Hb show ?thesis by simp (metis IfFalse)
+  qed
+next
+  case While_ty show ?case by (metis While)
+qed
+
+theorem styping_preservation: "(c, s) \<rightarrow> (c', s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
+proof(induct rule: small_step_induct)
+  case Assign thus ?case
+    by (auto simp: styping_def) (metis Assign(1,3) epreservation)
+qed auto
+
+theorem ctyping_preservation: "(c, s) \<rightarrow> (c', s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
+by (induct rule: small_step_induct) (auto simp: ctyping.intros)
+
+abbreviation small_steps :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
+where "x \<rightarrow>* y == star small_step x y"
+
+theorem type_sound: "(c, s) \<rightarrow>* (c', s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
+   \<Longrightarrow> \<exists>cs''. (c', s') \<rightarrow> cs''"
+  by (induction rule: star_induct)
+    ((metis progress)?, metis styping_preservation ctyping_preservation)
+
+end
diff --git a/Short_Theory_AExp.thy b/Short_Theory_AExp.thy
new file mode 100644
index 0000000..1b66b40
--- /dev/null
+++ b/Short_Theory_AExp.thy
@@ -0,0 +1,67 @@
+theory Short_Theory_AExp
+  imports Main
+begin
+
+type_synonym vname = string
+datatype aexp = N int | V vname | Plus aexp aexp | Times aexp aexp
+
+type_synonym val = int
+type_synonym state = "vname \<Rightarrow> val"
+
+fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
+  "aval (N n) _ = n" |
+  "aval (V x) s = s x" |
+  "aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s" |
+  "aval (Times a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s * aval a\<^sub>2 s"
+
+fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
+  "plus (N i\<^sub>1) (N i\<^sub>2) = N (i\<^sub>1 + i\<^sub>2)" |
+  "plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
+  "plus a (N i) = (if i = 0 then a else Plus a (N i))" |
+  "plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
+
+fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
+  "times (N i\<^sub>1) (N i\<^sub>2) = N (i\<^sub>1 * i\<^sub>2)" |
+  "times (N i) a = (if i = 1 then a else Times (N i) a)" |
+  "times a (N i) = (if i = 1 then a else Times a (N i))" |
+  "times a\<^sub>1 a\<^sub>2 = Times a\<^sub>1 a\<^sub>2"
+
+fun asimp_const :: "aexp \<Rightarrow> aexp" where
+  "asimp_const (N n) = N n" |
+  "asimp_const (V x) = V x" |
+  "asimp_const (Plus a\<^sub>1 a\<^sub>2) =
+    (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
+      (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N (n\<^sub>1 + n\<^sub>2) |
+      (b\<^sub>1, b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)" |
+  "asimp_const (Times a\<^sub>1 a\<^sub>2) =
+    (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
+      (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N (n\<^sub>1 * n\<^sub>2) |
+      (b\<^sub>1, b\<^sub>2) \<Rightarrow> Times b\<^sub>1 b\<^sub>2)"
+
+lemma "aval (asimp_const a) s = aval a s"
+  apply (induction a)
+    apply (auto split: aexp.split)
+  done
+
+lemma aval_plus: "aval (plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
+  apply (induction a\<^sub>1 a\<^sub>2 rule: plus.induct)
+              apply auto
+  done
+
+lemma aval_times: "aval (times a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s * aval a\<^sub>2 s"
+  apply (induction a\<^sub>1 a\<^sub>2 rule: times.induct)
+              apply auto
+  done
+
+fun asimp :: "aexp \<Rightarrow> aexp" where
+  "asimp (N n) = N n" |
+  "asimp (V x) = V x" |
+  "asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)" |
+  "asimp (Times a\<^sub>1 a\<^sub>2) = times (asimp a\<^sub>1) (asimp a\<^sub>2)"
+
+lemma aval_asimp [simp]: "aval (asimp a) s = aval a s"
+  apply (induction a)
+    apply (auto simp add: aval_plus aval_times)
+  done
+
+end
\ No newline at end of file
diff --git a/Short_Theory_ASM.thy b/Short_Theory_ASM.thy
new file mode 100644
index 0000000..06bcec8
--- /dev/null
+++ b/Short_Theory_ASM.thy
@@ -0,0 +1,39 @@
+theory Short_Theory_ASM
+  imports "HOL-IMP.AExp"
+begin
+
+datatype instr = LOADI val | LOAD vname | ADD
+type_synonym stack = "val list"
+
+fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
+  "exec1 (LOADI n) _ stk = Some (n # stk)" |
+  "exec1 (LOAD x) s stk = Some (s x # stk)" |
+  "exec1 ADD _ (j # i # stk) = Some ((i + j) # stk)" |
+  "exec1 ADD _ _ = None"
+
+fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
+  "exec [] _ stk = Some stk" |
+  "exec (i # is) s stk =
+    (case exec1 i s stk of
+      Some stk\<^sub>i \<Rightarrow> exec is s stk\<^sub>i |
+      None \<Rightarrow> None)"
+
+fun comp :: "aexp \<Rightarrow> instr list" where
+  "comp (N n) = [LOADI n]" |
+  "comp (V x) = [LOAD x]" |
+  "comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
+
+lemma exec_app: "exec (is\<^sub>1 @ is\<^sub>2) s stk =
+  (case exec is\<^sub>1 s stk of
+    Some stk\<^sub>1 \<Rightarrow> exec is\<^sub>2 s stk\<^sub>1 |
+    None \<Rightarrow> None)"
+  apply (induction is\<^sub>1 arbitrary: stk)
+   apply (auto split: option.split)
+  done
+
+lemma "exec (comp a) s stk = Some (aval a s # stk)"
+  apply (induction a arbitrary: stk)
+    apply (auto simp add: exec_app)
+  done
+
+end
\ No newline at end of file